simon/sidekick
1
0
Fork 0
mirror of https://github.com/c-cube/sidekick.git synced 2026-03-13 00:46:18 -04:00
Code Issues Projects Releases Packages Wiki Activity Actions

refactor: simpler, cleaner functors

Browse source
This commit is contained in:
Simon Cruanes 2019-01-18 22:38:15 -06:00 • committed by Guillaume Bury
parent c4da650e45
commit 1655d09035
30 changed files with 1342 additions and 1900 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
src/backend/Coq.ml
View file

@ -2,7 +2,6 @@
MSAT is free software, using the Apache license, see file LICENSE MSAT is free software, using the Apache license, see file LICENSE
Copyright 2015 Guillaume Bury Copyright 2015 Guillaume Bury
*) *)
open Msat
module type S = Backend_intf.S module type S = Backend_intf.S
@ -18,7 +17,7 @@ module type Arg = sig
end end
module Make(S : Res.S)(A : Arg with type hyp := S.clause module Make(S : Msat.S)(A : Arg with type hyp := S.clause
and type lemma := S.clause and type lemma := S.clause
and type assumption := S.clause) = struct and type assumption := S.clause) = struct
@ -26,6 +25,7 @@ module Make(S : Res.S)(A : Arg with type hyp := S.clause
module Clause = S.Clause module Clause = S.Clause
module M = Map.Make(S.Atom) module M = Map.Make(S.Atom)
module C_tbl = S.Clause.Tbl module C_tbl = S.Clause.Tbl
module P = S.Proof
let name = Clause.name let name = Clause.name
@ -122,29 +122,29 @@ module Make(S : Res.S)(A : Arg with type hyp := S.clause
Format.fprintf fmt "(* Clearing unused clauses *)@\n%a" clean_aux l' Format.fprintf fmt "(* Clearing unused clauses *)@\n%a" clean_aux l'
let prove_node t fmt node = let prove_node t fmt node =
let clause = node.S.conclusion in let clause = node.P.conclusion in
match node.S.step with match node.P.step with
| S.Hypothesis -> | P.Hypothesis ->
A.prove_hyp fmt (name clause) clause A.prove_hyp fmt (name clause) clause
| S.Assumption -> | P.Assumption ->
A.prove_assumption fmt (name clause) clause A.prove_assumption fmt (name clause) clause
| S.Lemma _ -> | P.Lemma _ ->
A.prove_lemma fmt (name clause) clause A.prove_lemma fmt (name clause) clause
| S.Duplicate (p, l) -> | P.Duplicate (p, l) ->
let c = S.conclusion p in let c = P.conclusion p in
let () = elim_duplicate fmt clause c l in let () = elim_duplicate fmt clause c l in
clean t fmt [c] clean t fmt [c]
| S.Resolution (p1, p2, a) -> | P.Resolution (p1, p2, a) ->
let c1 = S.conclusion p1 in let c1 = P.conclusion p1 in
let c2 = S.conclusion p2 in let c2 = P.conclusion p2 in
if resolution fmt clause c1 c2 a then clean t fmt [c1; c2] if resolution fmt clause c1 c2 a then clean t fmt [c1; c2]
let count_uses p = let count_uses p =
let h = C_tbl.create 128 in let h = C_tbl.create 128 in
let aux () node = let aux () node =
List.iter (fun p' -> incr_use h S.(conclusion p')) (S.parents node.S.step) List.iter (fun p' -> incr_use h P.(conclusion p')) (P.parents node.P.step)
in in
let () = S.fold aux () p in let () = P.fold aux () p in
h h
(* Here the main idea is to always try and have exactly (* Here the main idea is to always try and have exactly
@ -155,19 +155,19 @@ module Make(S : Res.S)(A : Arg with type hyp := S.clause
Format.fprintf fmt "%a" (prove_node h) node Format.fprintf fmt "%a" (prove_node h) node
in in
Format.fprintf fmt "(* Coq proof generated by mSAT*)@\n"; Format.fprintf fmt "(* Coq proof generated by mSAT*)@\n";
S.fold aux () p P.fold aux () p
end end
module Simple(S : Res.S) module Simple(S : Msat.S)
(A : Arg with type hyp = S.formula list (A : Arg with type hyp = S.formula list
and type lemma := S.lemma and type lemma := S.lemma
and type assumption := S.formula) = and type assumption := S.formula) =
Make(S)(struct Make(S)(struct
module P = S.Proof
(* Some helpers *) (* Some helpers *)
let lit = S.Atom.lit let lit = S.Atom.formula
let get_assumption c = let get_assumption c =
match S.Clause.atoms_l c with match S.Clause.atoms_l c with
@ -175,8 +175,8 @@ module Simple(S : Res.S)
| _ -> assert false | _ -> assert false
let get_lemma c = let get_lemma c =
match S.expand (S.prove c) with match P.expand (P.prove c) with
| {S.step=S.Lemma p; _} -> p | {P.step=P.Lemma p; _} -> p
| _ -> assert false | _ -> assert false
let prove_hyp fmt name c = let prove_hyp fmt name c =

7
src/backend/Coq.mli
View file

@ -8,7 +8,6 @@ Copyright 2015 Guillaume Bury
This module provides an easy way to produce coq scripts This module provides an easy way to produce coq scripts
corresponding to the resolution proofs output by the corresponding to the resolution proofs output by the
sat solver. *) sat solver. *)
open Msat
module type S = Backend_intf.S module type S = Backend_intf.S
(** Interface for exporting proofs. *) (** Interface for exporting proofs. *)
@ -34,14 +33,14 @@ module type Arg = sig
end end
module Make(S : Res.S)(A : Arg with type hyp := S.clause module Make(S : Msat.S)(A : Arg with type hyp := S.clause
and type lemma := S.clause and type lemma := S.clause
and type assumption := S.clause) : S with type t := S.proof and type assumption := S.clause) : S with type t := S.proof
(** Base functor to output Coq proofs *) (** Base functor to output Coq proofs *)
module Simple(S : Res.S)(A : Arg with type hyp = S.formula list module Simple(S : Msat.S)(A : Arg with type hyp = S.formula list
and type lemma := S.lemma and type lemma := S.lemma
and type assumption := S.formula) : S with type t := S.proof and type assumption := S.formula) : S with type t := S.proof
(** Simple functo to output Coq proofs *) (** Simple functor to output Coq proofs *)

11
src/backend/Dedukti.ml
View file

@ -3,8 +3,6 @@ MSAT is free software, using the Apache license, see file LICENSE
Copyright 2015 Guillaume Bury Copyright 2015 Guillaume Bury
*) *)
open Msat
module type S = Backend_intf.S module type S = Backend_intf.S
module type Arg = sig module type Arg = sig
@ -18,9 +16,10 @@ module type Arg = sig
val context : Format.formatter -> proof -> unit val context : Format.formatter -> proof -> unit
end end
module Make(S : Res.S)(A : Arg with type formula := S.formula module Make(S : Msat.S)(A : Arg with type formula := S.formula
and type lemma := S.lemma and type lemma := S.lemma
and type proof := S.proof) = struct and type proof := S.proof) = struct
module P = S.Proof
let pp_nl fmt = Format.fprintf fmt "@\n" let pp_nl fmt = Format.fprintf fmt "@\n"
let fprintf fmt format = Format.kfprintf pp_nl fmt format let fprintf fmt format = Format.kfprintf pp_nl fmt format
@ -32,10 +31,10 @@ module Make(S : Res.S)(A : Arg with type formula := S.formula
| [] -> () | [] -> ()
| a :: r -> | a :: r ->
let f, pos = let f, pos =
if S.Atom.is_pos a then if S.Atom.sign a then
S.Atom.lit a, true S.Atom.formula a, true
else else
S.Atom.lit (S.Atom.neg a), false S.Atom.formula (S.Atom.neg a), false
in in
fprintf fmt "%s _b %a ->@ %a" fprintf fmt "%s _b %a ->@ %a"
(if pos then "_pos" else "_neg") A.pp f aux r (if pos then "_pos" else "_neg") A.pp f aux r

4
src/backend/Dedukti.mli
View file

@ -9,8 +9,6 @@ Copyright 2014 Simon Cruanes
Work in progress... Work in progress...
*) *)
open Msat
module type S = Backend_intf.S module type S = Backend_intf.S
module type Arg = sig module type Arg = sig
@ -25,7 +23,7 @@ module type Arg = sig
end end
module Make : module Make :
functor(S : Res.S) -> functor(S : Msat.S) ->
functor(A : Arg functor(A : Arg
with type formula := S.formula with type formula := S.formula
and type lemma := S.lemma and type lemma := S.lemma

30
src/backend/Dimacs.ml
View file

@ -6,6 +6,11 @@ Copyright 2014 Simon Cruanes
open Msat open Msat
module type ARG = sig
type clause
val lits : clause -> int list
end
module type S = sig module type S = sig
type st type st
@ -29,15 +34,21 @@ module type S = sig
end end
module Make(St : Solver_types_intf.S) = struct module Make(St : Msat.S)(A: ARG with type clause = St.clause) = struct
type st = St.t type st = St.t
let pp_dimacs fmt c =
let lits = A.lits c in
List.iter (fun p -> Format.fprintf fmt "%d " p) lits;
Format.fprintf fmt "0"
(* Dimacs & iCNF export *) (* Dimacs & iCNF export *)
let export_vec name fmt vec = let export_vec name fmt vec =
Format.fprintf fmt "c %s@,%a@," name (Vec.pp ~sep:"" St.Clause.pp_dimacs) vec Format.fprintf fmt "c %s@,%a@," name (Vec.pp ~sep:"" pp_dimacs) vec
let export_assumption fmt vec = let export_assumption fmt vec =
Format.fprintf fmt "c Local assumptions@,a %a@," St.Clause.pp_dimacs vec Format.fprintf fmt "c Local assumptions@,a %a@," pp_dimacs vec
let export_icnf_aux r name map_filter fmt vec = let export_icnf_aux r name map_filter fmt vec =
let aux fmt _ = let aux fmt _ =
@ -45,14 +56,15 @@ module Make(St : Solver_types_intf.S) = struct
let x = Vec.get vec i in let x = Vec.get vec i in
match map_filter x with match map_filter x with
| None -> () | None -> ()
| Some _ -> Format.fprintf fmt "%a@," St.Clause.pp_dimacs (Vec.get vec i) | Some _ -> Format.fprintf fmt "%a@," pp_dimacs (Vec.get vec i)
done; done;
r := Vec.size vec r := Vec.size vec
in in
Format.fprintf fmt "c %s@,%a" name aux vec Format.fprintf fmt "c %s@,%a" name aux vec
(* TODO
let map_filter_learnt c = let map_filter_learnt c =
match St.Clause.premise c with match P.Clause.premise c with
| St.Hyp | St.Local -> assert false | St.Hyp | St.Local -> assert false
| St.Lemma _ -> Some c | St.Lemma _ -> Some c
| St.History l -> | St.History l ->
@ -73,13 +85,17 @@ module Make(St : Solver_types_intf.S) = struct
| Some d -> Vec.push lemmas d | Some d -> Vec.push lemmas d
) learnt; ) learnt;
lemmas lemmas
*)
let export st fmt ~hyps ~history ~local = let export st fmt ~hyps ~history ~local =
assert false
(* FIXME
assert (Vec.for_all (fun c -> St.Clause.premise c = St.Hyp) hyps); assert (Vec.for_all (fun c -> St.Clause.premise c = St.Hyp) hyps);
(* Learnt clauses, then filtered to only keep only (* Learnt clauses, then filtered to only keep only
the theory lemmas; all other learnt clauses should be logical the theory lemmas; all other learnt clauses should be logical
consequences of the rest. *) consequences of the rest. *)
let lemmas = filter_vec history in let lemmas = filter_vec history in
let lemmas = history in
(* Local assertions *) (* Local assertions *)
assert (Vec.for_all (fun c -> St.Local = St.Clause.premise c) local); assert (Vec.for_all (fun c -> St.Local = St.Clause.premise c) local);
(* Number of atoms and clauses *) (* Number of atoms and clauses *)
@ -90,12 +106,15 @@ module Make(St : Solver_types_intf.S) = struct
(export_vec "Local assumptions") local (export_vec "Local assumptions") local
(export_vec "Hypotheses") hyps (export_vec "Hypotheses") hyps
(export_vec "Lemmas") lemmas (export_vec "Lemmas") lemmas
*)
(* Refs to remember what portion of a problem has been printed *) (* Refs to remember what portion of a problem has been printed *)
let icnf_hyp = ref 0 let icnf_hyp = ref 0
let icnf_lemmas = ref 0 let icnf_lemmas = ref 0
let export_icnf fmt ~hyps ~history ~local = let export_icnf fmt ~hyps ~history ~local =
assert false
(* FIXME
assert (Vec.for_all (fun c -> St.Clause.premise c = St.Hyp) hyps); assert (Vec.for_all (fun c -> St.Clause.premise c = St.Hyp) hyps);
let lemmas = history in let lemmas = history in
(* Local assertions *) (* Local assertions *)
@ -113,6 +132,7 @@ module Make(St : Solver_types_intf.S) = struct
(export_icnf_aux icnf_hyp "Hypotheses" (fun x -> Some x)) hyps (export_icnf_aux icnf_hyp "Hypotheses" (fun x -> Some x)) hyps
(export_icnf_aux icnf_lemmas "Lemmas" map_filter_learnt) lemmas (export_icnf_aux icnf_lemmas "Lemmas" map_filter_learnt) lemmas
export_assumption local export_assumption local
*)
end end

