src/HOL/Tools/sat_solver.ML
changeset 15531 08c8dad8e399
parent 15332 0dc05858a862
child 15570 8d8c70b41bab
equal deleted inserted replaced
15530:6f43714517ee 15531:08c8dad8e399
    41 (* ------------------------------------------------------------------------- *)
    41 (* ------------------------------------------------------------------------- *)
    42 
    42 
    43 	exception NOT_CONFIGURED;
    43 	exception NOT_CONFIGURED;
    44 
    44 
    45 (* ------------------------------------------------------------------------- *)
    45 (* ------------------------------------------------------------------------- *)
    46 (* type of partial (satisfying) assignments: 'a i = None' means that 'a' is  *)
    46 (* type of partial (satisfying) assignments: 'a i = NONE' means that 'a' is  *)
    47 (*      a satisfying assigment regardless of the value of variable 'i'       *)
    47 (*      a satisfying assigment regardless of the value of variable 'i'       *)
    48 (* ------------------------------------------------------------------------- *)
    48 (* ------------------------------------------------------------------------- *)
    49 
    49 
    50 	type assignment = int -> bool option;
    50 	type assignment = int -> bool option;
    51 
    51 
   184 
   184 
   185 	(* Path.T -> string * string * string -> result *)
   185 	(* Path.T -> string * string * string -> result *)
   186 
   186 
   187 	fun parse_std_result_file path (satisfiable, assignment_prefix, unsatisfiable) =
   187 	fun parse_std_result_file path (satisfiable, assignment_prefix, unsatisfiable) =
   188 	let
   188 	let
   189 		(* 'a option -> 'a Library.option *)
   189 		(* 'a option -> 'a option *)
   190 		fun option (SOME a) =
   190 		fun option (SOME a) =
   191 			Some a
   191 			SOME a
   192 		  | option NONE =
   192 		  | option NONE =
   193 			None
   193 			NONE
   194 		(* string -> int list *)
   194 		(* string -> int list *)
   195 		fun int_list_from_string s =
   195 		fun int_list_from_string s =
   196 			mapfilter (option o Int.fromString) (space_explode " " s)
   196 			mapfilter (option o Int.fromString) (space_explode " " s)
   197 		(* int list -> assignment *)
   197 		(* int list -> assignment *)
   198 		fun assignment_from_list [] i =
   198 		fun assignment_from_list [] i =
   199 			None  (* the SAT solver didn't provide a value for this variable *)
   199 			NONE  (* the SAT solver didn't provide a value for this variable *)
   200 		  | assignment_from_list (x::xs) i =
   200 		  | assignment_from_list (x::xs) i =
   201 			if x=i then (Some true)
   201 			if x=i then (SOME true)
   202 			else if x=(~i) then (Some false)
   202 			else if x=(~i) then (SOME false)
   203 			else assignment_from_list xs i
   203 			else assignment_from_list xs i
   204 		(* int list -> string list -> assignment *)
   204 		(* int list -> string list -> assignment *)
   205 		fun parse_assignment xs [] =
   205 		fun parse_assignment xs [] =
   206 			assignment_from_list xs
   206 			assignment_from_list xs
   207 		  | parse_assignment xs (line::lines) =
   207 		  | parse_assignment xs (line::lines) =
   363 		(* int list *)
   363 		(* int list *)
   364 		val indices = PropLogic.indices fm
   364 		val indices = PropLogic.indices fm
   365 		(* int list -> int list -> int list option *)
   365 		(* int list -> int list -> int list option *)
   366 		(* binary increment: list 'xs' of current bits, list 'ys' of all bits (lower bits first) *)
   366 		(* binary increment: list 'xs' of current bits, list 'ys' of all bits (lower bits first) *)
   367 		fun next_list _ ([]:int list) =
   367 		fun next_list _ ([]:int list) =
   368 			None
   368 			NONE
   369 		  | next_list [] (y::ys) =
   369 		  | next_list [] (y::ys) =
   370 			Some [y]
   370 			SOME [y]
   371 		  | next_list (x::xs) (y::ys) =
   371 		  | next_list (x::xs) (y::ys) =
   372 			if x=y then
   372 			if x=y then
   373 				(* reset the bit, continue *)
   373 				(* reset the bit, continue *)
   374 				next_list xs ys
   374 				next_list xs ys
   375 			else
   375 			else
   376 				(* set the lowest bit that wasn't set before, keep the higher bits *)
   376 				(* set the lowest bit that wasn't set before, keep the higher bits *)
   377 				Some (y::x::xs)
   377 				SOME (y::x::xs)
   378 		(* int list -> int -> bool *)
   378 		(* int list -> int -> bool *)
   379 		fun assignment_from_list xs i =
   379 		fun assignment_from_list xs i =
   380 			i mem xs
   380 			i mem xs
   381 		(* int list -> SatSolver.result *)
   381 		(* int list -> SatSolver.result *)
   382 		fun solver_loop xs =
   382 		fun solver_loop xs =
   383 			if PropLogic.eval (assignment_from_list xs) fm then
   383 			if PropLogic.eval (assignment_from_list xs) fm then
   384 				SatSolver.SATISFIABLE (Some o (assignment_from_list xs))
   384 				SatSolver.SATISFIABLE (SOME o (assignment_from_list xs))
   385 			else
   385 			else
   386 				(case next_list xs indices of
   386 				(case next_list xs indices of
   387 				  Some xs' => solver_loop xs'
   387 				  SOME xs' => solver_loop xs'
   388 				| None     => SatSolver.UNSATISFIABLE)
   388 				| NONE     => SatSolver.UNSATISFIABLE)
   389 	in
   389 	in
   390 		(* start with the "first" assignment (all variables are interpreted as 'false') *)
   390 		(* start with the "first" assignment (all variables are interpreted as 'false') *)
   391 		solver_loop []
   391 		solver_loop []
   392 	end
   392 	end
   393 in
   393 in
   452 			fun dpll xs fm =
   452 			fun dpll xs fm =
   453 			let
   453 			let
   454 				val (xs', fm') = eval_and_force xs fm
   454 				val (xs', fm') = eval_and_force xs fm
   455 			in
   455 			in
   456 				case fm' of
   456 				case fm' of
   457 				  True  => Some xs'
   457 				  True  => SOME xs'
   458 				| False => None
   458 				| False => NONE
   459 				| _     =>
   459 				| _     =>
   460 					let
   460 					let
   461 						val x = the (fresh_var xs')  (* a fresh variable must exist since 'fm' did not evaluate to 'True'/'False' *)
   461 						val x = the (fresh_var xs')  (* a fresh variable must exist since 'fm' did not evaluate to 'True'/'False' *)
   462 					in
   462 					in
   463 						case dpll (x::xs') fm' of  (* passing fm' rather than fm should save some simplification work *)
   463 						case dpll (x::xs') fm' of  (* passing fm' rather than fm should save some simplification work *)
   464 						  Some xs'' => Some xs''
   464 						  SOME xs'' => SOME xs''
   465 						| None      => dpll ((~x)::xs') fm'  (* now try interpreting 'x' as 'False' *)
   465 						| NONE      => dpll ((~x)::xs') fm'  (* now try interpreting 'x' as 'False' *)
   466 					end
   466 					end
   467 			end
   467 			end
   468 			(* int list -> assignment *)
   468 			(* int list -> assignment *)
   469 			fun assignment_from_list [] i =
   469 			fun assignment_from_list [] i =
   470 				None  (* the DPLL procedure didn't provide a value for this variable *)
   470 				NONE  (* the DPLL procedure didn't provide a value for this variable *)
   471 			  | assignment_from_list (x::xs) i =
   471 			  | assignment_from_list (x::xs) i =
   472 				if x=i then (Some true)
   472 				if x=i then (SOME true)
   473 				else if x=(~i) then (Some false)
   473 				else if x=(~i) then (SOME false)
   474 				else assignment_from_list xs i
   474 				else assignment_from_list xs i
   475 		in
   475 		in
   476 			(* initially, no variable is interpreted yet *)
   476 			(* initially, no variable is interpreted yet *)
   477 			case dpll [] fm' of
   477 			case dpll [] fm' of
   478 			  Some assignment => SatSolver.SATISFIABLE (assignment_from_list assignment)
   478 			  SOME assignment => SatSolver.SATISFIABLE (assignment_from_list assignment)
   479 			| None            => SatSolver.UNSATISFIABLE
   479 			| NONE            => SatSolver.UNSATISFIABLE
   480 		end
   480 		end
   481 	end  (* local *)
   481 	end  (* local *)
   482 in
   482 in
   483 	SatSolver.add_solver ("dpll", dpll_solver)
   483 	SatSolver.add_solver ("dpll", dpll_solver)
   484 end;
   484 end;