8
src/backend/Dimacs.mli
View file

@ -12,6 +12,11 @@ Copyright 2014 Simon Cruanes
open Msat open Msat
module type ARG = sig
type clause
val lits : clause -> int list
end
module type S = sig module type S = sig
type st type st
@ -44,6 +49,7 @@ module type S = sig
end end
module Make(St: Solver_types_intf.S) : S with type clause := St.clause and type st = St.t module Make(St: Msat.S)(A: ARG with type clause = St.clause)
: S with type clause := St.clause and type st = St.t
(** Functor to create a module for exporting probems to the dimacs (& iCNF) formats. *) (** Functor to create a module for exporting probems to the dimacs (& iCNF) formats. *)

58
src/backend/Dot.ml
View file

@ -4,8 +4,6 @@ Copyright 2014 Guillaume Bury
Copyright 2014 Simon Cruanes Copyright 2014 Simon Cruanes
*) *)
open Msat
(** Output interface for the backend *) (** Output interface for the backend *)
module type S = Backend_intf.S module type S = Backend_intf.S
@ -30,7 +28,7 @@ module type Arg = sig
end end
module Default(S : Res.S) = struct module Default(S : Msat.S) = struct
module Atom = S.Atom module Atom = S.Atom
module Clause = S.Clause module Clause = S.Clause
@ -51,18 +49,19 @@ module Default(S : Res.S) = struct
end end
(** Functor to provide dot printing *) (** Functor to provide dot printing *)
module Make(S : Res.S)(A : Arg with type atom := S.atom module Make(S : Msat.S)(A : Arg with type atom := S.atom
and type hyp := S.clause and type hyp := S.clause
and type lemma := S.clause and type lemma := S.clause
and type assumption := S.clause) = struct and type assumption := S.clause) = struct
module Atom = S.Atom module Atom = S.Atom
module Clause = S.Clause module Clause = S.Clause
module P = S.Proof
let node_id n = Clause.name n.S.conclusion let node_id n = Clause.name n.P.conclusion
let res_node_id n = (node_id n) ^ "_res" let res_node_id n = (node_id n) ^ "_res"
let proof_id p = node_id (S.expand p) let proof_id p = node_id (P.expand p)
let print_clause fmt c = let print_clause fmt c =
let v = Clause.atoms c in let v = Clause.atoms c in
@ -80,8 +79,8 @@ module Make(S : Res.S)(A : Arg with type atom := S.atom
Format.fprintf fmt "%s -> %s;@\n" j i Format.fprintf fmt "%s -> %s;@\n" j i
let print_edges fmt n = let print_edges fmt n =
match S.(n.step) with match P.(n.step) with
| S.Resolution (p1, p2, _) -> | P.Resolution (p1, p2, _) ->
print_edge fmt (res_node_id n) (proof_id p1); print_edge fmt (res_node_id n) (proof_id p1);
print_edge fmt (res_node_id n) (proof_id p2) print_edge fmt (res_node_id n) (proof_id p2)
| _ -> () | _ -> ()
@ -109,29 +108,29 @@ module Make(S : Res.S)(A : Arg with type atom := S.atom
let ttify f c = fun fmt () -> f fmt c let ttify f c = fun fmt () -> f fmt c
let print_contents fmt n = let print_contents fmt n =
match S.(n.step) with match P.(n.step) with
(* Leafs of the proof tree *) (* Leafs of the proof tree *)
| S.Hypothesis -> | P.Hypothesis ->
let rule, color, l = A.hyp_info S.(n.conclusion) in let rule, color, l = A.hyp_info P.(n.conclusion) in
let color = match color with None -> "LIGHTBLUE" | Some c -> c in let color = match color with None -> "LIGHTBLUE" | Some c -> c in
print_dot_node fmt (node_id n) "LIGHTBLUE" S.(n.conclusion) rule color l print_dot_node fmt (node_id n) "LIGHTBLUE" P.(n.conclusion) rule color l
| S.Assumption -> | P.Assumption ->
let rule, color, l = A.assumption_info S.(n.conclusion) in let rule, color, l = A.assumption_info P.(n.conclusion) in
let color = match color with None -> "LIGHTBLUE" | Some c -> c in let color = match color with None -> "LIGHTBLUE" | Some c -> c in
print_dot_node fmt (node_id n) "LIGHTBLUE" S.(n.conclusion) rule color l print_dot_node fmt (node_id n) "LIGHTBLUE" P.(n.conclusion) rule color l
| S.Lemma _ -> | P.Lemma _ ->
let rule, color, l = A.lemma_info S.(n.conclusion) in let rule, color, l = A.lemma_info P.(n.conclusion) in
let color = match color with None -> "YELLOW" | Some c -> c in let color = match color with None -> "YELLOW" | Some c -> c in
print_dot_node fmt (node_id n) "LIGHTBLUE" S.(n.conclusion) rule color l print_dot_node fmt (node_id n) "LIGHTBLUE" P.(n.conclusion) rule color l
(* Tree nodes *) (* Tree nodes *)
| S.Duplicate (p, l) -> | P.Duplicate (p, l) ->
print_dot_node fmt (node_id n) "GREY" S.(n.conclusion) "Duplicate" "GREY" print_dot_node fmt (node_id n) "GREY" P.(n.conclusion) "Duplicate" "GREY"
((fun fmt () -> (Format.fprintf fmt "%s" (node_id n))) :: ((fun fmt () -> (Format.fprintf fmt "%s" (node_id n))) ::
List.map (ttify A.print_atom) l); List.map (ttify A.print_atom) l);
print_edge fmt (node_id n) (node_id (S.expand p)) print_edge fmt (node_id n) (node_id (P.expand p))
| S.Resolution (_, _, a) -> | P.Resolution (_, _, a) ->
print_dot_node fmt (node_id n) "GREY" S.(n.conclusion) "Resolution" "GREY" print_dot_node fmt (node_id n) "GREY" P.(n.conclusion) "Resolution" "GREY"
[(fun fmt () -> (Format.fprintf fmt "%s" (node_id n)))]; [(fun fmt () -> (Format.fprintf fmt "%s" (node_id n)))];
print_dot_res_node fmt (res_node_id n) a; print_dot_res_node fmt (res_node_id n) a;
print_edge fmt (node_id n) (res_node_id n) print_edge fmt (node_id n) (res_node_id n)
@ -142,12 +141,12 @@ module Make(S : Res.S)(A : Arg with type atom := S.atom
let pp fmt p = let pp fmt p =
Format.fprintf fmt "digraph proof {@\n"; Format.fprintf fmt "digraph proof {@\n";
S.fold (fun () -> print_node fmt) () p; P.fold (fun () -> print_node fmt) () p;
Format.fprintf fmt "}@." Format.fprintf fmt "}@."
end end
module Simple(S : Res.S) module Simple(S : Msat.S)
(A : Arg with type atom := S.formula (A : Arg with type atom := S.formula
and type hyp = S.formula list and type hyp = S.formula list
and type lemma := S.lemma and type lemma := S.lemma
@ -155,9 +154,10 @@ module Simple(S : Res.S)
Make(S)(struct Make(S)(struct
module Atom = S.Atom module Atom = S.Atom
module Clause = S.Clause module Clause = S.Clause
module P = S.Proof
(* Some helpers *) (* Some helpers *)
let lit = Atom.lit let lit = Atom.formula
let get_assumption c = let get_assumption c =
match S.Clause.atoms_l c with match S.Clause.atoms_l c with
@ -165,13 +165,13 @@ module Simple(S : Res.S)
| _ -> assert false | _ -> assert false
let get_lemma c = let get_lemma c =
match S.expand (S.prove c) with match P.expand (P.prove c) with
| {S.step=S.Lemma p;_} -> p | {P.step=P.Lemma p;_} -> p
| _ -> assert false | _ -> assert false
(* Actual functions *) (* Actual functions *)
let print_atom fmt a = let print_atom fmt a =
A.print_atom fmt (Atom.lit a) A.print_atom fmt (lit a)
let hyp_info c = let hyp_info c =
A.hyp_info (List.map lit (S.Clause.atoms_l c)) A.hyp_info (List.map lit (S.Clause.atoms_l c))

7
src/backend/Dot.mli
View file

@ -9,7 +9,6 @@ Copyright 2014 Simon Cruanes
This module provides functions to export proofs into the dot graph format. This module provides functions to export proofs into the dot graph format.
Graphs in dot format can be used to generates images using the graphviz tool. Graphs in dot format can be used to generates images using the graphviz tool.
*) *)
open Msat
module type S = Backend_intf.S module type S = Backend_intf.S
(** Interface for exporting proofs. *) (** Interface for exporting proofs. *)
@ -48,20 +47,20 @@ module type Arg = sig
end end
module Default(S : Res.S) : Arg with type atom := S.atom module Default(S : Msat.S) : Arg with type atom := S.atom
and type hyp := S.clause and type hyp := S.clause
and type lemma := S.clause and type lemma := S.clause
and type assumption := S.clause and type assumption := S.clause
(** Provides a reasonnable default to instantiate the [Make] functor, assuming (** Provides a reasonnable default to instantiate the [Make] functor, assuming
the original printing functions are compatible with DOT html labels. *) the original printing functions are compatible with DOT html labels. *)
module Make(S : Res.S)(A : Arg with type atom := S.atom module Make(S : Msat.S)(A : Arg with type atom := S.atom
and type hyp := S.clause and type hyp := S.clause
and type lemma := S.clause and type lemma := S.clause
and type assumption := S.clause) : S with type t := S.proof and type assumption := S.clause) : S with type t := S.proof
(** Functor for making a module to export proofs to the DOT format. *) (** Functor for making a module to export proofs to the DOT format. *)
module Simple(S : Res.S)(A : Arg with type atom := S.formula module Simple(S : Msat.S)(A : Arg with type atom := S.formula
and type hyp = S.formula list and type hyp = S.formula list
and type lemma := S.lemma and type lemma := S.lemma
and type assumption = S.formula) : S with type t := S.proof and type assumption = S.formula) : S with type t := S.proof

2
src/backend/dune
View file

@ -3,7 +3,7 @@
(public_name msat.backend) (public_name msat.backend)
(synopsis "proof backends for msat") (synopsis "proof backends for msat")
(libraries msat) (libraries msat)
(flags :standard -w +a-4-42-44-48-50-58-32-60@8 -color always -safe-string) (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -warn-error -27 -color always -safe-string)
(ocamlopt_flags :standard -O3 -bin-annot (ocamlopt_flags :standard -O3 -bin-annot
-unbox-closures -unbox-closures-factor 20) -unbox-closures -unbox-closures-factor 20)
) )

70
src/core/Expr_intf.ml
View file

@ -1,70 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2014 Guillaume Bury
Copyright 2014 Simon Cruanes
*)
(** Mcsat expressions
This modules defines the required implementation of expressions for Mcsat.
*)
type negated = Formula_intf.negated =
| Negated (** changed sign *)
| Same_sign (** kept sign *)
(** This type is used during the normalisation of formulas.
See {!val:Expr_intf.S.norm} for more details. *)
module type S = sig
(** Signature of formulas that parametrises the Mcsat Solver Module. *)
type proof
(** An abstract type for proofs *)
module Term : sig
(** McSat Terms *)
type t
(** The type of terms *)
val equal : t -> t -> bool
(** Equality over terms. *)
val hash : t -> int
(** Hashing function for terms. Should be such that two terms equal according
to {!val:Expr_intf.S.equal} have the same hash. *)
val pp : Format.formatter -> t -> unit
(** Printing function used among other for debugging. *)
end
module Formula : sig
(** McSat formulas *)
type t
(** The type of atomic formulas over terms. *)
val equal : t -> t -> bool
(** Equality over formulas. *)
val hash : t -> int
(** Hashing function for formulas. Should be such that two formulas equal according
to {!val:Expr_intf.S.equal} have the same hash. *)
val pp : Format.formatter -> t -> unit
(** Printing function used among other thing for debugging. *)
val neg : t -> t
(** Formula negation *)
val norm : t -> t * negated
(** Returns a 'normalized' form of the formula, possibly negated
(in which case return [Negated]).
[norm] must be so that [a] and [neg a] normalise to the same formula,
but one returns [Negated] and the other [Same_sign]. *)
end
end

50
src/core/Formula_intf.ml
View file

@ -1,50 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2014 Guillaume Bury
Copyright 2014 Simon Cruanes
*)
(** SMT formulas
This module defines the required implementation of formulas for
an SMT solver.
*)
type negated =
| Negated (** changed sign *)
| Same_sign (** kept sign *)
(** This type is used during the normalisation of formulas.
See {!val:Expr_intf.S.norm} for more details. *)
module type S = sig
(** SMT formulas *)
type t
(** The type of atomic formulas. *)
type proof
(** An abstract type for proofs *)
val equal : t -> t -> bool
(** Equality over formulas. *)
val hash : t -> int
(** Hashing function for formulas. Should be such that two formulas equal according
to {!val:Expr_intf.S.equal} have the same hash. *)
val pp : Format.formatter -> t -> unit
(** Printing function used among other thing for debugging. *)
val neg : t -> t
(** Formula negation. Should be an involution, i.e. [equal a (neg neg a)] should
always hold. *)
val norm : t -> t * negated
(** Returns a 'normalized' form of the formula, possibly negated
(in which case return [Negated]). This function is used to recognize
the link between a formula [a] and its negation [neg a], so the goal is
that [a] and [neg a] normalise to the same formula,
but one returns [Same_sign] and the other one returns [Negated] *)
end

944
src/core/Internal.ml
View file

File diff suppressed because it is too large Load diff

24
src/core/Msat.ml
View file

@ -1,15 +1,15 @@
(** Main API *) (** Main API *)
module Formula_intf = Formula_intf
module Plugin_intf = Plugin_intf
module Theory_intf = Theory_intf
module Expr_intf = Expr_intf
module Solver_types_intf = Solver_types_intf
module Res = Res module Solver_intf = Solver_intf
module type S = Solver_intf.S module type S = Solver_intf.S
module type FORMULA = Solver_intf.FORMULA
module type EXPR = Solver_intf.EXPR
module type PLUGIN_CDCL_T = Solver_intf.PLUGIN_CDCL_T
module type PLUGIN_MCSAT = Solver_intf.PLUGIN_MCSAT
module type PROOF = Solver_intf.PROOF
type ('term, 'form) sat_state = ('term, 'form) Solver_intf.sat_state = { type ('term, 'form) sat_state = ('term, 'form) Solver_intf.sat_state = {
eval : 'form -> bool; eval : 'form -> bool;
@ -27,13 +27,15 @@ type 'clause export = 'clause Solver_intf.export = {
history : 'clause Vec.t; history : 'clause Vec.t;
local : 'clause Vec.t; local : 'clause Vec.t;
} }
type ('formula, 'proof) th_res = ('formula, 'proof) Solver_intf.th_res =
| Th_sat
| Th_unsat of 'formula list * 'proof
module Make_smt_expr(E : Formula_intf.S) = Solver_types.SatMake(E) type negated = Solver_intf.negated = Negated | Same_sign
module Make_mcsat_expr(E : Expr_intf.S) = Solver_types.McMake(E)
module Make = Solver.Make module Make_mcsat = Solver.Make_mcsat
module Make_cdcl_t = Solver.Make_cdcl_t
module Make_dummy = Plugin_intf.Dummy module Make_pure_sat = Solver.Make_pure_sat
(**/**) (**/**)
module Vec = Vec module Vec = Vec

128
src/core/Plugin_intf.ml
View file

@ -1,128 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2016 Guillaume Bury
Copyright 2016 Simon Cruanes
*)
(** McSat Theory
This module defines what a theory must implement in order to
be sued in a McSat solver.
*)
type 'term eval_res =
| Unknown (** The given formula does not have an evaluation *)
| Valued of bool * ('term list) (** The given formula can be evaluated to the given bool.
The list of terms to give is the list of terms that
were effectively used for the evaluation. *)
(** The type of evaluation results for a given formula.
For instance, let's suppose we want to evaluate the formula [x * y = 0], the
following result are correct:
- [Unknown] if neither [x] nor [y] are assigned to a value
- [Valued (true, [x])] if [x] is assigned to [0]
- [Valued (true, [y])] if [y] is assigned to [0]
- [Valued (false, [x; y])] if [x] and [y] are assigned to 1 (or any non-zero number)
*)
type ('formula, 'proof) res =
| Sat
(** The current set of assumptions is satisfiable. *)
| Unsat of 'formula list * 'proof
(** The current set of assumptions is *NOT* satisfiable, and here is a
theory tautology (with its proof), for which every litteral is false
under the current assumptions. *)
(** Type returned by the theory. Formulas in the unsat clause must come from the
current set of assumptions, i.e must have been encountered in a slice. *)
type ('term, 'formula) assumption =
| Lit of 'formula (** The given formula is asserted true by the solver *)
| Assign of 'term * 'term (** The first term is assigned to the second *)
(** Asusmptions made by the core SAT solver. *)
type ('term, 'formula, 'proof) reason =
| Eval of 'term list (** The formula can be evalutaed using the terms in the list *)
| Consequence of 'formula list * 'proof (** [Consequence (l, p)] means that the formulas in [l] imply
the propagated formula [f]. The proof should be a proof of
the clause "[l] implies [f]". *)
(** The type of reasons for propagations of a formula [f]. *)
type ('term, 'formula, 'proof) slice = {
start : int; (** Start of the slice *)
length : int; (** Length of the slice *)
get : int -> ('term, 'formula) assumption; (** Accessor for the assertions in the slice.
Should only be called on integers [i] s.t.
[start <= i < start + length] *)
push : 'formula list -> 'proof -> unit; (** Add a clause to the solver. *)
propagate : 'formula ->
('term, 'formula, 'proof) reason -> unit; (** Propagate a formula, i.e. the theory can
evaluate the formula to be true (see the
definition of {!type:eval_res} *)
}
(** The type for a slice of assertions to assume/propagate in the theory. *)
(** Signature for theories to be given to the Model Constructing Solver. *)
module type S = sig
type t
(** The plugin state itself *)
type term
(** The type of terms. Should be compatible with Expr_intf.Term.t*)
type formula
(** The type of formulas. Should be compatble with Expr_intf.Formula.t *)
type proof
(** A custom type for the proofs of lemmas produced by the theory. *)
type level
(** The type for levels to allow backtracking. *)
val current_level : t -> level
(** Return the current level of the theory (either the empty/beginning state, or the
last level returned by the [assume] function). *)
val assume : t -> (term, formula, proof) slice -> (formula, proof) res
(** Assume the formulas in the slice, possibly pushing new formulas to be propagated,
and returns the result of the new assumptions. *)
val if_sat : t -> (term, formula, proof) slice -> (formula, proof) res
(** Called at the end of the search in case a model has been found. If no new clause is
pushed and the function returns [Sat], then proof search ends and 'sat' is returned,
else search is resumed. *)
val backtrack : t -> level -> unit
(** Backtrack to the given level. After a call to [backtrack l], the theory should be in the
same state as when it returned the value [l], *)
val assign : t -> term -> term
(** Returns an assignment value for the given term. *)
val iter_assignable : t -> (term -> unit) -> formula -> unit
(** An iterator over the subterms of a formula that should be assigned a value (usually the poure subterms) *)
val eval : t -> formula -> term eval_res
(** Returns the evaluation of the formula in the current assignment *)
end
module Dummy(F: Solver_types.S)
: S with type formula = F.formula
and type term = F.term
and type proof = F.proof
and type t = unit
= struct
type t = unit
type formula = F.formula
type term = F.term
type proof = F.proof
type level = unit
let current_level () = ()
let assume () _ = Sat
let if_sat () _ = Sat
let backtrack () _ = ()
let eval () _ = Unknown
let assign () t = t
let mcsat = false
let iter_assignable () _ _ = ()
end

302
src/core/Res.ml
View file

@ -1,302 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2014 Guillaume Bury
Copyright 2014 Simon Cruanes
*)
module type S = Res_intf.S
module type FULL = Res_intf.FULL
module Make(St : Solver_types.S) = struct
module St = St
type formula = St.formula
type lemma = St.proof
type clause = St.clause
type atom = St.atom
exception Insuficient_hyps
exception Resolution_error of string
(* Log levels *)
let error = 1
let warn = 3
let info = 10
let debug = 80
let equal_atoms a b = St.(a.aid) = St.(b.aid)
let compare_atoms a b = Pervasives.compare St.(a.aid) St.(b.aid)
module Clause = St.Clause
module Atom = St.Atom
let merge = List.merge compare_atoms
let _c = ref 0
let fresh_pcl_name () = incr _c; "R" ^ (string_of_int !_c)
(* Compute resolution of 2 clauses *)
let resolve l =
let rec aux resolved acc = function
| [] -> resolved, acc
| [a] -> resolved, a :: acc
| a :: b :: r ->
if equal_atoms a b then
aux resolved (a :: acc) r
else if equal_atoms St.(a.neg) b then
aux (St.(a.var.pa) :: resolved) acc r
else
aux resolved (a :: acc) (b :: r)
in
let resolved, new_clause = aux [] [] l in
resolved, List.rev new_clause
(* Compute the set of doublons of a clause *)
let list c = List.sort St.Atom.compare (Array.to_list St.(c.atoms))
let analyze cl =
let rec aux duplicates free = function
| [] -> duplicates, free
| [ x ] -> duplicates, x :: free
| x :: ((y :: r) as l) ->
if x == y then
count duplicates (x :: free) x [y] r
else
aux duplicates (x :: free) l
and count duplicates free x acc = function
| (y :: r) when x == y ->
count duplicates free x (y :: acc) r
| l ->
aux (acc :: duplicates) free l
in
let doublons, acc = aux [] [] cl in
doublons, List.rev acc
let to_list c =
let cl = list c in
let doublons, l = analyze cl in
let conflicts, _ = resolve l in
if doublons <> [] then
Log.debug warn "Input clause has redundancies";
if conflicts <> [] then
Log.debug warn "Input clause is a tautology";
cl
(*
let pp_cl fmt l =
let rec aux fmt = function
| [] -> ()
| a :: r ->
Format.fprintf fmt "%a@,%a" St.pp_atom a aux r
in
Format.fprintf fmt "@[<v>%a@]" aux l
*)
(* Comparison of clauses *)
let cmp_cl c d =
let rec aux = function
| [], [] -> 0
| a :: r, a' :: r' ->
begin match compare_atoms a a' with
| 0 -> aux (r, r')
| x -> x
end
| _ :: _ , [] -> -1
| [], _ :: _ -> 1
in
aux (c, d)
let[@inline] prove conclusion =
assert St.(conclusion.cpremise <> History []);
conclusion
let rec set_atom_proof a =
let aux acc b =
if equal_atoms a.St.neg b then acc
else set_atom_proof b :: acc
in
assert St.(a.var.v_level >= 0);
match St.(a.var.reason) with
| Some St.Bcp c ->
Log.debugf debug (fun k->k "Analysing: @[%a@ %a@]" St.Atom.debug a St.Clause.debug c);
if Array.length c.St.atoms = 1 then (
Log.debugf debug (fun k -> k "Old reason: @[%a@]" St.Atom.debug a);
c
) else (
assert (a.St.neg.St.is_true);
let r = St.History (c :: (Array.fold_left aux [] c.St.atoms)) in
let c' = St.Clause.make [a.St.neg] r in
a.St.var.St.reason <- Some St.(Bcp c');
Log.debugf debug
(fun k -> k "New reason: @[%a@ %a@]" St.Atom.debug a St.Clause.debug c');
c'
)
| _ ->
Log.debugf error (fun k -> k "Error while proving atom %a" St.Atom.debug a);
raise (Resolution_error "Cannot prove atom")
let prove_unsat conflict =
if Array.length conflict.St.atoms = 0 then conflict
else (
Log.debugf info (fun k -> k "Proving unsat from: @[%a@]" St.Clause.debug conflict);
let l = Array.fold_left (fun acc a -> set_atom_proof a :: acc) [] conflict.St.atoms in
let res = St.Clause.make [] (St.History (conflict :: l)) in
Log.debugf info (fun k -> k "Proof found: @[%a@]" St.Clause.debug res);
res
)
let prove_atom a =
if St.(a.is_true && a.var.v_level = 0) then
Some (set_atom_proof a)
else
None
(* Interface exposed *)
type proof = clause
and proof_node = {
conclusion : clause;
step : step;
}
and step =
| Hypothesis
| Assumption
| Lemma of lemma
| Duplicate of proof * atom list
| Resolution of proof * proof * atom
let rec chain_res (c, cl) = function
| d :: r ->
Log.debugf debug
(fun k -> k " Resolving clauses : @[%a@\n%a@]" St.Clause.debug c St.Clause.debug d);
let dl = to_list d in
begin match resolve (merge cl dl) with
| [ a ], l ->
begin match r with
| [] -> (l, c, d, a)
| _ ->
let new_clause = St.Clause.make l (St.History [c; d]) in
chain_res (new_clause, l) r
end
| _ ->
Log.debugf error
(fun k -> k "While resolving clauses:@[<hov>%a@\n%a@]"
St.Clause.debug c St.Clause.debug d);
raise (Resolution_error "Clause mismatch")
end
| _ ->
raise (Resolution_error "Bad history")
let[@inline] conclusion (p:proof) : clause = p
let expand conclusion =
Log.debugf debug (fun k -> k "Expanding : @[%a@]" St.Clause.debug conclusion);
match conclusion.St.cpremise with
| St.Lemma l ->
{conclusion; step = Lemma l; }
| St.Hyp ->
{ conclusion; step = Hypothesis; }
| St.Local ->
{ conclusion; step = Assumption; }
| St.History [] ->
Log.debugf error (fun k -> k "Empty history for clause: %a" St.Clause.debug conclusion);
raise (Resolution_error "Empty history")
| St.History [ c ] ->
let duplicates, res = analyze (list c) in
assert (cmp_cl res (list conclusion) = 0);
{ conclusion; step = Duplicate (c, List.concat duplicates) }
| St.History ( c :: ([_] as r)) ->
let (l, c', d', a) = chain_res (c, to_list c) r in
assert (cmp_cl l (to_list conclusion) = 0);
{ conclusion; step = Resolution (c', d', a); }
| St.History ( c :: r ) ->
let (l, c', d', a) = chain_res (c, to_list c) r in
conclusion.St.cpremise <- St.History [c'; d'];
assert (cmp_cl l (to_list conclusion) = 0);
{ conclusion; step = Resolution (c', d', a); }
(* Proof nodes manipulation *)
let is_leaf = function
| Hypothesis
| Assumption
| Lemma _ -> true
| Duplicate _
| Resolution _ -> false
let parents = function
| Hypothesis
| Assumption
| Lemma _ -> []
| Duplicate (p, _) -> [p]
| Resolution (p, p', _) -> [p; p']
let expl = function
| Hypothesis -> "hypothesis"
| Assumption -> "assumption"
| Lemma _ -> "lemma"
| Duplicate _ -> "duplicate"
| Resolution _ -> "resolution"
(* Compute unsat-core
TODO: replace visited bool by a int unique to each call
of unsat_core, so that the cleanup can be removed ? *)
let unsat_core proof =
let rec aux res acc = function
| [] -> res, acc
| c :: r ->
if not c.St.visited then (
c.St.visited <- true;
match c.St.cpremise with
| St.Hyp | St.Local | St.Lemma _ -> aux (c :: res) acc r
| St.History h ->
let l = List.fold_left (fun acc c ->
if not c.St.visited then c :: acc else acc) r h in
aux res (c :: acc) l
) else (
aux res acc r
)
in
let res, tmp = aux [] [] [proof] in
List.iter (fun c -> c.St.visited <- false) res;
List.iter (fun c -> c.St.visited <- false) tmp;
res
module Tbl = Clause.Tbl
type task =
| Enter of proof
| Leaving of proof
let spop s = try Some (Stack.pop s) with Stack.Empty -> None
let rec fold_aux s h f acc =
match spop s with
| None -> acc
| Some (Leaving c) ->
Tbl.add h c true;
fold_aux s h f (f acc (expand c))
| Some (Enter c) ->
if not (Tbl.mem h c) then begin
Stack.push (Leaving c) s;
let node = expand c in
begin match node.step with
| Duplicate (p1, _) ->
Stack.push (Enter p1) s
| Resolution (p1, p2, _) ->
Stack.push (Enter p2) s;
Stack.push (Enter p1) s
| Hypothesis | Assumption | Lemma _ -> ()
end
end;
fold_aux s h f acc
let fold f acc p =
let h = Tbl.create 42 in
let s = Stack.create () in
Stack.push (Enter p) s;
fold_aux s h f acc
let check p = fold (fun () _ -> ()) () p
end

19
src/core/Res.mli
View file

@ -1,19 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2014 Guillaume Bury
Copyright 2014 Simon Cruanes
*)
(** Resolution proofs
This modules defines functions to create and manipulate resolution proofs.
*)
module type S = Res_intf.S
(** Interface for a module manipulating resolution proofs. *)
module type FULL = Res_intf.FULL
module Make : functor (St : Solver_types.S) -> FULL with module St = St
(** Functor to create a module building proofs from a sat-solver unsat trace. *)

136
src/core/Res_intf.ml
View file

@ -1,136 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2014 Guillaume Bury
Copyright 2014 Simon Cruanes
*)
(** Interface for proofs *)
type 'a printer = Format.formatter -> 'a -> unit
module type S = sig
(** Signature for a module handling proof by resolution from sat solving traces *)
(** {3 Type declarations} *)
exception Insuficient_hyps
(** Raised when a complete resolution derivation cannot be found using the current hypotheses. *)
type formula
type atom
type lemma
type clause
(** Abstract types for atoms, clauses and theory-specific lemmas *)
type proof
(** Lazy type for proof trees. Proofs are persistent objects, and can be
extended to proof nodes using functions defined later. *)
and proof_node = {
conclusion : clause; (** The conclusion of the proof *)
step : step; (** The reasoning step used to prove the conclusion *)
}
(** A proof can be expanded into a proof node, which show the first step of the proof. *)
(** The type of reasoning steps allowed in a proof. *)
and step =
| Hypothesis
(** The conclusion is a user-provided hypothesis *)
| Assumption
(** The conclusion has been locally assumed by the user *)
| Lemma of lemma
(** The conclusion is a tautology provided by the theory, with associated proof *)
| Duplicate of proof * atom list
(** The conclusion is obtained by eliminating multiple occurences of the atom in
the conclusion of the provided proof. *)
| Resolution of proof * proof * atom
(** The conclusion can be deduced by performing a resolution between the conclusions
of the two given proofs. The atom on which to perform the resolution is also given. *)
(** {3 Proof building functions} *)
val prove : clause -> proof
(** Given a clause, return a proof of that clause.
@raise Insuficient_hyps if it does not succeed. *)
val prove_unsat : clause -> proof
(** Given a conflict clause [c], returns a proof of the empty clause.
@raise Insuficient_hyps if it does not succeed. *)
val prove_atom : atom -> proof option
(** Given an atom [a], returns a proof of the clause [[a]] if [a] is true at level 0 *)
(** {3 Proof Nodes} *)
val parents : step -> proof list
(** Returns the parents of a proof node. *)
val is_leaf : step -> bool
(** Returns wether the the proof node is a leaf, i.e. an hypothesis,
an assumption, or a lemma.
[true] if and only if {!parents} returns the empty list. *)
val expl : step -> string
(** Returns a short string description for the proof step; for instance
["hypothesis"] for a [Hypothesis]
(it currently returns the variant name in lowercase). *)
(** {3 Proof Manipulation} *)
val expand : proof -> proof_node
(** Return the proof step at the root of a given proof. *)
val conclusion : proof -> clause
(** What is proved at the root of the clause *)
val fold : ('a -> proof_node -> 'a) -> 'a -> proof -> 'a
(** [fold f acc p], fold [f] over the proof [p] and all its node. It is guaranteed that
[f] is executed exactly once on each proof node in the tree, and that the execution of
[f] on a proof node happens after the execution on the parents of the nodes. *)
val unsat_core : proof -> clause list
(** Returns the unsat_core of the given proof, i.e the lists of conclusions
of all leafs of the proof.
More efficient than using the [fold] function since it has
access to the internal representation of proofs *)
(** {3 Misc} *)
val check : proof -> unit
(** Check the contents of a proof. Mainly for internal use *)
module Clause : sig
type t = clause
val name : t -> string
val atoms : t -> atom array
val atoms_l : t -> atom list
val pp : t printer
(** A nice looking printer for clauses, which sort the atoms before printing. *)
module Tbl : Hashtbl.S with type key = t
end
module Atom : sig
type t = atom
val is_pos : t -> bool
val neg : t -> t
val abs : t -> t
val compare : t -> t -> int
val equal : t -> t -> bool
val lit : t -> formula
val pp : t printer
end
module Tbl : Hashtbl.S with type key = proof
end
module type FULL = sig
module St : Solver_types.S
(** Module defining atom and clauses *)
include S with type atom = St.atom
and type lemma = St.proof
and type clause = St.clause
and type formula = St.formula
end

149
src/core/Solver.ml
View file

@ -6,150 +6,7 @@ Copyright 2016 Simon Cruanes
module type S = Solver_intf.S module type S = Solver_intf.S
open Solver_intf module Make_cdcl_t = Internal.Make_cdcl_t
module Make_mcsat = Internal.Make_mcsat
module Make_pure_sat = Internal.Make_pure_sat
module Make
(St : Solver_types.S)
(Th : Plugin_intf.S with type term = St.term
and type formula = St.formula
and type proof = St.proof)
= struct
module St = St
module S = Internal.Make(St)(Th)
module Proof = S.Proof
exception UndecidedLit = S.UndecidedLit
type formula = St.formula
type term = St.term
type atom = St.formula
type clause = St.clause
type theory = Th.t
type t = S.t
type solver = t
let create = S.create
(* Result type *)
type res =
| Sat of (St.term,St.formula) sat_state
| Unsat of (St.clause,Proof.proof) unsat_state
let pp_all st lvl status =
Log.debugf lvl
(fun k -> k
"@[<v>%s - Full resume:@,@[<hov 2>Trail:@\n%a@]@,\
@[<hov 2>Temp:@\n%a@]@,@[<hov 2>Hyps:@\n%a@]@,@[<hov 2>Lemmas:@\n%a@]@,@]@."
status
(Vec.pp ~sep:"" St.Trail_elt.debug) (S.trail st)
(Vec.pp ~sep:"" St.Clause.debug) (S.temp st)
(Vec.pp ~sep:"" St.Clause.debug) (S.hyps st)
(Vec.pp ~sep:"" St.Clause.debug) (S.history st)
)
let mk_sat (st:S.t) : (_,_) sat_state =
pp_all st 99 "SAT";
let t = S.trail st in
let iter f f' =
Vec.iter (function
| St.Atom a -> f a.St.lit
| St.Lit l -> f' l.St.term)
t
in
{
eval = S.eval st;
eval_level = S.eval_level st;
iter_trail = iter;
model = (fun () -> S.model st);
}
let mk_unsat (st:S.t) : (_,_) unsat_state =
pp_all st 99 "UNSAT";
let unsat_conflict () =
match S.unsat_conflict st with
| None -> assert false
| Some c -> c
in
let get_proof () =
let c = unsat_conflict () in
S.Proof.prove_unsat c
in
{ unsat_conflict; get_proof; }
(* clean local state *)
let[@inline] cleanup_ (st:t) : unit =
if st.S.dirty then (
S.pop st; (* reset *)
st.S.dirty <- false;
)
(* Wrappers around internal functions*)
let[@inline] assume st ?tag cls : unit =
cleanup_ st;
S.assume st ?tag cls
let[@inline] add_clause st c : unit =
cleanup_ st;
S.add_clause st c
let solve (st:t) ?(assumptions=[]) () =
cleanup_ st;
try
S.push st;
st.S.dirty <- true; (* to call [pop] before any other action *)
S.local st assumptions;
S.solve st;
Sat (mk_sat st)
with S.Unsat ->
Unsat (mk_unsat st)
let[@inline] push st =
cleanup_ st;
S.push st
let[@inline] pop st =
cleanup_ st;
S.pop st
let unsat_core = S.Proof.unsat_core
let true_at_level0 st a =
try
let b, lev = S.eval_level st a in
b && lev = 0
with S.UndecidedLit -> false
let get_tag cl = St.(cl.tag)
let[@inline] new_lit st t =
cleanup_ st;
S.new_lit st t
let[@inline] new_atom st a =
cleanup_ st;
S.new_atom st a
let export (st:t) : St.clause export =
let hyps = S.hyps st in
let history = S.history st in
let local = S.temp st in
{hyps; history; local}
module Clause = struct
include St.Clause
let atoms c = St.Clause.atoms c |> Array.map (fun a -> a.St.lit)
let atoms_l c = St.Clause.atoms_l c |> List.map (fun a -> a.St.lit)
let make st ?tag l =
let l = List.map (S.mk_atom st) l in
St.Clause.make ?tag l St.Hyp
end
module Formula = St.Formula
module Term = St.Term
end

26
src/core/Solver.mli
View file

@ -13,16 +13,22 @@ Copyright 2014 Simon Cruanes
module type S = Solver_intf.S module type S = Solver_intf.S
(** Safe external interface of solvers. *) (** Safe external interface of solvers. *)
module Make module Make_cdcl_t(Th : Solver_intf.PLUGIN_CDCL_T)
(St : Solver_types.S) : S with type Term.t = Solver_intf.void
(Th : Plugin_intf.S with type term = St.term and module Formula = Th.Formula
and type formula = St.formula and type lemma = Th.proof
and type proof = St.proof)
: S with type term = St.term
and type formula = St.formula
and type clause = St.clause
and type Proof.lemma = St.proof
and type theory = Th.t and type theory = Th.t
(** Functor to make a safe external interface. *)
module Make_mcsat(Th : Solver_intf.PLUGIN_MCSAT)
: S with module Term = Th.Term
and module Formula = Th.Formula
and type lemma = Th.proof
and type theory = Th.t
module Make_pure_sat(F: Solver_intf.FORMULA)
: S with type Term.t = Solver_intf.void
and module Formula = F
and type lemma = Solver_intf.void
and type theory = unit

371
src/core/Solver_intf.ml
View file

@ -11,6 +11,8 @@ Copyright 2016 Simon Cruanes
functor in {!Solver} or {!Mcsolver}. functor in {!Solver} or {!Mcsolver}.
*) *)
type 'a printer = Format.formatter -> 'a -> unit
type ('term, 'form) sat_state = { type ('term, 'form) sat_state = {
eval: 'form -> bool; eval: 'form -> bool;
(** Returns the valuation of a formula in the current state (** Returns the valuation of a formula in the current state
@ -45,7 +47,279 @@ type 'clause export = {
} }
(** Export internal state *) (** Export internal state *)
type 'a printer = Format.formatter -> 'a -> unit type negated =
| Negated (** changed sign *)
| Same_sign (** kept sign *)
(** This type is used during the normalisation of formulas.
See {!val:Expr_intf.S.norm} for more details. *)
type 'term eval_res =
| Unknown (** The given formula does not have an evaluation *)
| Valued of bool * ('term list) (** The given formula can be evaluated to the given bool.
The list of terms to give is the list of terms that
were effectively used for the evaluation. *)
(** The type of evaluation results for a given formula.
For instance, let's suppose we want to evaluate the formula [x * y = 0], the
following result are correct:
- [Unknown] if neither [x] nor [y] are assigned to a value
- [Valued (true, [x])] if [x] is assigned to [0]
- [Valued (true, [y])] if [y] is assigned to [0]
- [Valued (false, [x; y])] if [x] and [y] are assigned to 1 (or any non-zero number)
*)
type ('formula, 'proof) th_res =
| Th_sat
(** The current set of assumptions is satisfiable. *)
| Th_unsat of 'formula list * 'proof
(** The current set of assumptions is *NOT* satisfiable, and here is a
theory tautology (with its proof), for which every litteral is false
under the current assumptions. *)
(** Type returned by the theory. Formulas in the unsat clause must come from the
current set of assumptions, i.e must have been encountered in a slice. *)
type ('term, 'formula) assumption =
| Lit of 'formula (** The given formula is asserted true by the solver *)
| Assign of 'term * 'term (** The first term is assigned to the second *)
(** Asusmptions made by the core SAT solver. *)
type ('term, 'formula, 'proof) reason =
| Eval of 'term list (** The formula can be evalutaed using the terms in the list *)
| Consequence of 'formula list * 'proof (** [Consequence (l, p)] means that the formulas in [l] imply
the propagated formula [f]. The proof should be a proof of
the clause "[l] implies [f]". *)
(** The type of reasons for propagations of a formula [f]. *)
type ('term, 'formula, 'proof) slice = {
start : int; (** Start of the slice *)
length : int; (** Length of the slice *)
get : int -> ('term, 'formula) assumption; (** Accessor for the assertions in the slice.
Should only be called on integers [i] s.t.
[start <= i < start + length] *)
push : 'formula list -> 'proof -> unit; (** Add a clause to the solver. *)
propagate : 'formula ->
('term, 'formula, 'proof) reason -> unit; (** Propagate a formula, i.e. the theory can
evaluate the formula to be true (see the
definition of {!type:eval_res} *)
}
(** The type for a slice of assertions to assume/propagate in the theory. *)
type ('a, 'b) gadt_eq = GADT_EQ : ('a, 'a) gadt_eq
type void = (unit,bool) gadt_eq
(** A provably empty type *)
module type FORMULA = sig
(** formulas *)
type t
(** The type of atomic formulas over terms. *)
val equal : t -> t -> bool
(** Equality over formulas. *)
val hash : t -> int
(** Hashing function for formulas. Should be such that two formulas equal according
to {!val:Expr_intf.S.equal} have the same hash. *)
val pp : t printer
(** Printing function used among other thing for debugging. *)
val neg : t -> t
(** Formula negation *)
val norm : t -> t * negated
(** Returns a 'normalized' form of the formula, possibly negated
(in which case return [Negated]).
[norm] must be so that [a] and [neg a] normalise to the same formula,
but one returns [Negated] and the other [Same_sign]. *)
end
(** Formulas and Terms required for mcSAT *)
module type EXPR = sig
type proof
(** An abstract type for proofs *)
module Term : sig
type t
(** The type of terms *)
val equal : t -> t -> bool
(** Equality over terms. *)
val hash : t -> int
(** Hashing function for terms. Should be such that two terms equal according
to {!val:Expr_intf.S.equal} have the same hash. *)
val pp : t printer
(** Printing function used among other for debugging. *)
end
module Formula : FORMULA
end
(** Signature for theories to be given to the CDCL(T) solver *)
module type PLUGIN_CDCL_T = sig
type t
(** The plugin state itself *)
module Formula : FORMULA
type proof
type level
(** The type for levels to allow backtracking. *)
val current_level : t -> level
(** Return the current level of the theory (either the empty/beginning state, or the
last level returned by the [assume] function). *)
val assume : t -> (void, Formula.t, proof) slice -> (Formula.t, proof) th_res
(** Assume the formulas in the slice, possibly pushing new formulas to be propagated,
and returns the result of the new assumptions. *)
val if_sat : t -> (void, Formula.t, proof) slice -> (Formula.t, proof) th_res
(** Called at the end of the search in case a model has been found. If no new clause is
pushed and the function returns [Sat], then proof search ends and 'sat' is returned,
else search is resumed. *)
val backtrack : t -> level -> unit
(** Backtrack to the given level. After a call to [backtrack l], the theory should be in the
same state as when it returned the value [l], *)
end
(** Signature for theories to be given to the Model Constructing Solver. *)
module type PLUGIN_MCSAT = sig
type t
(** The plugin state itself *)
include EXPR
type level
(** The type for levels to allow backtracking. *)
val current_level : t -> level
(** Return the current level of the theory (either the empty/beginning state, or the
last level returned by the [assume] function). *)
val assume : t -> (Term.t, Formula.t, proof) slice -> (Formula.t, proof) th_res
(** Assume the formulas in the slice, possibly pushing new formulas to be propagated,
and returns the result of the new assumptions. *)
val if_sat : t -> (Term.t, Formula.t, proof) slice -> (Formula.t, proof) th_res
(** Called at the end of the search in case a model has been found. If no new clause is
pushed and the function returns [Sat], then proof search ends and 'sat' is returned,
else search is resumed. *)
val backtrack : t -> level -> unit
(** Backtrack to the given level. After a call to [backtrack l], the theory should be in the
same state as when it returned the value [l], *)
val assign : t -> Term.t -> Term.t
(** Returns an assignment value for the given term. *)
val iter_assignable : t -> (Term.t -> unit) -> Formula.t -> unit
(** An iterator over the subTerm.ts of a Formula.t that should be assigned a value (usually the poure subTerm.ts) *)
val eval : t -> Formula.t -> Term.t eval_res
(** Returns the evaluation of the Formula.t in the current assignment *)
end
module type PROOF = sig
(** Signature for a module handling proof by resolution from sat solving traces *)
(** {3 Type declarations} *)
exception Insuficient_hyps
(** Raised when a complete resolution derivation cannot be found using the current hypotheses. *)
type formula
type atom
type lemma
type clause
(** Abstract types for atoms, clauses and theory-specific lemmas *)
type t
(** Lazy type for proof trees. Proofs are persistent objects, and can be
extended to proof nodes using functions defined later. *)
and proof_node = {
conclusion : clause; (** The conclusion of the proof *)
step : step; (** The reasoning step used to prove the conclusion *)
}
(** A proof can be expanded into a proof node, which show the first step of the proof. *)
(** The type of reasoning steps allowed in a proof. *)
and step =
| Hypothesis
(** The conclusion is a user-provided hypothesis *)
| Assumption
(** The conclusion has been locally assumed by the user *)
| Lemma of lemma
(** The conclusion is a tautology provided by the theory, with associated proof *)
| Duplicate of t * atom list
(** The conclusion is obtained by eliminating multiple occurences of the atom in
the conclusion of the provided proof. *)
| Resolution of t * t * atom
(** The conclusion can be deduced by performing a resolution between the conclusions
of the two given proofs. The atom on which to perform the resolution is also given. *)
(** {3 Proof building functions} *)
val prove : clause -> t
(** Given a clause, return a proof of that clause.
@raise Insuficient_hyps if it does not succeed. *)
val prove_unsat : clause -> t
(** Given a conflict clause [c], returns a proof of the empty clause.
@raise Insuficient_hyps if it does not succeed. *)
val prove_atom : atom -> t option
(** Given an atom [a], returns a proof of the clause [[a]] if [a] is true at level 0 *)
(** {3 Proof Nodes} *)
val parents : step -> t list
(** Returns the parents of a proof node. *)
val is_leaf : step -> bool
(** Returns wether the the proof node is a leaf, i.e. an hypothesis,
an assumption, or a lemma.
[true] if and only if {!parents} returns the empty list. *)
val expl : step -> string
(** Returns a short string description for the proof step; for instance
["hypothesis"] for a [Hypothesis]
(it currently returns the variant name in lowercase). *)
(** {3 Proof Manipulation} *)
val expand : t -> proof_node
(** Return the proof step at the root of a given proof. *)
val conclusion : t -> clause
(** What is proved at the root of the clause *)
val fold : ('a -> proof_node -> 'a) -> 'a -> t -> 'a
(** [fold f acc p], fold [f] over the proof [p] and all its node. It is guaranteed that
[f] is executed exactly once on each proof node in the tree, and that the execution of
[f] on a proof node happens after the execution on the parents of the nodes. *)
val unsat_core : t -> clause list
(** Returns the unsat_core of the given proof, i.e the lists of conclusions
of all leafs of the proof.
More efficient than using the [fold] function since it has
access to the internal representation of proofs *)
(** {3 Misc} *)
val check : t -> unit
(** Check the contents of a proof. Mainly for internal use *)
module Tbl : Hashtbl.S with type key = t
end
(** The external interface implemented by safe solvers, such as the one (** The external interface implemented by safe solvers, such as the one
created by the {!Solver.Make} and {!Mcsolver.Make} functors. *) created by the {!Solver.Make} and {!Mcsolver.Make} functors. *)
@ -54,18 +328,61 @@ module type S = sig
These are the internal modules used, you should probably not use them These are the internal modules used, you should probably not use them
if you're not familiar with the internals of mSAT. *) if you're not familiar with the internals of mSAT. *)
type term (** user terms *) include EXPR
type formula (** user formulas *) type term = Term.t (** user terms *)
type formula = Formula.t (** user formulas *)
type atom
(** The type of atoms given by the module argument for formulas.
An atom is a user-defined atomic formula whose truth value is
picked by Msat. *)
type clause type clause
type theory type theory
module Proof : Res.S with type clause = clause type lemma
type solver
module Atom : sig
type t = atom
val equal : t -> t -> bool
val compare : t -> t -> int
val hash : t -> int
val neg : t -> t
val sign : t -> bool
val abs : t -> t
val formula : t -> formula
val pp : t printer
end
module Clause : sig
type t = clause
val atoms : t -> atom array
val atoms_l : t -> atom list
val tag : t -> int option
val equal : t -> t -> bool
val name : t -> string
val pp : t printer
module Tbl : Hashtbl.S with type key = t
end
module Proof : PROOF
with type clause = clause
and type atom = atom
and type formula = formula
and type lemma = lemma
and type t = proof
(** A module to manipulate proofs. *) (** A module to manipulate proofs. *)
type t type t = solver
(** Main solver type, containing all state for solving. *) (** Main solver type, containing all state for solving. *)
val create : ?size:[`Tiny|`Small|`Big] -> theory -> t val create : ?size:[`Tiny|`Small|`Big] -> theory -> t
@ -76,15 +393,10 @@ module type S = sig
(** {2 Types} *) (** {2 Types} *)
type atom = formula
(** The type of atoms given by the module argument for formulas.
An atom is a user-defined atomic formula whose truth value is
picked by Msat. *)
(** Result type for the solver *) (** Result type for the solver *)
type res = type res =
| Sat of (term,formula) sat_state (** Returned when the solver reaches SAT, with a model *) | Sat of (term,atom) sat_state (** Returned when the solver reaches SAT, with a model *)
| Unsat of (clause,Proof.proof) unsat_state (** Returned when the solver reaches UNSAT, with a proof *) | Unsat of (clause,Proof.t) unsat_state (** Returned when the solver reaches UNSAT, with a proof *)
exception UndecidedLit exception UndecidedLit
(** Exception raised by the evaluating functions when a literal (** Exception raised by the evaluating functions when a literal
@ -92,11 +404,11 @@ module type S = sig
(** {2 Base operations} *) (** {2 Base operations} *)
val assume : t -> ?tag:int -> atom list list -> unit val assume : t -> ?tag:int -> formula list list -> unit
(** Add the list of clauses to the current set of assumptions. (** Add the list of clauses to the current set of assumptions.
Modifies the sat solver state in place. *) Modifies the sat solver state in place. *)
val add_clause : t -> clause -> unit val add_clause : t -> ?tag:int -> atom list -> unit
(** Lower level addition of clauses *) (** Lower level addition of clauses *)
val solve : t -> ?assumptions:atom list -> unit -> res val solve : t -> ?assumptions:atom list -> unit -> res
@ -110,12 +422,12 @@ module type S = sig
be decided on at some point during solving, wether it appears be decided on at some point during solving, wether it appears
in clauses or not. *) in clauses or not. *)
val new_atom : t -> atom -> unit val make_atom : t -> formula -> atom
(** Add a new atom (i.e propositional formula) to the solver. (** Add a new atom (i.e propositional formula) to the solver.
This formula will be decided on at some point during solving, This formula will be decided on at some point during solving,
wether it appears in clauses or not. *) wether it appears in clauses or not. *)
val unsat_core : Proof.proof -> clause list val unsat_core : Proof.t -> clause list
(** Returns the unsat core of a given proof, ie a subset of all the added (** Returns the unsat core of a given proof, ie a subset of all the added
clauses that is sufficient to establish unsatisfiability. *) clauses that is sufficient to establish unsatisfiability. *)
@ -136,32 +448,5 @@ module type S = sig
call to [push] *) call to [push] *)
val export : t -> clause export val export : t -> clause export
(** {2 Re-export some functions} *)
type solver = t
module Clause : sig
type t = clause
val atoms : t -> atom array
val atoms_l : t -> atom list
val tag : t -> int option
val equal : t -> t -> bool
val make : solver -> ?tag:int -> atom list -> t
val pp : t printer
end
module Formula : sig
type t = formula
val pp : t printer
end
module Term : sig
type t = term
val pp : t printer
end
end end

420
src/core/Solver_types.ml
View file

@ -1,420 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2016 Guillaume Bury
Copyright 2016 Simon Cruanes
*)
module type S = Solver_types_intf.S
(* Solver types for McSat Solving *)
(* ************************************************************************ *)
module McMake (E : Expr_intf.S) = struct
(* Flag for Mcsat v.s Pure Sat *)
let mcsat = true
type term = E.Term.t
type formula = E.Formula.t
type proof = E.proof
type seen =
| Nope
| Both
| Positive
| Negative
type lit = {
lid : int;
term : term;
mutable l_level : int;
mutable l_idx: int;
mutable l_weight : float;
mutable assigned : term option;
}
type var = {
vid : int;
pa : atom;
na : atom;
mutable v_fields : int;
mutable v_level : int;
mutable v_idx: int; (** position in heap *)
mutable v_weight : float; (** Weight (for the heap), tracking activity *)
mutable v_assignable: lit list option;
mutable reason : reason option;
}
and atom = {
aid : int;
var : var;
neg : atom;
lit : formula;
mutable is_true : bool;
mutable watched : clause Vec.t;
}
and clause = {
name : int;
tag : int option;
atoms : atom array;
mutable cpremise : premise;
mutable activity : float;
mutable attached : bool;
mutable visited : bool;
}
and reason =
| Decision
| Bcp of clause
| Semantic
and premise =
| Hyp
| Local
| Lemma of proof
| History of clause list
type elt =
| E_lit of lit
| E_var of var
type trail_elt =
| Lit of lit
| Atom of atom
(* Constructors *)
module MF = Hashtbl.Make(E.Formula)
module MT = Hashtbl.Make(E.Term)
type t = {
t_map: lit MT.t;
f_map: var MF.t;
vars: elt Vec.t;
mutable cpt_mk_var: int;
mutable cpt_mk_clause: int;
}
type state = t
let create_ size_map () : t = {
f_map = MF.create size_map;
t_map = MT.create size_map;
vars = Vec.create();
cpt_mk_var = 0;
cpt_mk_clause = 0;
}
let create ?(size=`Big) () : t =
let size_map = match size with
| `Tiny -> 8
| `Small -> 16
| `Big -> 4096
in
create_ size_map ()
let nb_elt st = Vec.size st.vars
let get_elt st i = Vec.get st.vars i
let iter_elt st f = Vec.iter f st.vars
let name_of_clause c = match c.cpremise with
| Hyp -> "H" ^ string_of_int c.name
| Local -> "L" ^ string_of_int c.name
| Lemma _ -> "T" ^ string_of_int c.name
| History _ -> "C" ^ string_of_int c.name
module Lit = struct
type t = lit
let[@inline] term l = l.term
let[@inline] level l = l.l_level
let[@inline] assigned l = l.assigned
let[@inline] weight l = l.l_weight
let make (st:state) (t:term) : t =
try MT.find st.t_map t
with Not_found ->
let res = {
lid = st.cpt_mk_var;
term = t;
l_weight = 1.;
l_idx= -1;
l_level = -1;
assigned = None;
} in
st.cpt_mk_var <- st.cpt_mk_var + 1;
MT.add st.t_map t res;
Vec.push st.vars (E_lit res);
res
let debug_assign fmt v =
match v.assigned with
| None ->
Format.fprintf fmt ""
| Some t ->
Format.fprintf fmt "@[<hov>@@%d->@ %a@]" v.l_level E.Term.pp t
let pp out v = E.Term.pp out v.term
let debug out v =
Format.fprintf out "%d[%a][lit:@[<hov>%a@]]"
(v.lid+1) debug_assign v E.Term.pp v.term
end
let seen_pos = 0b1
let seen_neg = 0b10
module Var = struct
type t = var
let[@inline] level v = v.v_level
let[@inline] pos v = v.pa
let[@inline] neg v = v.na
let[@inline] reason v = v.reason
let[@inline] assignable v = v.v_assignable
let[@inline] weight v = v.v_weight
let make (st:state) (t:formula) : var * Expr_intf.negated =
let lit, negated = E.Formula.norm t in
try
MF.find st.f_map lit, negated
with Not_found ->
let cpt_double = st.cpt_mk_var lsl 1 in
let rec var =
{ vid = st.cpt_mk_var;
pa = pa;
na = na;
v_fields = 0;
v_level = -1;
v_idx= -1;
v_weight = 0.;
v_assignable = None;
reason = None;
}
and pa =
{ var = var;
lit = lit;
watched = Vec.create();
neg = na;
is_true = false;
aid = cpt_double (* aid = vid*2 *) }
and na =
{ var = var;
lit = E.Formula.neg lit;
watched = Vec.create();
neg = pa;
is_true = false;
aid = cpt_double + 1 (* aid = vid*2+1 *) } in
MF.add st.f_map lit var;
st.cpt_mk_var <- st.cpt_mk_var + 1;
Vec.push st.vars (E_var var);
var, negated
(* Marking helpers *)
let[@inline] clear v =
v.v_fields <- 0
let[@inline] seen_both v =
(seen_pos land v.v_fields <> 0) &&
(seen_neg land v.v_fields <> 0)
end
module Atom = struct
type t = atom
let[@inline] level a = a.var.v_level
let[@inline] var a = a.var
let[@inline] neg a = a.neg
let[@inline] abs a = a.var.pa
let[@inline] lit a = a.lit
let[@inline] equal a b = a == b
let[@inline] is_pos a = a == abs a
let[@inline] compare a b = Pervasives.compare a.aid b.aid
let[@inline] reason a = Var.reason a.var
let[@inline] id a = a.aid
let[@inline] is_true a = a.is_true
let[@inline] is_false a = a.neg.is_true
let[@inline] seen a =
let pos = equal a (abs a) in
if pos
then (seen_pos land a.var.v_fields <> 0)
else (seen_neg land a.var.v_fields <> 0)
let[@inline] mark a =
let pos = equal a (abs a) in
if pos then (
a.var.v_fields <- seen_pos lor a.var.v_fields
) else (
a.var.v_fields <- seen_neg lor a.var.v_fields
)
let[@inline] make st lit =
let var, negated = Var.make st lit in
match negated with
| Formula_intf.Negated -> var.na
| Formula_intf.Same_sign -> var.pa
let pp fmt a = E.Formula.pp fmt a.lit
let pp_a fmt v =
if Array.length v = 0 then (
Format.fprintf fmt "∅"
) else (
pp fmt v.(0);
if (Array.length v) > 1 then begin
for i = 1 to (Array.length v) - 1 do
Format.fprintf fmt " ∨ %a" pp v.(i)
done
end
)
(* Complete debug printing *)
let sign a = if a == a.var.pa then "+" else "-"
let debug_reason fmt = function
| n, _ when n < 0 ->
Format.fprintf fmt "%%"
| n, None ->
Format.fprintf fmt "%d" n
| n, Some Decision ->
Format.fprintf fmt "@@%d" n
| n, Some Bcp c ->
Format.fprintf fmt "->%d/%s" n (name_of_clause c)
| n, Some Semantic ->
Format.fprintf fmt "::%d" n
let pp_level fmt a =
debug_reason fmt (a.var.v_level, a.var.reason)
let debug_value fmt a =
if a.is_true then
Format.fprintf fmt "T%a" pp_level a
else if a.neg.is_true then
Format.fprintf fmt "F%a" pp_level a
else
Format.fprintf fmt ""
let debug out a =
Format.fprintf out "%s%d[%a][atom:@[<hov>%a@]]"
(sign a) (a.var.vid+1) debug_value a E.Formula.pp a.lit
let debug_a out vec =
Array.iter (fun a -> Format.fprintf out "%a@ " debug a) vec
end
(* Elements *)
module Elt = struct
type t = elt
let[@inline] of_lit l = E_lit l
let[@inline] of_var v = E_var v
let[@inline] id = function
| E_lit l -> l.lid | E_var v -> v.vid
let[@inline] level = function
| E_lit l -> l.l_level | E_var v -> v.v_level
let[@inline] idx = function
| E_lit l -> l.l_idx | E_var v -> v.v_idx
let[@inline] weight = function
| E_lit l -> l.l_weight | E_var v -> v.v_weight
let[@inline] set_level e lvl = match e with
| E_lit l -> l.l_level <- lvl | E_var v -> v.v_level <- lvl
let[@inline] set_idx e i = match e with
| E_lit l -> l.l_idx <- i | E_var v -> v.v_idx <- i
let[@inline] set_weight e w = match e with
| E_lit l -> l.l_weight <- w | E_var v -> v.v_weight <- w
end
module Trail_elt = struct
type t = trail_elt
let[@inline] of_lit l = Lit l
let[@inline] of_atom a = Atom a
let debug fmt = function
| Lit l -> Lit.debug fmt l
| Atom a -> Atom.debug fmt a
end
module Clause = struct
type t = clause
let make =
let n = ref 0 in
fun ?tag ali premise ->
let atoms = Array.of_list ali in
let name = !n in
incr n;
{ name;
tag = tag;
atoms = atoms;
visited = false;
attached = false;
activity = 0.;
cpremise = premise}
let empty = make [] (History [])
let name = name_of_clause
let[@inline] equal c1 c2 = c1==c2
let[@inline] atoms c = c.atoms
let[@inline] atoms_l c = Array.to_list c.atoms
let[@inline] tag c = c.tag
let hash cl = Array.fold_left (fun i a -> Hashtbl.hash (a.aid, i)) 0 cl.atoms
let[@inline] premise c = c.cpremise
let[@inline] set_premise c p = c.cpremise <- p
let[@inline] visited c = c.visited
let[@inline] set_visited c b = c.visited <- b
let[@inline] attached c = c.attached
let[@inline] set_attached c b = c.attached <- b
let[@inline] activity c = c.activity
let[@inline] set_activity c w = c.activity <- w
module Tbl = Hashtbl.Make(struct
type t = clause
let hash = hash
let equal = equal
end)
let pp fmt c =
Format.fprintf fmt "%s : %a" (name c) Atom.pp_a c.atoms
let debug_premise out = function
| Hyp -> Format.fprintf out "hyp"
| Local -> Format.fprintf out "local"
| Lemma _ -> Format.fprintf out "th_lemma"
| History v ->
List.iter (fun c -> Format.fprintf out "%s,@ " (name_of_clause c)) v
let debug out ({atoms=arr; cpremise=cp;_}as c) =
Format.fprintf out "%s@[<hov>{@[<hov>%a@]}@ cpremise={@[<hov>%a@]}@]"
(name c) Atom.debug_a arr debug_premise cp
let pp_dimacs fmt {atoms;_} =
let aux fmt a =
Array.iter (fun p ->
Format.fprintf fmt "%s%d "
(if p == p.var.pa then "-" else "")
(p.var.vid+1)
) a
in
Format.fprintf fmt "%a0" aux atoms
end
module Term = E.Term
module Formula = E.Formula
end[@@inline]
(* Solver types for pure SAT Solving *)
(* ************************************************************************ *)
module SatMake (E : Formula_intf.S) = struct
include McMake(struct
include E
module Term = E
module Formula = E
end)
let mcsat = false
end[@@inline]

26
src/core/Solver_types.mli
View file

@ -1,26 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2016 Guillaume Bury
Copyright 2016 Simon Cruanes
*)
(** Internal types (implementation)
This modules actually implements the internal types used by the solver.
Since mutation is heavily used in the solver, it is really, really, *really*
discouraged to direclty use the functions in this module if you don't know the
inner working of mSAT perfectly as even the simplest
change can have dramatic effects on the solver.
*)
module type S = Solver_types_intf.S
(** Interface for the internal types. *)
module McMake (E : Expr_intf.S):
S with type term = E.Term.t and type formula = E.Formula.t and type proof = E.proof
(** Functor to instantiate the types of clauses for a solver. *)
module SatMake (E : Formula_intf.S):
S with type term = E.t and type formula = E.t and type proof = E.proof
(** Functor to instantiate the types of clauses for a solver. *)

271
src/core/Solver_types_intf.ml
View file

@ -1,271 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2016 Guillaume Bury
Copyright 2016 Simon Cruanes
*)
(** Internal types (interface)
This modules defines the interface of most of the internal types
used in the core solver.
*)
type 'a printer = Format.formatter -> 'a -> unit
module type S = sig
(** The signatures of clauses used in the Solver. *)
val mcsat : bool
(** TODO:deprecate. *)
type t
(** State for creating new terms, literals, clauses *)
val create: ?size:[`Tiny|`Small|`Big] -> unit -> t
(** {2 Type definitions} *)
type term
type formula
type proof
(** The types of terms, formulas and proofs. All of these are user-provided. *)
type seen =
| Nope
| Both
| Positive
| Negative
(* TODO: hide these types (from the outside of [Msat]);
instead, provide well defined modules [module Lit : sig type t val …]
that define their API in Msat itself (not here) *)
type lit = {
lid : int; (** Unique identifier *)
term : term; (** Wrapped term *)
mutable l_level : int; (** Decision level of the assignment *)
mutable l_idx: int; (** index in heap *)
mutable l_weight : float; (** Weight (for the heap) *)
mutable assigned : term option; (** Assignment *)
}
(** Wrapper type for literals, i.e. theory terms (for mcsat only). *)
type var = {
vid : int; (** Unique identifier *)
pa : atom; (** Link for the positive atom *)
na : atom; (** Link for the negative atom *)
mutable v_fields : int; (** bool fields *)
mutable v_level : int; (** Level of decision/propagation *)
mutable v_idx: int; (** rank in variable heap *)
mutable v_weight : float; (** Variable weight (for the heap) *)
mutable v_assignable: lit list option;
(** In mcsat, the list of lits that wraps subterms of the formula wrapped. *)
mutable reason : reason option;
(** The reason for propagation/decision of the literal *)
}
and atom = {
aid : int; (** Unique identifier *)
var : var; (** Link for the parent variable *)
neg : atom; (** Link for the negation of the atom *)
lit : formula; (** Wrapped formula *)
mutable is_true : bool; (** Is the atom true ? Conversely, the atom
is false iff a.neg.is_true *)
mutable watched : clause Vec.t; (** The vector of clauses that watch this atom *)
}
(** Atoms and variables wrap theory formulas. They exist in the form of
triplet: a variable and two atoms. For a formula [f] in normal form,
the variable v points to the positive atom [a] which wraps [f], while
[a.neg] wraps the theory negation of [f]. *)
and clause = {
name : int; (** Clause name, mainly for printing, unique. *)
tag : int option; (** User-provided tag for clauses. *)
atoms : atom array; (** The atoms that constitute the clause.*)
mutable cpremise : premise; (** The premise of the clause, i.e. the justification
of why the clause must be satisfied. *)
mutable activity : float; (** Clause activity, used for the heap heuristics. *)
mutable attached : bool; (** Is the clause attached, i.e. does it watch literals. *)
mutable visited : bool; (** Boolean used during propagation and proof generation. *)
}
(** The type of clauses. Each clause generated should be true, i.e. enforced
by the current problem (for more information, see the cpremise field). *)
and reason =
| Decision (** The atom has been decided by the sat solver *)
| Bcp of clause (** The atom has been propagated by the given clause *)
| Semantic (** The atom has been propagated by the theory at the given level. *)
(** Reasons of propagation/decision of atoms. *)
and premise =
| Hyp (** The clause is a hypothesis, provided by the user. *)
| Local (** The clause is a 1-atom clause,
where the atom is a local assumption*)
| Lemma of proof (** The clause is a theory-provided tautology, with
the given proof. *)
| History of clause list (** The clause can be obtained by resolution of the clauses
in the list. If the list has a single element [c] , then
the clause can be obtained by simplifying [c] (i.e
eliminating doublons in its atom list).
For a premise [History [a_1 :: ... :: a_n]] ([n > 0])
the clause is obtained by performing resolution of
[a_1] with [a_2], and then performing a resolution step between
the result and [a_3], etc...
Of course, each of the clause [a_i] also has its own premise. *)
(** Premises for clauses. Indeed each clause generated during a run of the solver
should be satisfied, the premise is the justification of why it should be
satisfied by the solver. *)
(** {2 Decisions and propagations} *)
type trail_elt =
| Lit of lit
| Atom of atom (**)
(** Either a lit of an atom *)
(** {2 Elements} *)
type elt =
| E_lit of lit
| E_var of var (**)
(** Either a lit of a var *)
val nb_elt : t -> int
val get_elt : t -> int -> elt
val iter_elt : t -> (elt -> unit) -> unit
(** Read access to the vector of variables created *)
(** {2 Variables, Literals & Clauses } *)
type state = t
module Lit : sig
type t = lit
val term : t -> term
val make : state -> term -> t
(** Returns the variable associated with the term *)
val level : t -> int
val assigned : t -> term option
val weight : t -> float
val pp : t printer
val debug : t printer
end
module Var : sig
type t = var
val pos : t -> atom
val neg : t -> atom
val level : t -> int
val reason : t -> reason option
val assignable : t -> lit list option
val weight : t -> float
val make : state -> formula -> t * Formula_intf.negated
(** Returns the variable linked with the given formula,
and whether the atom associated with the formula
is [var.pa] or [var.na] *)
val seen_both : t -> bool
(** both atoms have been seen? *)
val clear : t -> unit
(** Clear the 'seen' field of the variable. *)
end
module Atom : sig
type t = atom
val level : t -> int
val reason : t -> reason option
val lit : t -> formula
val equal : t -> t -> bool
val compare : t -> t -> int
val var : t -> Var.t
val abs : t -> t (** positive atom *)
val neg : t -> t
val id : t -> int
val is_pos : t -> bool (* positive atom? *)
val is_true : t -> bool
val is_false : t -> bool
val make : state -> formula -> t
(** Returns the atom associated with the given formula *)
val mark : t -> unit
(** Mark the atom as seen, using the 'seen' field in the variable. *)
val seen : t -> bool
(** Returns wether the atom has been marked as seen. *)
val pp : t printer
val pp_a : t array printer
val debug : t printer
val debug_a : t array printer
end
module Elt : sig
type t = elt
val of_lit : Lit.t -> t
val of_var : Var.t -> t
val id : t -> int
val level : t -> int
val idx : t -> int
val weight : t -> float
val set_level : t -> int -> unit
val set_idx : t -> int -> unit
val set_weight : t -> float -> unit
end
module Clause : sig
type t = clause
val name : t -> string
val equal : t -> t -> bool
val hash : t -> int
val atoms : t -> Atom.t array
val atoms_l : t -> Atom.t list
val tag : t -> int option
val premise : t -> premise
val empty : t
(** The empty clause *)
val make : ?tag:int -> Atom.t list -> premise -> clause
(** [make_clause name atoms size premise] creates a clause with the given attributes. *)
val pp : t printer
val pp_dimacs : t printer
val debug : t printer
module Tbl : Hashtbl.S with type key = t
end
module Trail_elt : sig
type t = trail_elt
val of_lit : Lit.t -> t
val of_atom : Atom.t -> t
(** Constructors and destructors *)
val debug : t printer
end
module Term : sig
type t = term
val equal : t -> t -> bool
val hash : t -> int
val pp : t printer
end
module Formula : sig
type t = formula
val equal : t -> t -> bool
val hash : t -> int
val pp : t printer
end
end

83
src/core/Theory_intf.ml
View file

@ -1,83 +0,0 @@
(*
MSAT is free software, using the Apache license, see file LICENSE
Copyright 2016 Guillaume Bury
Copyright 2016 Simon Cruanes
*)
(** SMT Theory
This module defines what a theory must implement in order to
be used in an SMT solver.
*)
type ('formula, 'proof) res = ('formula, 'proof) Plugin_intf.res =
| Sat
(** The current set of assumptions is satisfiable. *)
| Unsat of 'formula list * 'proof
(** The current set of assumptions is *NOT* satisfiable, and here is a
theory tautology (with its proof), for which every litteral is false
under the current assumptions. *)
(** Type returned by the theory. Formulas in the unsat clause must come from the
current set of assumptions, i.e must have been encountered in a slice. *)
type ('form, 'proof) slice = {
start : int; (** Start of the slice *)
length : int; (** Length of the slice *)
get : int -> 'form; (** Accesor for the formuals in the slice.
Should only be called on integers [i] s.t.
[start <= i < start + length] *)
push : 'form list -> 'proof -> unit; (** Allows to add to the solver a clause. *)
propagate : 'form -> 'form list -> 'proof -> unit;
(** [propagate lit causes proof] informs the solver to propagate [lit], with the reason
that the clause [causes => lit] is a theory tautology. It is faster than pushing
the associated clause but the clause will not be remembered by the sat solver,
i.e it will not be used by the solver to do boolean propagation. *)
}
(** The type for a slice. Slices are some kind of view of the current
propagation queue. They allow to look at the propagated literals,
and to add new clauses to the solver. *)
(** Signature for theories to be given to the Solver. *)
module type S = sig
type t
(** The state of the theory itself *)
type formula
(** The type of formulas. Should be compatble with Formula_intf.S *)
type proof
(** A custom type for the proofs of lemmas produced by the theory. *)
type level
(** The type for levels to allow backtracking. *)
val current_level : t -> level
(** Return the current level of the theory (either the empty/beginning state, or the
last level returned by the [assume] function). *)
val assume : t -> (formula, proof) slice -> (formula, proof) res
(** Assume the formulas in the slice, possibly pushing new formulas to be propagated,
and returns the result of the new assumptions. *)
val if_sat : t -> (formula, proof) slice -> (formula, proof) res
(** Called at the end of the search in case a model has been found. If no new clause is
pushed, then 'sat' is returned, else search is resumed. *)
val backtrack : t -> level -> unit
(** Backtrack to the given level. After a call to [backtrack l], the theory should be in the
same state as when it returned the value [l], *)
end
module Dummy(F: Formula_intf.S)
: S with type formula = F.t and type t = unit
= struct
type t = unit
type formula = F.t
type proof = unit
type level = unit
let current_level () = ()
let assume () _ = Sat
let if_sat () _ = Sat
let backtrack () _ = ()
end

4
src/main/main.ml
View file

@ -19,7 +19,7 @@ let size_limit = ref 1000_000_000.
module S = Msat_sat module S = Msat_sat
module Process = struct module Process = struct
module D = Msat_backend.Dot.Make(S.Proof)(Msat_backend.Dot.Default(S.Proof)) module D = Msat_backend.Dot.Make(S)(Msat_backend.Dot.Default(S))
let hyps = ref [] let hyps = ref []
@ -29,7 +29,7 @@ module Process = struct
let check_clause c = let check_clause c =
let l = List.map (function a -> let l = List.map (function a ->
Log.debugf 99 Log.debugf 99
(fun k -> k "Checking value of %a" S.Formula.pp a); (fun k -> k "Checking value of %a" S.Atom.pp a);
sat.Msat.eval a) c in sat.Msat.eval a) c in
List.exists (fun x -> x) l List.exists (fun x -> x) l
in in

7
src/sat/Expr_sat.ml
View file

@ -2,9 +2,6 @@
exception Bad_atom exception Bad_atom
(** Exception raised if an atom cannot be created *) (** Exception raised if an atom cannot be created *)
type proof
(** A empty type for proofs *)
type t = int type t = int
(** Atoms are represented as integers. [-i] begin the negation of [i]. (** Atoms are represented as integers. [-i] begin the negation of [i].
Additionally, since we nee dot be able to create fresh atoms, we Additionally, since we nee dot be able to create fresh atoms, we
@ -31,9 +28,9 @@ let neg a = - a
let norm a = let norm a =
abs a, if a < 0 then abs a, if a < 0 then
Formula_intf.Negated Solver_intf.Negated
else else
Formula_intf.Same_sign Solver_intf.Same_sign
let abs = abs let abs = abs

2
src/sat/Expr_sat.mli
View file

@ -8,7 +8,7 @@
near optimal efficiency (both in terms of space and time). near optimal efficiency (both in terms of space and time).
*) *)
include Formula_intf.S include Solver_intf.FORMULA
(** This modules implements the requirements for implementing an SAT Solver. *) (** This modules implements the requirements for implementing an SAT Solver. *)
val make : int -> t val make : int -> t

4
src/sat/Msat_sat.ml
View file

@ -4,7 +4,5 @@ Copyright 2016 Guillaume Bury
*) *)
module Expr = Expr_sat module Expr = Expr_sat
include Msat.Make_pure_sat(Expr)
module F = Msat.Make_smt_expr(Expr)
include Msat.Make(F)(Msat.Make_dummy(F))

2
src/sat/Msat_sat.mli
View file

@ -11,6 +11,6 @@ Copyright 2016 Guillaume Bury
module Expr = Expr_sat module Expr = Expr_sat
include Msat.S with type formula = Expr.t and type theory = unit include Msat.S with type Formula.t = Expr.t and type theory = unit
(** A functor that can generate as many solvers as needed. *) (** A functor that can generate as many solvers as needed. *)

37
tests/test_api.ml
View file

@ -7,6 +7,7 @@ Copyright 2014 Simon Cruanes
(* Tests that require the API *) (* Tests that require the API *)
module F = Msat_sat.Expr module F = Msat_sat.Expr
module S = Msat_sat
let (|>) x f = f x let (|>) x f = f x
@ -36,27 +37,7 @@ type solver_res =
exception Incorrect_model exception Incorrect_model
module type BASIC_SOLVER = sig let mk_solver () : S.t = S.create ~size:`Big ()
type t
val create : unit -> t
val solve : t -> ?assumptions:F.t list -> unit -> solver_res
val assume : t -> ?tag:int -> F.t list list -> unit
end
let mk_solver (): (module BASIC_SOLVER) =
let module S = struct
include Msat_sat
let create() = create()
let solve st ?assumptions () =
match solve st ?assumptions() with
| Sat _ ->
R_sat
| Unsat us ->
let p = us.Msat.get_proof () in
Proof.check p;
R_unsat
end
in (module S)
exception Error of string exception Error of string
@ -86,20 +67,22 @@ module Test = struct
let run (t:t): result = let run (t:t): result =
(* Interesting stuff happening *) (* Interesting stuff happening *)
let (module S: BASIC_SOLVER) = mk_solver () in let st = mk_solver() in
let st = S.create() in
try try
List.iter List.iter
(function (function
| A_assume cs -> | A_assume cs ->
S.assume st cs S.assume st cs
| A_solve (assumptions, expect) -> | A_solve (assumptions, expect) ->
let assumptions = List.map (S.make_atom st) assumptions in
match S.solve st ~assumptions (), expect with match S.solve st ~assumptions (), expect with
| R_sat, `Expect_sat | S.Sat _, `Expect_sat -> ()
| R_unsat, `Expect_unsat -> () | S.Unsat us, `Expect_unsat ->
| R_unsat, `Expect_sat -> let p = us.Msat.get_proof () in
S.Proof.check p;
| S.Unsat _, `Expect_sat ->
error "expect sat, got unsat" error "expect sat, got unsat"
| R_sat, `Expect_unsat -> | S.Sat _, `Expect_unsat ->
error "expect unsat, got sat" error "expect unsat, got sat"
) )
t.actions; t.actions;