mirror of
https://github.com/c-cube/sidekick.git
synced 2026-01-22 17:36:41 -05:00
vendor current msat in src/sat for further modifications
This commit is contained in:
commit
1a58ab0bfc
48 changed files with 5799 additions and 5 deletions
5
.header
5
.header
|
|
@ -1,5 +0,0 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
13
src/sat/.gitignore
vendored
Normal file
13
src/sat/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
_build/
|
||||
*.annot
|
||||
*.native
|
||||
*.log
|
||||
*.status
|
||||
.*.swp
|
||||
.session
|
||||
*.docdir
|
||||
src/util/log.ml
|
||||
doc/index.html
|
||||
*.exe
|
||||
.merlin
|
||||
*.install
|
||||
118
src/sat/CHANGELOG.md
Normal file
118
src/sat/CHANGELOG.md
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
# CHANGES
|
||||
|
||||
## 0.9.1
|
||||
|
||||
- add `on_conflit` callback
|
||||
- fix termination issue when using `push_decision_lit` from plugin
|
||||
|
||||
## 0.9
|
||||
|
||||
- feat: allow the theory to ask for some literals to be decided on
|
||||
- feat: allow to set the default polarity of variables at creation time
|
||||
|
||||
## 0.8.3
|
||||
|
||||
- support containers 3.0
|
||||
|
||||
## 0.8.2
|
||||
|
||||
- fix opam file
|
||||
- fix: allow conflicts below decision level in `Make_cdcl_t`
|
||||
|
||||
## 0.8.1
|
||||
|
||||
- fixes in `Heap`
|
||||
- package for `msat-bin`
|
||||
- use `iter` instead of `sequence` in dune and opam files
|
||||
- more docs
|
||||
|
||||
## 0.8
|
||||
|
||||
big refactoring, change of API with fewer functions, etc.
|
||||
see `git log` for more details.
|
||||
|
||||
## 0.6.1
|
||||
|
||||
- add simple functor for DOT backend
|
||||
- various bugfixes
|
||||
|
||||
## 0.6
|
||||
|
||||
### Feature
|
||||
|
||||
- An already instantiated sat solver in the Sat module
|
||||
- A `full_slice` function for running possibly expensive satisfiability
|
||||
tests (in SMT) when a propositional model has been found
|
||||
- Forgetful propagations: propagations whose reason (i.e clause) is not watched
|
||||
|
||||
## 0.5.1
|
||||
|
||||
### Bug
|
||||
|
||||
- Removed some needless allocations
|
||||
|
||||
### Breaking
|
||||
|
||||
- Better interface for mcsat propagations
|
||||
|
||||
### Feature
|
||||
|
||||
- Allow level 0 semantic propagations
|
||||
|
||||
## 0.5
|
||||
|
||||
### Bug
|
||||
|
||||
- Grow heap when adding local hyps
|
||||
- Avoid forgetting some one atom clauses
|
||||
- Fixed a bug for propagations at level 0
|
||||
- Late propagations need to be re-propagated
|
||||
- Fixed conflict at level 0
|
||||
- Avoid forgetting some theory conflict clauses
|
||||
|
||||
### Breaking
|
||||
|
||||
- Changed `if_sat` interface
|
||||
|
||||
## 0.4.1
|
||||
|
||||
### Bug
|
||||
|
||||
- fix bug in `add_clause`
|
||||
|
||||
## 0.4
|
||||
|
||||
- performance improvements
|
||||
- many bugfixes
|
||||
- more tests
|
||||
|
||||
### Breaking
|
||||
|
||||
- remove push/pop (source of many bugs)
|
||||
- replaced by solve : assumptions:lit list -> unit -> result
|
||||
|
||||
### Features
|
||||
|
||||
- Accept late conflict clauses
|
||||
- cleaner API, moving some types outside the client-required interface
|
||||
|
||||
## 0.3
|
||||
|
||||
### Features
|
||||
|
||||
- Proofs for atoms at level 0
|
||||
- Compatibility with ocaml >= 4.00
|
||||
- Released some restrictions on dummy sat theories
|
||||
|
||||
## 0.2
|
||||
|
||||
### Breaking
|
||||
|
||||
- Log argument has been removed from functors
|
||||
- All the functors now take a dummy last argument to ensure the solver modules are unique
|
||||
|
||||
### Features
|
||||
|
||||
- push/pop operations
|
||||
- access to decision level when evaluating literals
|
||||
|
||||
188
src/sat/README.md
Normal file
188
src/sat/README.md
Normal file
|
|
@ -0,0 +1,188 @@
|
|||
# MSAT [](https://travis-ci.org/Gbury/mSAT)
|
||||
|
||||
MSAT is an OCaml library that features a modular SAT-solver and some
|
||||
extensions (including SMT), derived from [Alt-Ergo Zero](http://cubicle.lri.fr/alt-ergo-zero).
|
||||
|
||||
It was presented at [ICFP 2017](https://icfp17.sigplan.org/event/ocaml-2017-papers-msat-an-ocaml-sat-solver),
|
||||
using a [poster](https://github.com/Gbury/mSAT/blob/master/articles/icfp_2017.pdf)
|
||||
|
||||
|
||||
## COPYRIGHT
|
||||
|
||||
This program is distributed under the Apache Software License version
|
||||
2.0. See the enclosed file `LICENSE`.
|
||||
|
||||
## Documentation
|
||||
|
||||
See https://gbury.github.io/mSAT/
|
||||
|
||||
## INSTALLATION
|
||||
|
||||
### Via opam
|
||||
|
||||
Once the package is on [opam](http://opam.ocaml.org), just `opam install msat`.
|
||||
For the development version, use:
|
||||
|
||||
```
|
||||
opam pin add msat https://github.com/Gbury/mSAT.git
|
||||
```
|
||||
|
||||
### Manual installation
|
||||
|
||||
You will need `dune` and `iter`. The command is:
|
||||
|
||||
```
|
||||
$ make install
|
||||
```
|
||||
|
||||
## USAGE
|
||||
|
||||
### Generic SAT/SMT Solver
|
||||
|
||||
A modular implementation of the SMT algorithm can be found in the `Msat.Solver` module,
|
||||
as a functor which takes two modules :
|
||||
|
||||
- A representation of formulas (which implements the `Formula_intf.S` signature)
|
||||
|
||||
- A theory (which implements the `Theory_intf.S` signature) to check consistence of assertions.
|
||||
|
||||
- A dummy empty module to ensure generativity of the solver (solver modules heavily relies on
|
||||
side effects to their internal state)
|
||||
|
||||
### Sat Solver
|
||||
|
||||
A ready-to-use SAT solver is available in the `Msat_sat` module
|
||||
using the `msat.sat` library. It can be loaded
|
||||
as shown in the following code :
|
||||
|
||||
```ocaml
|
||||
# #require "msat";;
|
||||
# #require "msat.sat";;
|
||||
# #print_depth 0;; (* do not print details *)
|
||||
```
|
||||
|
||||
Then we can create a solver and create some boolean variables:
|
||||
|
||||
```ocaml
|
||||
module Sat = Msat_sat
|
||||
module E = Sat.Int_lit (* expressions *)
|
||||
|
||||
let solver = Sat.create()
|
||||
|
||||
(* We create here two distinct atoms *)
|
||||
let a = E.fresh () (* A 'new_atom' is always distinct from any other atom *)
|
||||
let b = E.make 1 (* Atoms can be created from integers *)
|
||||
```
|
||||
|
||||
We can try and check the satisfiability of some clauses — here, the clause `a or b`.
|
||||
`Sat.assume` adds a list of clauses to the solver. Calling `Sat.solve`
|
||||
will check the satisfiability of the current set of clauses, here "Sat".
|
||||
|
||||
```ocaml
|
||||
# a <> b;;
|
||||
- : bool = true
|
||||
# Sat.assume solver [[a; b]] ();;
|
||||
- : unit = ()
|
||||
# let res = Sat.solve solver;;
|
||||
val res : Sat.res = Sat.Sat ...
|
||||
```
|
||||
|
||||
The Sat solver has an incremental mutable state, so we still have
|
||||
the clause `a or b` in our assumptions.
|
||||
We add `not a` and `not b` to the state, and get "Unsat".
|
||||
|
||||
```ocaml
|
||||
# Sat.assume solver [[E.neg a]; [E.neg b]] () ;;
|
||||
- : unit = ()
|
||||
# let res = Sat.solve solver ;;
|
||||
val res : Sat.res = Sat.Unsat ...
|
||||
```
|
||||
|
||||
#### Formulas API
|
||||
|
||||
Writing clauses by hand can be tedious and error-prone.
|
||||
The functor `Msat_tseitin.Make` in the library `msat.tseitin`
|
||||
proposes a formula AST (parametrized by
|
||||
atoms) and a function to convert these formulas into clauses:
|
||||
|
||||
```ocaml
|
||||
# #require "msat.tseitin";;
|
||||
```
|
||||
|
||||
```ocaml
|
||||
(* Module initialization *)
|
||||
module F = Msat_tseitin.Make(E)
|
||||
|
||||
let solver = Sat.create ()
|
||||
|
||||
(* We create here two distinct atoms *)
|
||||
let a = E.fresh () (* A fresh atom is always distinct from any other atom *)
|
||||
let b = E.make 1 (* Atoms can be created from integers *)
|
||||
|
||||
(* Let's create some formulas *)
|
||||
let p = F.make_atom a
|
||||
let q = F.make_atom b
|
||||
let r = F.make_and [p; q]
|
||||
let s = F.make_or [F.make_not p; F.make_not q]
|
||||
```
|
||||
|
||||
We can try and check the satisfiability of the given formulas, by turning
|
||||
it into clauses using `make_cnf`:
|
||||
|
||||
```ocaml
|
||||
# Sat.assume solver (F.make_cnf r) ();;
|
||||
- : unit = ()
|
||||
# Sat.solve solver;;
|
||||
- : Sat.res = Sat.Sat ...
|
||||
```
|
||||
|
||||
```ocaml
|
||||
# Sat.assume solver (F.make_cnf s) ();;
|
||||
- : unit = ()
|
||||
# Sat.solve solver ;;
|
||||
- : Sat.res = Sat.Unsat ...
|
||||
```
|
||||
|
||||
### CDCL(T): a Sudoku solver as an example
|
||||
|
||||
The directory `src/sudoku/` contains a simple Sudoku solver that
|
||||
uses the interface `Msat.Make_cdcl_t`.
|
||||
In essence, it implements the logical theory `CDCL(Sudoku)`.
|
||||
The script `sudoku_solve.sh` compiles and runs the solver,
|
||||
as does `dune exec src/sudoku/sudoku_solve.exe`.
|
||||
|
||||
It's able to parse sudoku grids denoted as 81 integers
|
||||
(see `tests/sudoku/sudoku.txt` for example).
|
||||
|
||||
Here is a sample grid and the output from the solver (in roughly .5s):
|
||||
|
||||
```sh non-deterministic=command
|
||||
$ echo '..............3.85..1.2.......5.7.....4...1...9.......5......73..2.1........4...9' > sudoku.txt
|
||||
$ dune exec src/sudoku/sudoku_solve.exe -- sudoku.txt
|
||||
...
|
||||
#########################
|
||||
solve grid:
|
||||
.........
|
||||
.....3.85
|
||||
..1.2....
|
||||
...5.7...
|
||||
..4...1..
|
||||
.9.......
|
||||
5......73
|
||||
..2.1....
|
||||
....4...9
|
||||
|
||||
...
|
||||
987654321
|
||||
246173985
|
||||
351928746
|
||||
128537694
|
||||
634892157
|
||||
795461832
|
||||
519286473
|
||||
472319568
|
||||
863745219
|
||||
|
||||
###################
|
||||
...
|
||||
```
|
||||
10
src/sat/dune
Normal file
10
src/sat/dune
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
|
||||
(alias
|
||||
(name runtest)
|
||||
(deps README.md src/core/msat.cma src/sat/msat_sat.cma (source_tree src))
|
||||
(locks test)
|
||||
(package msat)
|
||||
(action (progn
|
||||
(run mdx test README.md)
|
||||
(diff? README.md README.md.corrected))))
|
||||
|
||||
27
src/sat/src/backend/Backend_intf.ml
Normal file
27
src/sat/src/backend/Backend_intf.ml
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
|
||||
(** Backend interface
|
||||
|
||||
This modules defines the interface of the modules providing
|
||||
export of proofs.
|
||||
*)
|
||||
|
||||
module type S = sig
|
||||
(** Proof exporting
|
||||
|
||||
Currently, exporting a proof means printing it into a file
|
||||
according to the conventions of a given format.
|
||||
*)
|
||||
|
||||
type t
|
||||
(** The type of proofs. *)
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
(** A function for printing proofs in the desired format. *)
|
||||
|
||||
end
|
||||
|
||||
193
src/sat/src/backend/Coq.ml
Normal file
193
src/sat/src/backend/Coq.ml
Normal file
|
|
@ -0,0 +1,193 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2015 Guillaume Bury
|
||||
*)
|
||||
|
||||
module type S = Backend_intf.S
|
||||
|
||||
module type Arg = sig
|
||||
|
||||
type hyp
|
||||
type lemma
|
||||
type assumption
|
||||
|
||||
val prove_hyp : Format.formatter -> string -> hyp -> unit
|
||||
val prove_lemma : Format.formatter -> string -> lemma -> unit
|
||||
val prove_assumption : Format.formatter -> string -> assumption -> unit
|
||||
|
||||
end
|
||||
|
||||
module Make(S : Msat.S)(A : Arg with type hyp := S.clause
|
||||
and type lemma := S.clause
|
||||
and type assumption := S.clause) = struct
|
||||
|
||||
module Atom = S.Atom
|
||||
module Clause = S.Clause
|
||||
module M = Map.Make(S.Atom)
|
||||
module C_tbl = S.Clause.Tbl
|
||||
module P = S.Proof
|
||||
|
||||
let name = Clause.name
|
||||
|
||||
let clause_map c =
|
||||
let rec aux acc a i =
|
||||
if i >= Array.length a then acc
|
||||
else begin
|
||||
let name = Format.sprintf "A%d" i in
|
||||
aux (M.add a.(i) name acc) a (i + 1)
|
||||
end
|
||||
in
|
||||
aux M.empty (Clause.atoms c) 0
|
||||
|
||||
let clause_iter m format fmt clause =
|
||||
let aux atom = Format.fprintf fmt format (M.find atom m) in
|
||||
Array.iter aux (Clause.atoms clause)
|
||||
|
||||
let elim_duplicate fmt goal hyp _ =
|
||||
(** Printing info comment in coq *)
|
||||
Format.fprintf fmt
|
||||
"(* Eliminating doublons. Goal : %s ; Hyp : %s *)@\n"
|
||||
(name goal) (name hyp);
|
||||
(** Prove the goal: intro the atoms, then use them with the hyp *)
|
||||
let m = clause_map goal in
|
||||
Format.fprintf fmt "pose proof @[<hov>(fun %a=>@ %s%a) as %s@].@\n"
|
||||
(clause_iter m "%s@ ") goal (name hyp)
|
||||
(clause_iter m "@ %s") hyp (name goal)
|
||||
|
||||
let resolution_aux m a h1 h2 fmt () =
|
||||
Format.fprintf fmt "%s%a" (name h1)
|
||||
(fun fmt -> Array.iter (fun b ->
|
||||
if b == a then begin
|
||||
Format.fprintf fmt "@ (fun p =>@ %s%a)"
|
||||
(name h2) (fun fmt -> (Array.iter (fun c ->
|
||||
if Atom.equal c (Atom.neg a) then
|
||||
Format.fprintf fmt "@ (fun np => np p)"
|
||||
else
|
||||
Format.fprintf fmt "@ %s" (M.find c m)))
|
||||
) (Clause.atoms h2)
|
||||
end else
|
||||
Format.fprintf fmt "@ %s" (M.find b m)
|
||||
)) (Clause.atoms h1)
|
||||
|
||||
let resolution fmt goal hyp1 hyp2 atom =
|
||||
let a = Atom.abs atom in
|
||||
let h1, h2 =
|
||||
if Array.exists (Atom.equal a) (Clause.atoms hyp1) then hyp1, hyp2
|
||||
else (
|
||||
assert (Array.exists (Atom.equal a) (Clause.atoms hyp2));
|
||||
hyp2, hyp1
|
||||
)
|
||||
in
|
||||
(** Print some debug info *)
|
||||
Format.fprintf fmt
|
||||
"(* Clausal resolution. Goal : %s ; Hyps : %s, %s *)@\n"
|
||||
(name goal) (name h1) (name h2);
|
||||
(** Prove the goal: intro the axioms, then perform resolution *)
|
||||
if Array.length (Clause.atoms goal) = 0 then (
|
||||
let m = M.empty in
|
||||
Format.fprintf fmt "exact @[<hov 1>(%a)@].@\n" (resolution_aux m a h1 h2) ();
|
||||
false
|
||||
) else (
|
||||
let m = clause_map goal in
|
||||
Format.fprintf fmt "pose proof @[<hov>(fun %a=>@ %a)@ as %s.@]@\n"
|
||||
(clause_iter m "%s@ ") goal (resolution_aux m a h1 h2) () (name goal);
|
||||
true
|
||||
)
|
||||
|
||||
(* Count uses of hypotheses *)
|
||||
let incr_use h c =
|
||||
let i = try C_tbl.find h c with Not_found -> 0 in
|
||||
C_tbl.add h c (i + 1)
|
||||
|
||||
let decr_use h c =
|
||||
let i = C_tbl.find h c - 1 in
|
||||
assert (i >= 0);
|
||||
let () = C_tbl.add h c i in
|
||||
i <= 0
|
||||
|
||||
let clear fmt c =
|
||||
Format.fprintf fmt "clear %s." (name c)
|
||||
|
||||
let rec clean_aux fmt = function
|
||||
| [] -> ()
|
||||
| [x] ->
|
||||
Format.fprintf fmt "%a@\n" clear x
|
||||
| x :: ((_ :: _) as r) ->
|
||||
Format.fprintf fmt "%a@ %a" clear x clean_aux r
|
||||
|
||||
let clean h fmt l =
|
||||
match List.filter (decr_use h) l with
|
||||
| [] -> ()
|
||||
| l' ->
|
||||
Format.fprintf fmt "(* Clearing unused clauses *)@\n%a" clean_aux l'
|
||||
|
||||
let prove_node t fmt node =
|
||||
let clause = node.P.conclusion in
|
||||
match node.P.step with
|
||||
| P.Hypothesis _ ->
|
||||
A.prove_hyp fmt (name clause) clause
|
||||
| P.Assumption ->
|
||||
A.prove_assumption fmt (name clause) clause
|
||||
| P.Lemma _ ->
|
||||
A.prove_lemma fmt (name clause) clause
|
||||
| P.Duplicate (p, l) ->
|
||||
let c = P.conclusion p in
|
||||
let () = elim_duplicate fmt clause c l in
|
||||
clean t fmt [c]
|
||||
| P.Hyper_res hr ->
|
||||
let (p1, p2, a) = P.res_of_hyper_res hr in
|
||||
let c1 = P.conclusion p1 in
|
||||
let c2 = P.conclusion p2 in
|
||||
if resolution fmt clause c1 c2 a then clean t fmt [c1; c2]
|
||||
|
||||
let count_uses p =
|
||||
let h = C_tbl.create 128 in
|
||||
let aux () node =
|
||||
List.iter (fun p' -> incr_use h P.(conclusion p')) (P.parents node.P.step)
|
||||
in
|
||||
let () = P.fold aux () p in
|
||||
h
|
||||
|
||||
(* Here the main idea is to always try and have exactly
|
||||
one goal to prove, i.e False. So each *)
|
||||
let pp fmt p =
|
||||
let h = count_uses p in
|
||||
let aux () node =
|
||||
Format.fprintf fmt "%a" (prove_node h) node
|
||||
in
|
||||
Format.fprintf fmt "(* Coq proof generated by mSAT*)@\n";
|
||||
P.fold aux () p
|
||||
end
|
||||
|
||||
|
||||
module Simple(S : Msat.S)
|
||||
(A : Arg with type hyp = S.formula list
|
||||
and type lemma := S.lemma
|
||||
and type assumption := S.formula) =
|
||||
Make(S)(struct
|
||||
module P = S.Proof
|
||||
|
||||
(* Some helpers *)
|
||||
let lit = S.Atom.formula
|
||||
|
||||
let get_assumption c =
|
||||
match S.Clause.atoms_l c with
|
||||
| [ x ] -> x
|
||||
| _ -> assert false
|
||||
|
||||
let get_lemma c =
|
||||
match P.expand (P.prove c) with
|
||||
| {P.step=P.Lemma p; _} -> p
|
||||
| _ -> assert false
|
||||
|
||||
let prove_hyp fmt name c =
|
||||
A.prove_hyp fmt name (List.map lit (S.Clause.atoms_l c))
|
||||
|
||||
let prove_lemma fmt name c =
|
||||
A.prove_lemma fmt name (get_lemma c)
|
||||
|
||||
let prove_assumption fmt name c =
|
||||
A.prove_assumption fmt name (lit (get_assumption c))
|
||||
|
||||
end)
|
||||
|
||||
46
src/sat/src/backend/Coq.mli
Normal file
46
src/sat/src/backend/Coq.mli
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2015 Guillaume Bury
|
||||
*)
|
||||
|
||||
(** Coq Backend
|
||||
|
||||
This module provides an easy way to produce coq scripts
|
||||
corresponding to the resolution proofs output by the
|
||||
sat solver. *)
|
||||
|
||||
module type S = Backend_intf.S
|
||||
(** Interface for exporting proofs. *)
|
||||
|
||||
module type Arg = sig
|
||||
(** Term printing for Coq *)
|
||||
|
||||
type hyp
|
||||
type lemma
|
||||
type assumption
|
||||
(** The types of hypotheses, lemmas, and assumptions *)
|
||||
|
||||
val prove_hyp : Format.formatter -> string -> hyp -> unit
|
||||
val prove_lemma : Format.formatter -> string -> lemma -> unit
|
||||
val prove_assumption : Format.formatter -> string -> assumption -> unit
|
||||
(** Proving function for hypotheses, lemmas and assumptions.
|
||||
[prove_x fmt name x] should prove [x], and be such that after
|
||||
executing it, [x] is among the coq hypotheses under the name [name].
|
||||
The hypothesis should be the encoding of the given clause, i.e
|
||||
for a clause [a \/ not b \/ c], the proved hypothesis should be:
|
||||
[ ~ a -> ~ ~ b -> ~ c -> False ], keeping the same order as the
|
||||
one in the atoms array of the clause. *)
|
||||
|
||||
end
|
||||
|
||||
module Make(S : Msat.S)(A : Arg with type hyp := S.clause
|
||||
and type lemma := S.clause
|
||||
and type assumption := S.clause) : S with type t := S.proof
|
||||
(** Base functor to output Coq proofs *)
|
||||
|
||||
|
||||
module Simple(S : Msat.S)(A : Arg with type hyp = S.formula list
|
||||
and type lemma := S.lemma
|
||||
and type assumption := S.formula) : S with type t := S.proof
|
||||
(** Simple functor to output Coq proofs *)
|
||||
|
||||
62
src/sat/src/backend/Dedukti.ml
Normal file
62
src/sat/src/backend/Dedukti.ml
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2015 Guillaume Bury
|
||||
*)
|
||||
|
||||
module type S = Backend_intf.S
|
||||
|
||||
module type Arg = sig
|
||||
|
||||
type proof
|
||||
type lemma
|
||||
type formula
|
||||
|
||||
val pp : Format.formatter -> formula -> unit
|
||||
val prove : Format.formatter -> lemma -> unit
|
||||
val context : Format.formatter -> proof -> unit
|
||||
end
|
||||
|
||||
module Make(S : Msat.S)(A : Arg with type formula := S.formula
|
||||
and type lemma := S.lemma
|
||||
and type proof := S.proof) = struct
|
||||
module P = S.Proof
|
||||
|
||||
let pp_nl fmt = Format.fprintf fmt "@\n"
|
||||
let fprintf fmt format = Format.kfprintf pp_nl fmt format
|
||||
|
||||
let _clause_name = S.Clause.name
|
||||
|
||||
let _pp_clause fmt c =
|
||||
let rec aux fmt = function
|
||||
| [] -> ()
|
||||
| a :: r ->
|
||||
let f, pos =
|
||||
if S.Atom.sign a then
|
||||
S.Atom.formula a, true
|
||||
else
|
||||
S.Atom.formula (S.Atom.neg a), false
|
||||
in
|
||||
fprintf fmt "%s _b %a ->@ %a"
|
||||
(if pos then "_pos" else "_neg") A.pp f aux r
|
||||
in
|
||||
fprintf fmt "_b : Prop ->@ %a ->@ _proof _b" aux (S.Clause.atoms_l c)
|
||||
|
||||
let context fmt p =
|
||||
fprintf fmt "(; Embedding ;)";
|
||||
fprintf fmt "Prop : Type.";
|
||||
fprintf fmt "_proof : Prop -> Type.";
|
||||
fprintf fmt "(; Notations for clauses ;)";
|
||||
fprintf fmt "_pos : Prop -> Prop -> Type.";
|
||||
fprintf fmt "_neg : Prop -> Prop -> Type.";
|
||||
fprintf fmt "[b: Prop, p: Prop] _pos b p --> _proof p -> _proof b.";
|
||||
fprintf fmt "[b: Prop, p: Prop] _neg b p --> _pos b p -> _proof b.";
|
||||
A.context fmt p
|
||||
|
||||
let pp fmt p =
|
||||
fprintf fmt "#NAME Proof.";
|
||||
fprintf fmt "(; Dedukti file automatically generated by mSAT ;)";
|
||||
context fmt p;
|
||||
()
|
||||
|
||||
end
|
||||
|
||||
32
src/sat/src/backend/Dedukti.mli
Normal file
32
src/sat/src/backend/Dedukti.mli
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
|
||||
(** Deduki backend for proofs
|
||||
|
||||
Work in progress...
|
||||
*)
|
||||
|
||||
module type S = Backend_intf.S
|
||||
|
||||
module type Arg = sig
|
||||
|
||||
type lemma
|
||||
type proof
|
||||
type formula
|
||||
|
||||
val pp : Format.formatter -> formula -> unit
|
||||
val prove : Format.formatter -> lemma -> unit
|
||||
val context : Format.formatter -> proof -> unit
|
||||
end
|
||||
|
||||
module Make :
|
||||
functor(S : Msat.S) ->
|
||||
functor(A : Arg
|
||||
with type formula := S.formula
|
||||
and type lemma := S.lemma
|
||||
and type proof := S.proof) ->
|
||||
S with type t := S.proof
|
||||
(** Functor to generate a backend to output proofs for the dedukti type checker. *)
|
||||
191
src/sat/src/backend/Dot.ml
Normal file
191
src/sat/src/backend/Dot.ml
Normal file
|
|
@ -0,0 +1,191 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
|
||||
(** Output interface for the backend *)
|
||||
module type S = Backend_intf.S
|
||||
|
||||
(** Input module for the backend *)
|
||||
module type Arg = sig
|
||||
|
||||
type atom
|
||||
(* Type of atoms *)
|
||||
|
||||
type hyp
|
||||
type lemma
|
||||
type assumption
|
||||
(** Types for hypotheses, lemmas, and assumptions. *)
|
||||
|
||||
val print_atom : Format.formatter -> atom -> unit
|
||||
(** Printing function for atoms *)
|
||||
|
||||
val hyp_info : hyp -> string * string option * (Format.formatter -> unit -> unit) list
|
||||
val lemma_info : lemma -> string * string option * (Format.formatter -> unit -> unit) list
|
||||
val assumption_info : assumption -> string * string option * (Format.formatter -> unit -> unit) list
|
||||
(** Functions to return information about hypotheses and lemmas *)
|
||||
|
||||
end
|
||||
|
||||
module Default(S : Msat.S) = struct
|
||||
module Atom = S.Atom
|
||||
module Clause = S.Clause
|
||||
|
||||
let print_atom = Atom.pp
|
||||
|
||||
let hyp_info c =
|
||||
"hypothesis", Some "LIGHTBLUE",
|
||||
[ fun fmt () -> Format.fprintf fmt "%s" @@ Clause.name c]
|
||||
|
||||
let lemma_info c =
|
||||
"lemma", Some "BLUE",
|
||||
[ fun fmt () -> Format.fprintf fmt "%s" @@ Clause.name c]
|
||||
|
||||
let assumption_info c =
|
||||
"assumption", Some "PURPLE",
|
||||
[ fun fmt () -> Format.fprintf fmt "%s" @@ Clause.name c]
|
||||
|
||||
end
|
||||
|
||||
(** Functor to provide dot printing *)
|
||||
module Make(S : Msat.S)(A : Arg with type atom := S.atom
|
||||
and type hyp := S.clause
|
||||
and type lemma := S.clause
|
||||
and type assumption := S.clause) = struct
|
||||
module Atom = S.Atom
|
||||
module Clause = S.Clause
|
||||
module P = S.Proof
|
||||
|
||||
let node_id n = Clause.name n.P.conclusion
|
||||
let proof_id p = node_id (P.expand p)
|
||||
let res_nn_id n1 n2 = node_id n1 ^ "_" ^ node_id n2 ^ "_res"
|
||||
let res_np_id n1 n2 = node_id n1 ^ "_" ^ proof_id n2 ^ "_res"
|
||||
|
||||
let print_clause fmt c =
|
||||
let v = Clause.atoms c in
|
||||
if Array.length v = 0 then
|
||||
Format.fprintf fmt "⊥"
|
||||
else
|
||||
let n = Array.length v in
|
||||
for i = 0 to n - 1 do
|
||||
Format.fprintf fmt "%a" A.print_atom v.(i);
|
||||
if i < n - 1 then
|
||||
Format.fprintf fmt ", "
|
||||
done
|
||||
|
||||
let print_edge fmt i j =
|
||||
Format.fprintf fmt "%s -> %s;@\n" j i
|
||||
|
||||
let print_edges fmt n =
|
||||
match P.(n.step) with
|
||||
| P.Hyper_res {P.hr_steps=[];_} -> assert false (* NOTE: should never happen *)
|
||||
| P.Hyper_res {P.hr_init; hr_steps=((_,p0)::_) as l} ->
|
||||
print_edge fmt (res_np_id n p0) (proof_id hr_init);
|
||||
List.iter
|
||||
(fun (_,p2) -> print_edge fmt (res_np_id n p2) (proof_id p2))
|
||||
l;
|
||||
| _ -> ()
|
||||
|
||||
let table_options fmt color =
|
||||
Format.fprintf fmt "BORDER=\"0\" CELLBORDER=\"1\" CELLSPACING=\"0\" BGCOLOR=\"%s\"" color
|
||||
|
||||
let table fmt (c, rule, color, l) =
|
||||
Format.fprintf fmt "<TR><TD colspan=\"2\">%a</TD></TR>" print_clause c;
|
||||
match l with
|
||||
| [] ->
|
||||
Format.fprintf fmt "<TR><TD BGCOLOR=\"%s\" colspan=\"2\">%s</TD></TR>" color rule
|
||||
| f :: r ->
|
||||
Format.fprintf fmt "<TR><TD BGCOLOR=\"%s\" rowspan=\"%d\">%s</TD><TD>%a</TD></TR>"
|
||||
color (List.length l) rule f ();
|
||||
List.iter (fun f -> Format.fprintf fmt "<TR><TD>%a</TD></TR>" f ()) r
|
||||
|
||||
let print_dot_node fmt id color c rule rule_color l =
|
||||
Format.fprintf fmt "%s [shape=plaintext, label=<<TABLE %a>%a</TABLE>>];@\n"
|
||||
id table_options color table (c, rule, rule_color, l)
|
||||
|
||||
let print_dot_res_node fmt id a =
|
||||
Format.fprintf fmt "%s [label=<%a>];@\n" id A.print_atom a
|
||||
|
||||
let ttify f c = fun fmt () -> f fmt c
|
||||
|
||||
let print_contents fmt n =
|
||||
match P.(n.step) with
|
||||
(* Leafs of the proof tree *)
|
||||
| P.Hypothesis _ ->
|
||||
let rule, color, l = A.hyp_info P.(n.conclusion) in
|
||||
let color = match color with None -> "LIGHTBLUE" | Some c -> c in
|
||||
print_dot_node fmt (node_id n) "LIGHTBLUE" P.(n.conclusion) rule color l
|
||||
| P.Assumption ->
|
||||
let rule, color, l = A.assumption_info P.(n.conclusion) in
|
||||
let color = match color with None -> "LIGHTBLUE" | Some c -> c in
|
||||
print_dot_node fmt (node_id n) "LIGHTBLUE" P.(n.conclusion) rule color l
|
||||
| P.Lemma _ ->
|
||||
let rule, color, l = A.lemma_info P.(n.conclusion) in
|
||||
let color = match color with None -> "YELLOW" | Some c -> c in
|
||||
print_dot_node fmt (node_id n) "LIGHTBLUE" P.(n.conclusion) rule color l
|
||||
|
||||
(* Tree nodes *)
|
||||
| P.Duplicate (p, l) ->
|
||||
print_dot_node fmt (node_id n) "GREY" P.(n.conclusion) "Duplicate" "GREY"
|
||||
((fun fmt () -> (Format.fprintf fmt "%s" (node_id n))) ::
|
||||
List.map (ttify A.print_atom) l);
|
||||
print_edge fmt (node_id n) (node_id (P.expand p))
|
||||
| P.Hyper_res {P.hr_steps=l; _} ->
|
||||
print_dot_node fmt (node_id n) "GREY" P.(n.conclusion) "Resolution" "GREY"
|
||||
[(fun fmt () -> (Format.fprintf fmt "%s" (node_id n)))];
|
||||
List.iter
|
||||
(fun (a,p2) ->
|
||||
print_dot_res_node fmt (res_np_id n p2) a;
|
||||
print_edge fmt (node_id n) (res_np_id n p2))
|
||||
l
|
||||
|
||||
let print_node fmt n =
|
||||
print_contents fmt n;
|
||||
print_edges fmt n
|
||||
|
||||
let pp fmt p =
|
||||
Format.fprintf fmt "digraph proof {@\n";
|
||||
P.fold (fun () -> print_node fmt) () p;
|
||||
Format.fprintf fmt "}@."
|
||||
|
||||
end
|
||||
|
||||
module Simple(S : Msat.S)
|
||||
(A : Arg with type atom := S.formula
|
||||
and type hyp = S.formula list
|
||||
and type lemma := S.lemma
|
||||
and type assumption = S.formula) =
|
||||
Make(S)(struct
|
||||
module Atom = S.Atom
|
||||
module Clause = S.Clause
|
||||
module P = S.Proof
|
||||
|
||||
(* Some helpers *)
|
||||
let lit = Atom.formula
|
||||
|
||||
let get_assumption c =
|
||||
match S.Clause.atoms_l c with
|
||||
| [ x ] -> x
|
||||
| _ -> assert false
|
||||
|
||||
let get_lemma c =
|
||||
match P.expand (P.prove c) with
|
||||
| {P.step=P.Lemma p;_} -> p
|
||||
| _ -> assert false
|
||||
|
||||
(* Actual functions *)
|
||||
let print_atom fmt a =
|
||||
A.print_atom fmt (lit a)
|
||||
|
||||
let hyp_info c =
|
||||
A.hyp_info (List.map lit (S.Clause.atoms_l c))
|
||||
|
||||
let lemma_info c =
|
||||
A.lemma_info (get_lemma c)
|
||||
|
||||
let assumption_info c =
|
||||
A.assumption_info (lit (get_assumption c))
|
||||
|
||||
end)
|
||||
|
||||
70
src/sat/src/backend/Dot.mli
Normal file
70
src/sat/src/backend/Dot.mli
Normal file
|
|
@ -0,0 +1,70 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
|
||||
(** Dot backend for proofs
|
||||
|
||||
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.
|
||||
*)
|
||||
|
||||
module type S = Backend_intf.S
|
||||
(** Interface for exporting proofs. *)
|
||||
|
||||
module type Arg = sig
|
||||
(** Term printing for DOT
|
||||
|
||||
This module defines what functions are required in order to export
|
||||
a proof to the DOT format.
|
||||
*)
|
||||
|
||||
type atom
|
||||
(** The type of atomic formuals *)
|
||||
|
||||
type hyp
|
||||
type lemma
|
||||
type assumption
|
||||
(** The type of theory-specifi proofs (also called lemmas). *)
|
||||
|
||||
val print_atom : Format.formatter -> atom -> unit
|
||||
(** Print the contents of the given atomic formulas.
|
||||
WARNING: this function should take care to escape and/or not output special
|
||||
reserved characters for the dot format (such as quotes and so on). *)
|
||||
|
||||
val hyp_info : hyp -> string * string option * (Format.formatter -> unit -> unit) list
|
||||
val lemma_info : lemma -> string * string option * (Format.formatter -> unit -> unit) list
|
||||
val assumption_info : assumption -> string * string option * (Format.formatter -> unit -> unit) list
|
||||
(** Generate some information about the leafs of the proof tree. Currently this backend
|
||||
print each lemma/assumption/hypothesis as a single leaf of the proof tree.
|
||||
These function should return a triplet [(rule, color, l)], such that:
|
||||
- [rule] is a name for the proof (arbitrary, does not need to be unique, but
|
||||
should rather be descriptive)
|
||||
- [color] is a color name (optional) understood by DOT
|
||||
- [l] is a list of printers that will be called to print some additional information
|
||||
*)
|
||||
|
||||
end
|
||||
|
||||
module Default(S : Msat.S) : Arg with type atom := S.atom
|
||||
and type hyp := S.clause
|
||||
and type lemma := S.clause
|
||||
and type assumption := S.clause
|
||||
(** Provides a reasonnable default to instantiate the [Make] functor, assuming
|
||||
the original printing functions are compatible with DOT html labels. *)
|
||||
|
||||
module Make(S : Msat.S)(A : Arg with type atom := S.atom
|
||||
and type hyp := S.clause
|
||||
and type lemma := S.clause
|
||||
and type assumption := S.clause) : S with type t := S.proof
|
||||
(** Functor for making a module to export proofs to the DOT format. *)
|
||||
|
||||
module Simple(S : Msat.S)(A : Arg with type atom := S.formula
|
||||
and type hyp = S.formula list
|
||||
and type lemma := S.lemma
|
||||
and type assumption = S.formula) : S with type t := S.proof
|
||||
(** Functor for making a module to export proofs to the DOT format.
|
||||
The substitution of the hyp type is non-destructive due to a restriction
|
||||
of destructive substitutions on earlier versions of ocaml. *)
|
||||
|
||||
10
src/sat/src/backend/dune
Normal file
10
src/sat/src/backend/dune
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
(library
|
||||
(name msat_backend)
|
||||
(public_name msat.backend)
|
||||
(synopsis "proof backends for msat")
|
||||
(libraries msat)
|
||||
(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
|
||||
-unbox-closures -unbox-closures-factor 20)
|
||||
)
|
||||
|
||||
29
src/sat/src/backtrack/Backtrackable_ref.ml
Normal file
29
src/sat/src/backtrack/Backtrackable_ref.ml
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
|
||||
type 'a t = {
|
||||
mutable cur: 'a;
|
||||
stack: 'a Vec.t;
|
||||
copy: ('a -> 'a) option;
|
||||
}
|
||||
|
||||
let create ?copy x: _ t =
|
||||
{cur=x; stack=Vec.create(); copy}
|
||||
|
||||
let[@inline] get self = self.cur
|
||||
let[@inline] set self x = self.cur <- x
|
||||
let[@inline] update self f = self.cur <- f self.cur
|
||||
|
||||
let[@inline] n_levels self = Vec.size self.stack
|
||||
|
||||
let[@inline] push_level self : unit =
|
||||
let x = self.cur in
|
||||
let x = match self.copy with None -> x | Some f -> f x in
|
||||
Vec.push self.stack x
|
||||
|
||||
let pop_levels self n : unit =
|
||||
assert (n>=0);
|
||||
if n > Vec.size self.stack then invalid_arg "Backtrackable_ref.pop_levels";
|
||||
let i = Vec.size self.stack-n in
|
||||
let x = Vec.get self.stack i in
|
||||
self.cur <- x;
|
||||
Vec.shrink self.stack i;
|
||||
()
|
||||
30
src/sat/src/backtrack/Backtrackable_ref.mli
Normal file
30
src/sat/src/backtrack/Backtrackable_ref.mli
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
|
||||
(** {1 Backtrackable ref} *)
|
||||
|
||||
type 'a t
|
||||
|
||||
val create : ?copy:('a -> 'a) -> 'a -> 'a t
|
||||
(** Create a backtrackable reference holding the given value initially.
|
||||
@param copy if provided, will be used to copy the value when [push_level]
|
||||
is called. *)
|
||||
|
||||
val set : 'a t -> 'a -> unit
|
||||
(** Set the reference's current content *)
|
||||
|
||||
val get : 'a t -> 'a
|
||||
(** Get the reference's current content *)
|
||||
|
||||
val update : 'a t -> ('a -> 'a) -> unit
|
||||
(** Update the reference's current content *)
|
||||
|
||||
val push_level : _ t -> unit
|
||||
(** Push a backtracking level, copying the current value on top of some
|
||||
stack. The [copy] function will be used if it was provided in {!create}. *)
|
||||
|
||||
val n_levels : _ t -> int
|
||||
(** Number of saved values *)
|
||||
|
||||
val pop_levels : _ t -> int -> unit
|
||||
(** Pop [n] levels, restoring to the value the reference was storing [n] calls
|
||||
to [push_level] earlier.
|
||||
@raise Invalid_argument if [n] is bigger than [n_levels]. *)
|
||||
2
src/sat/src/backtrack/Msat_backtrack.ml
Normal file
2
src/sat/src/backtrack/Msat_backtrack.ml
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
module Ref = Backtrackable_ref
|
||||
11
src/sat/src/backtrack/dune
Normal file
11
src/sat/src/backtrack/dune
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(library
|
||||
(name msat_backtrack)
|
||||
(public_name msat.backtrack)
|
||||
(libraries msat)
|
||||
(synopsis "backtrackable data structures for msat")
|
||||
(flags :standard -warn-error -3 -w +a-4-42-44-48-50-58-32-60@8
|
||||
-color always -safe-string -open Msat)
|
||||
(ocamlopt_flags :standard -O3 -bin-annot
|
||||
-unbox-closures -unbox-closures-factor 20)
|
||||
)
|
||||
145
src/sat/src/core/Heap.ml
Normal file
145
src/sat/src/core/Heap.ml
Normal file
|
|
@ -0,0 +1,145 @@
|
|||
|
||||
module type RANKED = Heap_intf.RANKED
|
||||
|
||||
module type S = Heap_intf.S
|
||||
|
||||
module Make(Elt : RANKED) = struct
|
||||
type elt = Elt.t
|
||||
|
||||
type t = {
|
||||
heap : elt Vec.t;
|
||||
} [@@unboxed]
|
||||
|
||||
let _absent_index = -1
|
||||
|
||||
let create () =
|
||||
{ heap = Vec.create(); }
|
||||
|
||||
let[@inline] left i = (i lsl 1) + 1 (* i*2 + 1 *)
|
||||
let[@inline] right i = (i + 1) lsl 1 (* (i+1)*2 *)
|
||||
let[@inline] parent i = (i - 1) asr 1 (* (i-1) / 2 *)
|
||||
|
||||
(*
|
||||
let rec heap_property cmp ({heap=heap} as s) i =
|
||||
i >= (Vec.size heap) ||
|
||||
((i = 0 || not(cmp (Vec. get heap i) (Vec.get heap (parent i))))
|
||||
&& heap_property cmp s (left i) && heap_property cmp s (right i))
|
||||
|
||||
let heap_property cmp s = heap_property cmp s 1
|
||||
*)
|
||||
|
||||
(* [elt] is above or at its expected position. Move it up the heap
|
||||
(towards high indices) to restore the heap property *)
|
||||
let percolate_up {heap} (elt:Elt.t) : unit =
|
||||
let pi = ref (parent (Elt.idx elt)) in
|
||||
let i = ref (Elt.idx elt) in
|
||||
while !i <> 0 && Elt.cmp elt (Vec.get heap !pi) do
|
||||
Vec.set heap !i (Vec.get heap !pi);
|
||||
Elt.set_idx (Vec.get heap !i) !i;
|
||||
i := !pi;
|
||||
pi := parent !i
|
||||
done;
|
||||
Vec.set heap !i elt;
|
||||
Elt.set_idx elt !i
|
||||
|
||||
let percolate_down {heap} (elt:Elt.t): unit =
|
||||
let sz = Vec.size heap in
|
||||
let li = ref (left (Elt.idx elt)) in
|
||||
let ri = ref (right (Elt.idx elt)) in
|
||||
let i = ref (Elt.idx elt) in
|
||||
begin
|
||||
try
|
||||
while !li < sz do
|
||||
let child =
|
||||
if !ri < sz && Elt.cmp (Vec.get heap !ri) (Vec.get heap !li)
|
||||
then !ri
|
||||
else !li
|
||||
in
|
||||
if not (Elt.cmp (Vec.get heap child) elt) then raise Exit;
|
||||
Vec.set heap !i (Vec.get heap child);
|
||||
Elt.set_idx (Vec.get heap !i) !i;
|
||||
i := child;
|
||||
li := left !i;
|
||||
ri := right !i
|
||||
done;
|
||||
with Exit -> ()
|
||||
end;
|
||||
Vec.set heap !i elt;
|
||||
Elt.set_idx elt !i
|
||||
|
||||
let[@inline] in_heap x = Elt.idx x >= 0
|
||||
|
||||
let[@inline] decrease s x = assert (in_heap x); percolate_up s x
|
||||
|
||||
(*
|
||||
let increase cmp s n =
|
||||
assert (in_heap s n); percolate_down cmp s (V.get s.indices n)
|
||||
*)
|
||||
|
||||
let filter s filt =
|
||||
let j = ref 0 in
|
||||
let lim = Vec.size s.heap in
|
||||
for i = 0 to lim - 1 do
|
||||
if filt (Vec.get s.heap i) then (
|
||||
Vec.set s.heap !j (Vec.get s.heap i);
|
||||
Elt.set_idx (Vec.get s.heap i) !j;
|
||||
incr j;
|
||||
) else (
|
||||
Elt.set_idx (Vec.get s.heap i) _absent_index;
|
||||
);
|
||||
done;
|
||||
Vec.shrink s.heap (lim - !j);
|
||||
for i = (lim / 2) - 1 downto 0 do
|
||||
percolate_down s (Vec.get s.heap i)
|
||||
done
|
||||
|
||||
let size s = Vec.size s.heap
|
||||
|
||||
let is_empty s = Vec.is_empty s.heap
|
||||
|
||||
let clear {heap} =
|
||||
Vec.iter (fun e -> Elt.set_idx e _absent_index) heap;
|
||||
Vec.clear heap;
|
||||
()
|
||||
|
||||
let insert s elt =
|
||||
if not (in_heap elt) then (
|
||||
Elt.set_idx elt (Vec.size s.heap);
|
||||
Vec.push s.heap elt;
|
||||
percolate_up s elt;
|
||||
)
|
||||
|
||||
(*
|
||||
let update cmp s n =
|
||||
assert (heap_property cmp s);
|
||||
begin
|
||||
if in_heap s n then
|
||||
begin
|
||||
percolate_up cmp s (Vec.get s.indices n);
|
||||
percolate_down cmp s (Vec.get s.indices n)
|
||||
end
|
||||
else insert cmp s n
|
||||
end;
|
||||
assert (heap_property cmp s)
|
||||
*)
|
||||
|
||||
let remove_min ({heap} as s) =
|
||||
match Vec.size heap with
|
||||
| 0 -> raise Not_found
|
||||
| 1 ->
|
||||
let x = Vec.pop heap in
|
||||
Elt.set_idx x _absent_index;
|
||||
x
|
||||
| _ ->
|
||||
let x = Vec.get heap 0 in
|
||||
let new_hd = Vec.pop heap in (* heap.last() *)
|
||||
Vec.set heap 0 new_hd;
|
||||
Elt.set_idx x _absent_index;
|
||||
Elt.set_idx new_hd 0;
|
||||
(* enforce heap property again *)
|
||||
if Vec.size heap > 1 then (
|
||||
percolate_down s new_hd;
|
||||
);
|
||||
x
|
||||
|
||||
end [@@inline]
|
||||
5
src/sat/src/core/Heap.mli
Normal file
5
src/sat/src/core/Heap.mli
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
module type RANKED = Heap_intf.RANKED
|
||||
|
||||
module type S = Heap_intf.S
|
||||
|
||||
module Make(X : RANKED) : S with type elt = X.t
|
||||
46
src/sat/src/core/Heap_intf.ml
Normal file
46
src/sat/src/core/Heap_intf.ml
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
|
||||
module type RANKED = sig
|
||||
type t
|
||||
val idx: t -> int (** Index in heap. return -1 if never set *)
|
||||
val set_idx : t -> int -> unit (** Update index in heap *)
|
||||
val cmp : t -> t -> bool
|
||||
end
|
||||
|
||||
module type S = sig
|
||||
type elt
|
||||
(** Type of elements *)
|
||||
|
||||
type t
|
||||
(** Heap of {!elt}, whose priority is increased or decreased
|
||||
incrementally (see {!decrease} for instance) *)
|
||||
|
||||
val create : unit -> t
|
||||
(** Create a heap *)
|
||||
|
||||
val decrease : t -> elt -> unit
|
||||
(** [decrease h x] decreases the value associated to [x] within [h] *)
|
||||
|
||||
val in_heap : elt -> bool
|
||||
|
||||
(*val increase : (int -> int -> bool) -> t -> int -> unit*)
|
||||
|
||||
val size : t -> int
|
||||
(** Number of integers within the heap *)
|
||||
|
||||
val is_empty : t -> bool
|
||||
|
||||
val clear : t -> unit
|
||||
(** Clear the content of the heap *)
|
||||
|
||||
val insert : t -> elt -> unit
|
||||
(** Insert a new element into the heap *)
|
||||
|
||||
(*val update : (int -> int -> bool) -> t -> int -> unit*)
|
||||
|
||||
val remove_min : t -> elt
|
||||
(** Remove and return the integer that has the lowest value from the heap
|
||||
@raise Not_found if the heap is empty *)
|
||||
|
||||
val filter : t -> (elt -> bool) -> unit
|
||||
(** Filter out values that don't satisfy the predicate *)
|
||||
end
|
||||
2275
src/sat/src/core/Internal.ml
Normal file
2275
src/sat/src/core/Internal.ml
Normal file
File diff suppressed because it is too large
Load diff
33
src/sat/src/core/Log.ml
Normal file
33
src/sat/src/core/Log.ml
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
|
||||
(** {1 Logging functions, real version} *)
|
||||
|
||||
let enabled = true (* NOTE: change here for 0-overhead *)
|
||||
|
||||
let debug_level_ = ref 0
|
||||
let set_debug l = debug_level_ := l
|
||||
let get_debug () = !debug_level_
|
||||
|
||||
let debug_fmt_ = ref Format.err_formatter
|
||||
|
||||
let set_debug_out f = debug_fmt_ := f
|
||||
|
||||
(* does the printing, inconditionally *)
|
||||
let debug_real_ l k =
|
||||
k (fun fmt ->
|
||||
Format.fprintf !debug_fmt_ "@[<2>@{<Blue>[%d|%.3f]@}@ "
|
||||
l (Sys.time());
|
||||
Format.kfprintf
|
||||
(fun fmt -> Format.fprintf fmt "@]@.")
|
||||
!debug_fmt_ fmt)
|
||||
|
||||
let[@inline] debugf l k =
|
||||
if enabled && l <= !debug_level_ then (
|
||||
debug_real_ l k;
|
||||
)
|
||||
|
||||
let[@inline] debug l msg = debugf l (fun k->k "%s" msg)
|
||||
26
src/sat/src/core/Log.mli
Normal file
26
src/sat/src/core/Log.mli
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
|
||||
(** {1 Logging function, for debugging} *)
|
||||
|
||||
val enabled : bool
|
||||
|
||||
val set_debug : int -> unit (** Set debug level *)
|
||||
val get_debug : unit -> int (** Current debug level *)
|
||||
|
||||
val debugf :
|
||||
int ->
|
||||
((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) ->
|
||||
unit
|
||||
(** Emit a debug message at the given level. If the level is lower
|
||||
than [get_debug ()], the message will indeed be emitted *)
|
||||
|
||||
val debug : int -> string -> unit
|
||||
(** Simpler version of {!debug}, without formatting *)
|
||||
|
||||
val set_debug_out : Format.formatter -> unit
|
||||
(** Change the output formatter. *)
|
||||
|
||||
76
src/sat/src/core/Msat.ml
Normal file
76
src/sat/src/core/Msat.ml
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
(** Main API *)
|
||||
|
||||
|
||||
module Solver_intf = Solver_intf
|
||||
|
||||
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
|
||||
|
||||
(** Empty type *)
|
||||
type void = (unit,bool) Solver_intf.gadt_eq
|
||||
|
||||
type lbool = Solver_intf.lbool = L_true | L_false | L_undefined
|
||||
|
||||
type ('term, 'form, 'value) sat_state = ('term, 'form, 'value) Solver_intf.sat_state = {
|
||||
eval : 'form -> bool;
|
||||
eval_level : 'form -> bool * int;
|
||||
iter_trail : ('form -> unit) -> ('term -> unit) -> unit;
|
||||
model : unit -> ('term * 'value) list;
|
||||
}
|
||||
|
||||
type ('atom,'clause, 'proof) unsat_state = ('atom,'clause, 'proof) Solver_intf.unsat_state = {
|
||||
unsat_conflict : unit -> 'clause;
|
||||
get_proof : unit -> 'proof;
|
||||
unsat_assumptions: unit -> 'atom list;
|
||||
}
|
||||
type 'clause export = 'clause Solver_intf.export = {
|
||||
hyps : 'clause Vec.t;
|
||||
history : 'clause Vec.t;
|
||||
}
|
||||
|
||||
type ('term, 'formula, 'value) assumption = ('term, 'formula, 'value) Solver_intf.assumption =
|
||||
| Lit of 'formula (** The given formula is asserted true by the solver *)
|
||||
| Assign of 'term * 'value (** The term is assigned to the value *)
|
||||
|
||||
type ('term, 'formula, 'proof) reason = ('term, 'formula, 'proof) Solver_intf.reason =
|
||||
| Eval of 'term list
|
||||
| Consequence of (unit -> 'formula list * 'proof)
|
||||
|
||||
type ('term, 'formula, 'value, 'proof) acts = ('term, 'formula, 'value, 'proof) Solver_intf.acts = {
|
||||
acts_iter_assumptions: (('term,'formula,'value) assumption -> unit) -> unit;
|
||||
acts_eval_lit: 'formula -> lbool;
|
||||
acts_mk_lit: ?default_pol:bool -> 'formula -> unit;
|
||||
acts_mk_term: 'term -> unit;
|
||||
acts_add_clause : ?keep:bool -> 'formula list -> 'proof -> unit;
|
||||
acts_raise_conflict: 'b. 'formula list -> 'proof -> 'b;
|
||||
acts_propagate : 'formula -> ('term, 'formula, 'proof) reason -> unit;
|
||||
acts_add_decision_lit: 'formula -> bool -> unit;
|
||||
}
|
||||
|
||||
type negated = Solver_intf.negated = Negated | Same_sign
|
||||
|
||||
(** Print {!negated} values *)
|
||||
let pp_negated out = function
|
||||
| Negated -> Format.fprintf out "negated"
|
||||
| Same_sign -> Format.fprintf out "same-sign"
|
||||
|
||||
(** Print {!lbool} values *)
|
||||
let pp_lbool out = function
|
||||
| L_true -> Format.fprintf out "true"
|
||||
| L_false -> Format.fprintf out "false"
|
||||
| L_undefined -> Format.fprintf out "undefined"
|
||||
|
||||
exception No_proof = Solver_intf.No_proof
|
||||
|
||||
module Make_mcsat = Solver.Make_mcsat
|
||||
module Make_cdcl_t = Solver.Make_cdcl_t
|
||||
module Make_pure_sat = Solver.Make_pure_sat
|
||||
|
||||
(**/**)
|
||||
module Vec = Vec
|
||||
module Log = Log
|
||||
(**/**)
|
||||
12
src/sat/src/core/Solver.ml
Normal file
12
src/sat/src/core/Solver.ml
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2016 Guillaume Bury
|
||||
Copyright 2016 Simon Cruanes
|
||||
*)
|
||||
|
||||
module type S = Solver_intf.S
|
||||
|
||||
module Make_cdcl_t = Internal.Make_cdcl_t
|
||||
module Make_mcsat = Internal.Make_mcsat
|
||||
module Make_pure_sat = Internal.Make_pure_sat
|
||||
|
||||
34
src/sat/src/core/Solver.mli
Normal file
34
src/sat/src/core/Solver.mli
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
|
||||
(** mSAT safe interface
|
||||
|
||||
This module defines a safe interface for the core solver.
|
||||
It is the basis of the {!module:Solver} and {!module:Mcsolver} modules.
|
||||
*)
|
||||
|
||||
module type S = Solver_intf.S
|
||||
(** Safe external interface of solvers. *)
|
||||
|
||||
module Make_cdcl_t(Th : Solver_intf.PLUGIN_CDCL_T)
|
||||
: S with type Term.t = Solver_intf.void
|
||||
and module Formula = Th.Formula
|
||||
and type lemma = Th.proof
|
||||
and type theory = Th.t
|
||||
|
||||
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(Th: Solver_intf.PLUGIN_SAT)
|
||||
: S with type Term.t = Solver_intf.void
|
||||
and module Formula = Th.Formula
|
||||
and type lemma = Th.proof
|
||||
and type theory = unit
|
||||
|
||||
|
||||
514
src/sat/src/core/Solver_intf.ml
Normal file
514
src/sat/src/core/Solver_intf.ml
Normal file
|
|
@ -0,0 +1,514 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2016 Guillaume Bury
|
||||
Copyright 2016 Simon Cruanes
|
||||
*)
|
||||
|
||||
(** Interface for Solvers
|
||||
|
||||
This modules defines the safe external interface for solvers.
|
||||
Solvers that implements this interface can be obtained using the [Make]
|
||||
functor in {!Solver} or {!Mcsolver}.
|
||||
*)
|
||||
|
||||
type 'a printer = Format.formatter -> 'a -> unit
|
||||
|
||||
type ('term, 'form, 'value) sat_state = {
|
||||
eval: 'form -> bool;
|
||||
(** Returns the valuation of a formula in the current state
|
||||
of the sat solver.
|
||||
@raise UndecidedLit if the literal is not decided *)
|
||||
eval_level: 'form -> bool * int;
|
||||
(** Return the current assignement of the literals, as well as its
|
||||
decision level. If the level is 0, then it is necessary for
|
||||
the atom to have this value; otherwise it is due to choices
|
||||
that can potentially be backtracked.
|
||||
@raise UndecidedLit if the literal is not decided *)
|
||||
iter_trail : ('form -> unit) -> ('term -> unit) -> unit;
|
||||
(** Iter thorugh the formulas and terms in order of decision/propagation
|
||||
(starting from the first propagation, to the last propagation). *)
|
||||
model: unit -> ('term * 'value) list;
|
||||
(** Returns the model found if the formula is satisfiable. *)
|
||||
}
|
||||
(** The type of values returned when the solver reaches a SAT state. *)
|
||||
|
||||
type ('atom, 'clause, 'proof) unsat_state = {
|
||||
unsat_conflict : unit -> 'clause;
|
||||
(** Returns the unsat clause found at the toplevel *)
|
||||
get_proof : unit -> 'proof;
|
||||
(** returns a persistent proof of the empty clause from the Unsat result. *)
|
||||
unsat_assumptions: unit -> 'atom list;
|
||||
(** Subset of assumptions responsible for "unsat" *)
|
||||
}
|
||||
(** The type of values returned when the solver reaches an UNSAT state. *)
|
||||
|
||||
type 'clause export = {
|
||||
hyps: 'clause Vec.t;
|
||||
history: 'clause Vec.t;
|
||||
}
|
||||
(** Export internal state *)
|
||||
|
||||
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 ('term, 'formula, 'value) assumption =
|
||||
| Lit of 'formula (** The given formula is asserted true by the solver *)
|
||||
| Assign of 'term * 'value (** The term is assigned to the value *)
|
||||
(** 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 (unit -> '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]".
|
||||
|
||||
invariant: in [Consequence (fun () -> l,p)], all elements of [l] must be true in
|
||||
the current trail.
|
||||
|
||||
{b note} on lazyiness: the justification is suspended (using [unit -> …])
|
||||
to avoid potentially costly computations that might never be used
|
||||
if this literal is backtracked without participating in a conflict.
|
||||
Therefore the function that produces [(l,p)] needs only be safe in
|
||||
trails (partial models) that are conservative extensions of the current
|
||||
trail.
|
||||
If the theory isn't robust w.r.t. extensions of the trail (e.g. if
|
||||
its internal state undergoes significant changes),
|
||||
it can be easier to produce the explanation eagerly when
|
||||
propagating, and then use [Consequence (fun () -> expl, proof)] with
|
||||
the already produced [(expl,proof)] tuple.
|
||||
*)
|
||||
(** The type of reasons for propagations of a formula [f]. *)
|
||||
|
||||
type lbool = L_true | L_false | L_undefined
|
||||
(** Valuation of an atom *)
|
||||
|
||||
(* TODO: find a way to use atoms instead of formulas here *)
|
||||
type ('term, 'formula, 'value, 'proof) acts = {
|
||||
acts_iter_assumptions: (('term,'formula,'value) assumption -> unit) -> unit;
|
||||
(** Traverse the new assumptions on the boolean trail. *)
|
||||
|
||||
acts_eval_lit: 'formula -> lbool;
|
||||
(** Obtain current value of the given literal *)
|
||||
|
||||
acts_mk_lit: ?default_pol:bool -> 'formula -> unit;
|
||||
(** Map the given formula to a literal, which will be decided by the
|
||||
SAT solver. *)
|
||||
|
||||
acts_mk_term: 'term -> unit;
|
||||
(** Map the given term (and its subterms) to decision variables,
|
||||
for the MCSAT solver to decide. *)
|
||||
|
||||
acts_add_clause: ?keep:bool -> 'formula list -> 'proof -> unit;
|
||||
(** Add a clause to the solver.
|
||||
@param keep if true, the clause will be kept by the solver.
|
||||
Otherwise the solver is allowed to GC the clause and propose this
|
||||
partial model again.
|
||||
*)
|
||||
|
||||
acts_raise_conflict: 'b. 'formula list -> 'proof -> 'b;
|
||||
(** Raise a conflict, yielding control back to the solver.
|
||||
The list of atoms must be a valid theory lemma that is false in the
|
||||
current trail. *)
|
||||
|
||||
acts_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} *)
|
||||
|
||||
acts_add_decision_lit: 'formula -> bool -> unit;
|
||||
(** Ask the SAT solver to decide on the given formula with given sign
|
||||
before it can answer [SAT]. The order of decisions is still unspecified.
|
||||
Useful for theory combination. This will be undone on backtracking. *)
|
||||
}
|
||||
(** 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 *)
|
||||
|
||||
exception No_proof
|
||||
|
||||
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 {!equal} have the same hash. *)
|
||||
|
||||
val pp : t printer
|
||||
(** Printing function used among other for debugging. *)
|
||||
end
|
||||
|
||||
module Value : sig
|
||||
type t
|
||||
(** The type of semantic values (domain elements) *)
|
||||
|
||||
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
|
||||
|
||||
val push_level : t -> unit
|
||||
(** Create a new backtrack level *)
|
||||
|
||||
val pop_levels : t -> int -> unit
|
||||
(** Pop [n] levels of the theory *)
|
||||
|
||||
val partial_check : t -> (void, Formula.t, void, proof) acts -> unit
|
||||
(** Assume the formulas in the slice, possibly using the [slice]
|
||||
to push new formulas to be propagated or to raising a conflict or to add
|
||||
new lemmas. *)
|
||||
|
||||
val final_check : t -> (void, Formula.t, void, proof) acts -> unit
|
||||
(** Called at the end of the search in case a model has been found.
|
||||
If no new clause is pushed, then proof search ends and "sat" is returned;
|
||||
if lemmas are added, search is resumed;
|
||||
if a conflict clause is added, search backtracks and then resumes. *)
|
||||
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
|
||||
|
||||
val push_level : t -> unit
|
||||
(** Create a new backtrack level *)
|
||||
|
||||
val pop_levels : t -> int -> unit
|
||||
(** Pop [n] levels of the theory *)
|
||||
|
||||
val partial_check : t -> (Term.t, Formula.t, Value.t, proof) acts -> unit
|
||||
(** Assume the formulas in the slice, possibly using the [slice]
|
||||
to push new formulas to be propagated or to raising a conflict or to add
|
||||
new lemmas. *)
|
||||
|
||||
val final_check : t -> (Term.t, Formula.t, Value.t, proof) acts -> unit
|
||||
(** Called at the end of the search in case a model has been found.
|
||||
If no new clause is pushed, then proof search ends and "sat" is returned;
|
||||
if lemmas are added, search is resumed;
|
||||
if a conflict clause is added, search backtracks and then resumes. *)
|
||||
|
||||
val assign : t -> Term.t -> Value.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
|
||||
|
||||
(** Signature for pure SAT solvers *)
|
||||
module type PLUGIN_SAT = sig
|
||||
module Formula : FORMULA
|
||||
|
||||
type proof
|
||||
end
|
||||
|
||||
module type PROOF = sig
|
||||
(** Signature for a module handling proof by resolution from sat solving traces *)
|
||||
|
||||
(** {3 Type declarations} *)
|
||||
|
||||
exception Resolution_error of string
|
||||
(** Raised when resolution failed. *)
|
||||
|
||||
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 of lemma
|
||||
(** 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. *)
|
||||
| Hyper_res of hyper_res_step
|
||||
|
||||
and hyper_res_step = {
|
||||
hr_init: t;
|
||||
hr_steps: (atom * t) list; (* list of pivot+clause to resolve against [init] *)
|
||||
}
|
||||
|
||||
(** {3 Proof building functions} *)
|
||||
|
||||
val prove : clause -> t
|
||||
(** Given a clause, return a proof of that clause.
|
||||
@raise Resolution_error if it does not succeed. *)
|
||||
|
||||
val prove_unsat : clause -> t
|
||||
(** Given a conflict clause [c], returns a proof of the empty clause.
|
||||
@raise Resolution_error 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 *)
|
||||
|
||||
val res_of_hyper_res : hyper_res_step -> t * t * atom
|
||||
(** Turn an hyper resolution step into a resolution step.
|
||||
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 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_empty_conclusion : t -> unit
|
||||
(** Check that the proof's conclusion is the empty clause,
|
||||
@raise Resolution_error otherwise *)
|
||||
|
||||
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
|
||||
created by the {!Solver.Make} and {!Mcsolver.Make} functors. *)
|
||||
module type S = sig
|
||||
(** {2 Internal modules}
|
||||
These are the internal modules used, you should probably not use them
|
||||
if you're not familiar with the internals of mSAT. *)
|
||||
|
||||
include EXPR
|
||||
|
||||
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 theory
|
||||
|
||||
type lemma
|
||||
(** A theory lemma or an input axiom *)
|
||||
|
||||
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 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. *)
|
||||
|
||||
type t = solver
|
||||
(** Main solver type, containing all state for solving. *)
|
||||
|
||||
val create :
|
||||
?on_conflict:(atom array -> unit) ->
|
||||
?on_decision:(atom -> unit) ->
|
||||
?on_new_atom:(atom -> unit) ->
|
||||
?store_proof:bool ->
|
||||
?size:[`Tiny|`Small|`Big] ->
|
||||
theory ->
|
||||
t
|
||||
(** Create new solver
|
||||
@param theory the theory
|
||||
@param store_proof if true, stores proof (default [true]). Otherwise
|
||||
the functions that return proofs will fail with [No_proof]
|
||||
@param size the initial size of internal data structures. The bigger,
|
||||
the faster, but also the more RAM it uses. *)
|
||||
|
||||
val theory : t -> theory
|
||||
(** Access the theory state *)
|
||||
|
||||
(** {2 Types} *)
|
||||
|
||||
(** Result type for the solver *)
|
||||
type res =
|
||||
| Sat of (term,formula,Value.t) sat_state (** Returned when the solver reaches SAT, with a model *)
|
||||
| Unsat of (atom,clause,Proof.t) unsat_state (** Returned when the solver reaches UNSAT, with a proof *)
|
||||
|
||||
exception UndecidedLit
|
||||
(** Exception raised by the evaluating functions when a literal
|
||||
has not yet been assigned a value. *)
|
||||
|
||||
(** {2 Base operations} *)
|
||||
|
||||
val assume : t -> formula list list -> lemma -> unit
|
||||
(** Add the list of clauses to the current set of assumptions.
|
||||
Modifies the sat solver state in place. *)
|
||||
|
||||
val add_clause : t -> atom list -> lemma -> unit
|
||||
(** Lower level addition of clauses *)
|
||||
|
||||
val add_clause_a : t -> atom array -> lemma -> unit
|
||||
(** Lower level addition of clauses *)
|
||||
|
||||
val solve :
|
||||
?assumptions:atom list ->
|
||||
t -> res
|
||||
(** Try and solves the current set of clauses.
|
||||
@param assumptions additional atomic assumptions to be temporarily added.
|
||||
The assumptions are just used for this call to [solve], they are
|
||||
not saved in the solver's state. *)
|
||||
|
||||
val make_term : t -> term -> unit
|
||||
(** Add a new term (i.e. decision variable) to the solver. This term will
|
||||
be decided on at some point during solving, wether it appears
|
||||
in clauses or not. *)
|
||||
|
||||
val make_atom : t -> formula -> atom
|
||||
(** Add a new atom (i.e propositional formula) to the solver.
|
||||
This formula will be decided on at some point during solving,
|
||||
wether it appears in clauses or not. *)
|
||||
|
||||
val true_at_level0 : t -> atom -> bool
|
||||
(** [true_at_level0 a] returns [true] if [a] was proved at level0, i.e.
|
||||
it must hold in all models *)
|
||||
|
||||
val eval_atom : t -> atom -> lbool
|
||||
(** Evaluate atom in current state *)
|
||||
|
||||
val export : t -> clause export
|
||||
end
|
||||
|
||||
113
src/sat/src/core/Vec.ml
Normal file
113
src/sat/src/core/Vec.ml
Normal file
|
|
@ -0,0 +1,113 @@
|
|||
|
||||
type 'a t = {
|
||||
mutable data : 'a array;
|
||||
mutable sz : int;
|
||||
}
|
||||
|
||||
let make n x = {data=Array.make n x; sz=0}
|
||||
|
||||
let[@inline] create () = {data = [||]; sz = 0}
|
||||
|
||||
let[@inline] clear s = s.sz <- 0
|
||||
|
||||
let[@inline] shrink t i =
|
||||
assert (i >= 0);
|
||||
assert (i<=t.sz);
|
||||
t.sz <- i
|
||||
|
||||
let[@inline] pop t =
|
||||
if t.sz = 0 then invalid_arg "vec.pop";
|
||||
let x = Array.unsafe_get t.data (t.sz - 1) in
|
||||
t.sz <- t.sz - 1;
|
||||
x
|
||||
|
||||
let[@inline] size t = t.sz
|
||||
|
||||
let[@inline] is_empty t = t.sz = 0
|
||||
|
||||
let[@inline] is_full t = Array.length t.data = t.sz
|
||||
|
||||
let[@inline] copy t : _ t =
|
||||
let data = Array.copy t.data in
|
||||
{t with data}
|
||||
|
||||
(* grow the array *)
|
||||
let[@inline never] grow_to_double_size t x : unit =
|
||||
if Array.length t.data = Sys.max_array_length then (
|
||||
failwith "vec: cannot resize";
|
||||
);
|
||||
let size =
|
||||
min Sys.max_array_length (max 4 (2 * Array.length t.data))
|
||||
in
|
||||
let arr' = Array.make size x in
|
||||
Array.blit t.data 0 arr' 0 (Array.length t.data);
|
||||
t.data <- arr';
|
||||
assert (Array.length t.data > t.sz);
|
||||
()
|
||||
|
||||
let[@inline] push t x : unit =
|
||||
if is_full t then grow_to_double_size t x;
|
||||
Array.unsafe_set t.data t.sz x;
|
||||
t.sz <- t.sz + 1
|
||||
|
||||
let[@inline] get t i =
|
||||
if i < 0 || i >= t.sz then invalid_arg "vec.get";
|
||||
Array.unsafe_get t.data i
|
||||
|
||||
let[@inline] set t i v =
|
||||
if i < 0 || i > t.sz then invalid_arg "vec.set";
|
||||
if i = t.sz then (
|
||||
push t v
|
||||
) else (
|
||||
Array.unsafe_set t.data i v
|
||||
)
|
||||
|
||||
let[@inline] fast_remove t i =
|
||||
assert (i>= 0 && i < t.sz);
|
||||
Array.unsafe_set t.data i @@ Array.unsafe_get t.data (t.sz - 1);
|
||||
t.sz <- t.sz - 1
|
||||
|
||||
let filter_in_place f vec =
|
||||
let i = ref 0 in
|
||||
while !i < size vec do
|
||||
if f (Array.unsafe_get vec.data !i) then incr i else fast_remove vec !i
|
||||
done
|
||||
|
||||
let sort t f : unit =
|
||||
let sub_arr = if is_full t then t.data else Array.sub t.data 0 t.sz in
|
||||
Array.fast_sort f sub_arr;
|
||||
t.data <- sub_arr
|
||||
|
||||
let[@inline] iter f t =
|
||||
for i = 0 to size t - 1 do
|
||||
f (Array.unsafe_get t.data i)
|
||||
done
|
||||
|
||||
let[@inline] iteri f t =
|
||||
for i = 0 to size t - 1 do
|
||||
f i (Array.unsafe_get t.data i)
|
||||
done
|
||||
|
||||
let[@inline] to_seq a k = iter k a
|
||||
|
||||
let exists p t = Iter.exists p @@ to_seq t
|
||||
let for_all p t = Iter.for_all p @@ to_seq t
|
||||
let fold f acc a = Iter.fold f acc @@ to_seq a
|
||||
let to_list a = Iter.to_list @@ to_seq a
|
||||
let to_array a = Array.sub a.data 0 a.sz
|
||||
|
||||
let of_list l : _ t =
|
||||
match l with
|
||||
| [] -> create()
|
||||
| x :: tl ->
|
||||
let v = make (List.length tl+1) x in
|
||||
List.iter (push v) l;
|
||||
v
|
||||
|
||||
let pp ?(sep=", ") pp out v =
|
||||
let first = ref true in
|
||||
iter
|
||||
(fun x ->
|
||||
if !first then first := false else Format.fprintf out "%s@," sep;
|
||||
pp out x)
|
||||
v
|
||||
83
src/sat/src/core/Vec.mli
Normal file
83
src/sat/src/core/Vec.mli
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
|
||||
type 'a t
|
||||
(** Abstract type of vectors of 'a *)
|
||||
|
||||
val make : int -> 'a -> 'a t
|
||||
(** [make cap dummy] creates a new vector filled with [dummy]. The vector
|
||||
is initially empty but its underlying array has capacity [cap].
|
||||
[dummy] will stay alive as long as the vector *)
|
||||
|
||||
val create : unit -> 'a t
|
||||
|
||||
val to_list : 'a t -> 'a list
|
||||
(** Returns the list of elements of the vector *)
|
||||
|
||||
val to_array : 'a t -> 'a array
|
||||
|
||||
val of_list : 'a list -> 'a t
|
||||
|
||||
val to_seq : 'a t -> 'a Iter.t
|
||||
|
||||
val clear : 'a t -> unit
|
||||
(** Set size to 0, doesn't free elements *)
|
||||
|
||||
val shrink : 'a t -> int -> unit
|
||||
(** [shrink vec sz] resets size of [vec] to [sz].
|
||||
Assumes [sz >=0 && sz <= size vec] *)
|
||||
|
||||
val pop : 'a t -> 'a
|
||||
(** Pop last element and return it.
|
||||
@raise Invalid_argument if the vector is empty *)
|
||||
|
||||
val size : 'a t -> int
|
||||
|
||||
val is_empty : 'a t -> bool
|
||||
|
||||
val is_full : 'a t -> bool
|
||||
(** Is the capacity of the vector equal to the number of its elements? *)
|
||||
|
||||
val push : 'a t -> 'a -> unit
|
||||
(** Push element into the vector *)
|
||||
|
||||
val get : 'a t -> int -> 'a
|
||||
(** get the element at the given index, or
|
||||
@raise Invalid_argument if the index is not valid *)
|
||||
|
||||
val set : 'a t -> int -> 'a -> unit
|
||||
(** set the element at the given index, either already set or the first
|
||||
free slot if [not (is_full vec)], or
|
||||
@raise Invalid_argument if the index is not valid *)
|
||||
|
||||
val copy : 'a t -> 'a t
|
||||
(** Fresh copy *)
|
||||
|
||||
val fast_remove : 'a t -> int -> unit
|
||||
(** Remove element at index [i] without preserving order
|
||||
(swap with last element) *)
|
||||
|
||||
val filter_in_place : ('a -> bool) -> 'a t -> unit
|
||||
(** [filter_in_place f v] removes from [v] the elements that do
|
||||
not satisfy [f] *)
|
||||
|
||||
val sort : 'a t -> ('a -> 'a -> int) -> unit
|
||||
(** Sort in place the array *)
|
||||
|
||||
val iter : ('a -> unit) -> 'a t -> unit
|
||||
(** Iterate on elements *)
|
||||
|
||||
val iteri : (int -> 'a -> unit) -> 'a t -> unit
|
||||
(** Iterate on elements with their index *)
|
||||
|
||||
val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
|
||||
(** Fold over elements *)
|
||||
|
||||
val exists : ('a -> bool) -> 'a t -> bool
|
||||
(** Does there exist an element that satisfies the predicate? *)
|
||||
|
||||
val for_all : ('a -> bool) -> 'a t -> bool
|
||||
(** Do all elements satisfy the predicate? *)
|
||||
|
||||
val pp :
|
||||
?sep:string ->
|
||||
(Format.formatter -> 'a -> unit) ->
|
||||
Format.formatter -> 'a t -> unit
|
||||
10
src/sat/src/core/dune
Normal file
10
src/sat/src/core/dune
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
|
||||
(library
|
||||
(name msat)
|
||||
(public_name msat)
|
||||
(libraries iter)
|
||||
(synopsis "core data structures and algorithms for msat")
|
||||
(flags :standard -warn-error -3 -w +a-4-42-44-48-50-58-32-60@8 -color always -safe-string)
|
||||
(ocamlopt_flags :standard -O3 -bin-annot
|
||||
-unbox-closures -unbox-closures-factor 20)
|
||||
)
|
||||
92
src/sat/src/core/msat.mld
Normal file
92
src/sat/src/core/msat.mld
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
{1 mSAT}
|
||||
|
||||
{2 License}
|
||||
|
||||
This code is free, under the {{:https://github.com/Gbury/mSAT/blob/master/LICENSE}Apache 2.0 license}.
|
||||
|
||||
{2 Contents}
|
||||
|
||||
mSAT is an ocaml library providing SAT/SMT/McSat solvers. More precisely,
|
||||
what mSAT provides are functors to easily create such solvers. Indeed, the core
|
||||
of a sat solver does not need much information about either the exact representation
|
||||
of terms or the inner workings of a theory.
|
||||
|
||||
Most modules in mSAT actually define functors. These functors usually take one
|
||||
or two arguments, usually an implementation of Terms and formulas used, and an implementation
|
||||
of the theory used during solving.
|
||||
|
||||
{4 Solver creation}
|
||||
|
||||
The following modules allow to easily create a SAT or SMT solver (remark: a SAT solver is
|
||||
simply an SMT solver with an empty theory).
|
||||
|
||||
{!modules:
|
||||
Msat
|
||||
}
|
||||
|
||||
The following modules allow the creation of a McSat solver (Model Constructing solver):
|
||||
|
||||
{!modules:
|
||||
Msat_mcsolver
|
||||
}
|
||||
|
||||
{4 Useful tools}
|
||||
|
||||
An instanciation of a pure sat solver is also provided:
|
||||
|
||||
{!modules:
|
||||
Msat_sat
|
||||
}
|
||||
|
||||
Lastly, mSAT also provides an implementation of Tseitin's CNF conversion:
|
||||
|
||||
{!modules:
|
||||
Msat_tseitin
|
||||
}
|
||||
|
||||
{4 Proof Management}
|
||||
|
||||
mSAT solvers are able to provide detailed proofs when an unsat state is reached. To do
|
||||
so, it require the provided theory to give proofs of the tautologies it gives the solver.
|
||||
These proofs will be called lemmas. The type of lemmas is defined by the theory and can
|
||||
very well be [unit].
|
||||
|
||||
In this context a proof is a resolution tree, whose conclusion (i.e. root) is the
|
||||
empty clause, effectively allowing to deduce [false] from the hypotheses.
|
||||
A resolution tree is a binary tree whose nodes are clauses. Inner nodes' clauses are
|
||||
obtained by performing resolution between the two clauses of the children nodes, while
|
||||
leafs of the tree are either hypotheses, or tautologies (i.e. conflicts returned by
|
||||
the theory).
|
||||
|
||||
{!modules:
|
||||
Msat__Res
|
||||
Msat__Res_intf
|
||||
}
|
||||
|
||||
Backends for exporting proofs to different formats:
|
||||
|
||||
{!modules:
|
||||
Dot
|
||||
Coq
|
||||
Dedukti
|
||||
Backend_intf
|
||||
}
|
||||
|
||||
{4 Internal modules}
|
||||
|
||||
WARNING: for advanced users only ! These modules expose a lot of unsafe functions
|
||||
that must be used with care to not break the required invariants. Additionally, these
|
||||
interfaces are not part of the main API and so are subject to a lot more breaking changes
|
||||
than the safe modules above.
|
||||
|
||||
{!modules:
|
||||
Dimacs
|
||||
Internal
|
||||
External
|
||||
Solver_types
|
||||
Solver_types_intf
|
||||
}
|
||||
|
||||
{2 Index}
|
||||
|
||||
{!indexlist}
|
||||
4
src/sat/src/dune
Normal file
4
src/sat/src/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
|
||||
(documentation
|
||||
(package msat)
|
||||
(mld_files :standard))
|
||||
121
src/sat/src/index.mld
Normal file
121
src/sat/src/index.mld
Normal file
|
|
@ -0,0 +1,121 @@
|
|||
|
||||
|
||||
{1 mSAT: a Modular SAT Solver}
|
||||
|
||||
(The entry point of this library is the module: {!module-Msat}.)
|
||||
|
||||
A modular implementation of the SMT algorithm can be found in the {!Msat.Solver} module,
|
||||
as a functor which takes two modules :
|
||||
|
||||
- A representation of formulas (which implements the `Formula_intf.S` signature)
|
||||
|
||||
- A theory (which implements the `Theory_intf.S` signature) to check consistence of assertions.
|
||||
|
||||
- A dummy empty module to ensure generativity of the solver (solver modules heavily relies on
|
||||
side effects to their internal state)
|
||||
|
||||
{3 Sat Solver}
|
||||
|
||||
A ready-to-use SAT solver is available in the {!Msat_sat} module
|
||||
using the [msat.sat] library (see {!module-Msat_sat}). It can be loaded
|
||||
as shown in the following code :
|
||||
|
||||
{[
|
||||
# #require "msat";;
|
||||
# #require "msat.sat";;
|
||||
# #print_depth 0;; (* do not print details *)
|
||||
]}
|
||||
|
||||
Then we can create a solver and create some boolean variables:
|
||||
|
||||
{[
|
||||
module Sat = Msat_sat
|
||||
module E = Sat.Int_lit (* expressions *)
|
||||
|
||||
let solver = Sat.create()
|
||||
|
||||
(* We create here two distinct atoms *)
|
||||
let a = E.fresh () (* A 'new_atom' is always distinct from any other atom *)
|
||||
let b = E.make 1 (* Atoms can be created from integers *)
|
||||
]}
|
||||
|
||||
We can try and check the satisfiability of some clauses — here, the clause [a or b].
|
||||
[Sat.assume] adds a list of clauses to the solver. Calling [Sat.solve]
|
||||
will check the satisfiability of the current set of clauses, here "Sat".
|
||||
|
||||
{[
|
||||
# a <> b;;
|
||||
- : bool = true
|
||||
# Sat.assume solver [[a; b]] ();;
|
||||
- : unit = ()
|
||||
# let res = Sat.solve solver;;
|
||||
val res : Sat.res = Sat.Sat ...
|
||||
]}
|
||||
|
||||
The Sat solver has an incremental mutable state, so we still have
|
||||
the clause `a or b` in our assumptions.
|
||||
We add `not a` and `not b` to the state, and get "Unsat".
|
||||
|
||||
{[
|
||||
# Sat.assume solver [[E.neg a]; [E.neg b]] () ;;
|
||||
- : unit = ()
|
||||
# let res = Sat.solve solver ;;
|
||||
val res : Sat.res = Sat.Unsat ...
|
||||
]}
|
||||
|
||||
{3 Formulas API}
|
||||
|
||||
Writing clauses by hand can be tedious and error-prone.
|
||||
The functor {!Msat_tseitin.Make} in the library [msat.tseitin] (see {!module-Msat_tseitin}).
|
||||
proposes a formula AST (parametrized by
|
||||
atoms) and a function to convert these formulas into clauses:
|
||||
|
||||
{[
|
||||
# #require "msat.tseitin";;
|
||||
]}
|
||||
|
||||
{[
|
||||
(* Module initialization *)
|
||||
module F = Msat_tseitin.Make(E)
|
||||
|
||||
let solver = Sat.create ()
|
||||
|
||||
(* We create here two distinct atoms *)
|
||||
let a = E.fresh () (* A fresh atom is always distinct from any other atom *)
|
||||
let b = E.make 1 (* Atoms can be created from integers *)
|
||||
|
||||
(* Let's create some formulas *)
|
||||
let p = F.make_atom a
|
||||
let q = F.make_atom b
|
||||
let r = F.make_and [p; q]
|
||||
let s = F.make_or [F.make_not p; F.make_not q]
|
||||
]}
|
||||
|
||||
We can try and check the satisfiability of the given formulas, by turning
|
||||
it into clauses using `make_cnf`:
|
||||
|
||||
{[
|
||||
# Sat.assume solver (F.make_cnf r) ();;
|
||||
- : unit = ()
|
||||
# Sat.solve solver;;
|
||||
- : Sat.res = Sat.Sat ...
|
||||
]}
|
||||
|
||||
{[
|
||||
# Sat.assume solver (F.make_cnf s) ();;
|
||||
- : unit = ()
|
||||
# Sat.solve solver ;;
|
||||
- : Sat.res = Sat.Unsat ...
|
||||
]}
|
||||
|
||||
{3 Backtracking utils}
|
||||
|
||||
The library {!module-Msat_backtrack} contains some backtrackable
|
||||
data structures that are useful for implementing theories.
|
||||
|
||||
{3 Library msat.backend}
|
||||
|
||||
This is used for proof backends:
|
||||
|
||||
The entry point of this library is the module:
|
||||
{!module-Msat_backend}.
|
||||
20
src/sat/src/main/Dimacs_lex.mll
Normal file
20
src/sat/src/main/Dimacs_lex.mll
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
{
|
||||
open Dimacs_parse
|
||||
}
|
||||
|
||||
let number = ['1' - '9'] ['0' - '9']*
|
||||
|
||||
rule token = parse
|
||||
| eof { EOF }
|
||||
| "c" { comment lexbuf }
|
||||
| [' ' '\t' '\r'] { token lexbuf }
|
||||
| 'p' { P }
|
||||
| "cnf" { CNF }
|
||||
| '\n' { Lexing.new_line lexbuf; token lexbuf }
|
||||
| '0' { ZERO }
|
||||
| '-'? number { LIT (int_of_string (Lexing.lexeme lexbuf)) }
|
||||
| _ { failwith @@ Printf.sprintf "dimacs.lexer: unexpected char `%s`" (Lexing.lexeme lexbuf) }
|
||||
|
||||
and comment = parse
|
||||
| '\n' { Lexing.new_line lexbuf; token lexbuf }
|
||||
| [^'\n'] { comment lexbuf }
|
||||
34
src/sat/src/main/Dimacs_parse.mly
Normal file
34
src/sat/src/main/Dimacs_parse.mly
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
/* Copyright 2005 INRIA */
|
||||
|
||||
%{
|
||||
let lnum pos = pos.Lexing.pos_lnum
|
||||
let cnum pos = pos.Lexing.pos_cnum - pos.Lexing.pos_bol
|
||||
let pp_pos out (start,stop) =
|
||||
Format.fprintf out "(at %d:%d - %d:%d)"
|
||||
(lnum start) (cnum start) (lnum stop) (cnum stop)
|
||||
%}
|
||||
|
||||
%token <int> LIT
|
||||
%token ZERO
|
||||
%token P CNF EOF
|
||||
|
||||
%start file
|
||||
%type <int list list> file
|
||||
|
||||
%%
|
||||
|
||||
/* DIMACS syntax */
|
||||
|
||||
prelude:
|
||||
| P CNF LIT LIT { () }
|
||||
|
||||
clauses:
|
||||
| { [] }
|
||||
| clause clauses { $1 :: $2 }
|
||||
|
||||
file:
|
||||
| prelude clauses EOF { $2 }
|
||||
|
||||
clause:
|
||||
| ZERO { [] }
|
||||
| LIT clause { $1 :: $2 }
|
||||
14
src/sat/src/main/dune
Normal file
14
src/sat/src/main/dune
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
; main binary
|
||||
(executable
|
||||
(name main)
|
||||
(public_name msat)
|
||||
(package msat-bin)
|
||||
(libraries containers camlzip msat msat.sat msat.backend)
|
||||
(flags :standard -warn-error -3 -w +a-4-42-44-48-50-58-32-60@8 -color always -safe-string -open Msat)
|
||||
(ocamlopt_flags :standard -O3 -color always
|
||||
-unbox-closures -unbox-closures-factor 20)
|
||||
)
|
||||
|
||||
(ocamlyacc (modules Dimacs_parse))
|
||||
(ocamllex (modules Dimacs_lex))
|
||||
186
src/sat/src/main/main.ml
Normal file
186
src/sat/src/main/main.ml
Normal file
|
|
@ -0,0 +1,186 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
|
||||
exception Incorrect_model
|
||||
exception Out_of_time
|
||||
exception Out_of_space
|
||||
|
||||
let file = ref ""
|
||||
let p_cnf = ref false
|
||||
let p_check = ref false
|
||||
let p_dot_proof = ref ""
|
||||
let p_proof_print = ref false
|
||||
let time_limit = ref 300.
|
||||
let size_limit = ref 1000_000_000.
|
||||
let no_proof = ref false
|
||||
|
||||
module S = Msat_sat
|
||||
|
||||
module Process() = struct
|
||||
module D = Msat_backend.Dot.Make(S)(Msat_backend.Dot.Default(S))
|
||||
|
||||
let hyps = ref []
|
||||
|
||||
let st = S.create ~store_proof:(not !no_proof) ~size:`Big ()
|
||||
|
||||
let check_model sat =
|
||||
let check_clause c =
|
||||
let l = List.map (function a ->
|
||||
Log.debugf 99
|
||||
(fun k -> k "Checking value of %a" S.Formula.pp a);
|
||||
sat.Msat.eval a) c in
|
||||
List.exists (fun x -> x) l
|
||||
in
|
||||
let l = List.map check_clause !hyps in
|
||||
List.for_all (fun x -> x) l
|
||||
|
||||
let prove ~assumptions () =
|
||||
let res = S.solve ~assumptions st in
|
||||
let t = Sys.time () in
|
||||
begin match res with
|
||||
| S.Sat state ->
|
||||
if !p_check then
|
||||
if not (check_model state) then
|
||||
raise Incorrect_model;
|
||||
let t' = Sys.time () -. t in
|
||||
Format.printf "Sat (%f/%f)@." t t'
|
||||
| S.Unsat state ->
|
||||
if !p_check then (
|
||||
let p = state.Msat.get_proof () in
|
||||
S.Proof.check_empty_conclusion p;
|
||||
S.Proof.check p;
|
||||
if !p_dot_proof <> "" then (
|
||||
let oc = open_out !p_dot_proof in
|
||||
let fmt = Format.formatter_of_out_channel oc in
|
||||
Format.fprintf fmt "%a@?" D.pp p;
|
||||
flush oc; close_out_noerr oc;
|
||||
)
|
||||
);
|
||||
let t' = Sys.time () -. t in
|
||||
Format.printf "Unsat (%f/%f)@." t t'
|
||||
end
|
||||
|
||||
let conv_c c = List.rev_map S.Int_lit.make c
|
||||
|
||||
let add_clauses cs =
|
||||
S.assume st (CCList.map conv_c cs) ()
|
||||
end[@@inline]
|
||||
|
||||
let parse_file f =
|
||||
let module L = Lexing in
|
||||
CCIO.with_in f
|
||||
(fun ic ->
|
||||
let buf =
|
||||
if CCString.suffix ~suf:".gz" f
|
||||
then (
|
||||
let gic = Gzip.open_in_chan ic in
|
||||
L.from_function (fun bytes len -> Gzip.input gic bytes 0 len)
|
||||
) else L.from_channel ic
|
||||
in
|
||||
buf.L.lex_curr_p <- {buf.L.lex_curr_p with L.pos_fname=f;};
|
||||
Dimacs_parse.file Dimacs_lex.token buf)
|
||||
|
||||
let error_msg opt arg l =
|
||||
Format.fprintf Format.str_formatter "'%s' is not a valid argument for '%s', valid arguments are : %a"
|
||||
arg opt (fun fmt -> List.iter (fun (s, _) -> Format.fprintf fmt "%s, " s)) l;
|
||||
Format.flush_str_formatter ()
|
||||
|
||||
(* Arguments parsing *)
|
||||
let int_arg r arg =
|
||||
let l = String.length arg in
|
||||
let multiplier m =
|
||||
let arg1 = String.sub arg 0 (l-1) in
|
||||
r := m *. (float_of_string arg1)
|
||||
in
|
||||
if l = 0 then raise (Arg.Bad "bad numeric argument")
|
||||
else
|
||||
try
|
||||
match arg.[l-1] with
|
||||
| 'k' -> multiplier 1e3
|
||||
| 'M' -> multiplier 1e6
|
||||
| 'G' -> multiplier 1e9
|
||||
| 'T' -> multiplier 1e12
|
||||
| 's' -> multiplier 1.
|
||||
| 'm' -> multiplier 60.
|
||||
| 'h' -> multiplier 3600.
|
||||
| 'd' -> multiplier 86400.
|
||||
| '0'..'9' -> r := float_of_string arg
|
||||
| _ -> raise (Arg.Bad "bad numeric argument")
|
||||
with Failure _ -> raise (Arg.Bad "bad numeric argument")
|
||||
|
||||
let setup_gc_stat () =
|
||||
at_exit (fun () ->
|
||||
Gc.print_stat stdout;
|
||||
)
|
||||
|
||||
let input_file = fun s -> file := s
|
||||
|
||||
let usage = "Usage : main [options] <file>"
|
||||
let argspec = Arg.align [
|
||||
"-bt", Arg.Unit (fun () -> Printexc.record_backtrace true),
|
||||
" Enable stack traces";
|
||||
"-cnf", Arg.Set p_cnf,
|
||||
" Prints the cnf used.";
|
||||
"-check", Arg.Set p_check,
|
||||
" Build, check and print the proof (if output is set), if unsat";
|
||||
"-dot", Arg.Set_string p_dot_proof,
|
||||
" If provided, print the dot proof in the given file";
|
||||
"-gc", Arg.Unit setup_gc_stat,
|
||||
" Outputs statistics about the GC";
|
||||
"-size", Arg.String (int_arg size_limit),
|
||||
"<s>[kMGT] Sets the size limit for the sat solver";
|
||||
"-time", Arg.String (int_arg time_limit),
|
||||
"<t>[smhd] Sets the time limit for the sat solver";
|
||||
"-v", Arg.Int (fun i -> Log.set_debug i),
|
||||
"<lvl> Sets the debug verbose level";
|
||||
"-no-proof", Arg.Set no_proof, " disable proof logging";
|
||||
]
|
||||
|
||||
(* Limits alarm *)
|
||||
let check () =
|
||||
let t = Sys.time () in
|
||||
let heap_size = (Gc.quick_stat ()).Gc.heap_words in
|
||||
let s = float heap_size *. float Sys.word_size /. 8. in
|
||||
if t > !time_limit then
|
||||
raise Out_of_time
|
||||
else if s > !size_limit then
|
||||
raise Out_of_space
|
||||
|
||||
let main () =
|
||||
(* Administrative duties *)
|
||||
Arg.parse argspec input_file usage;
|
||||
if !file = "" then (
|
||||
Arg.usage argspec usage;
|
||||
exit 2
|
||||
);
|
||||
let al = Gc.create_alarm check in
|
||||
|
||||
let module P = Process() in
|
||||
|
||||
(* Interesting stuff happening *)
|
||||
let clauses = parse_file !file in
|
||||
P.add_clauses clauses;
|
||||
P.prove ~assumptions:[] ();
|
||||
Gc.delete_alarm al;
|
||||
()
|
||||
|
||||
let () =
|
||||
try
|
||||
main ()
|
||||
with
|
||||
| Out_of_time ->
|
||||
Format.printf "Timeout@.";
|
||||
exit 2
|
||||
| Out_of_space ->
|
||||
Format.printf "Spaceout@.";
|
||||
exit 3
|
||||
| Incorrect_model ->
|
||||
Format.printf "Internal error : incorrect *sat* model@.";
|
||||
exit 4
|
||||
| S.Proof.Resolution_error msg ->
|
||||
Format.printf "Internal error: incorrect *unsat* proof:\n%s@." msg;
|
||||
exit 5
|
||||
|
||||
66
src/sat/src/sat/Int_lit.ml
Normal file
66
src/sat/src/sat/Int_lit.ml
Normal file
|
|
@ -0,0 +1,66 @@
|
|||
|
||||
exception Bad_atom
|
||||
(** Exception raised if an atom cannot be created *)
|
||||
|
||||
type t = int
|
||||
(** Atoms are represented as integers. [-i] begin the negation of [i].
|
||||
Additionally, since we nee dot be able to create fresh atoms, we
|
||||
use even integers for user-created atoms, and odd integers for the
|
||||
fresh atoms. *)
|
||||
|
||||
let max_lit = max_int
|
||||
|
||||
(* Counters *)
|
||||
let max_index = ref 0
|
||||
let max_fresh = ref (-1)
|
||||
|
||||
(** Internal function for creating atoms.
|
||||
Updates the internal counters *)
|
||||
let _make i =
|
||||
if i <> 0 && (abs i) < max_lit then begin
|
||||
max_index := max !max_index (abs i);
|
||||
i
|
||||
end else
|
||||
raise Bad_atom
|
||||
|
||||
let to_int i = i
|
||||
|
||||
(** *)
|
||||
let neg a = - a
|
||||
|
||||
let norm a =
|
||||
abs a, if a < 0 then
|
||||
Solver_intf.Negated
|
||||
else
|
||||
Solver_intf.Same_sign
|
||||
|
||||
let abs = abs
|
||||
|
||||
let sign i = i > 0
|
||||
|
||||
let apply_sign b i = if b then i else neg i
|
||||
|
||||
let set_sign b i = if b then abs i else neg (abs i)
|
||||
|
||||
let hash (a:int) = a land max_int
|
||||
let equal (a:int) b = a=b
|
||||
let compare (a:int) b = compare a b
|
||||
|
||||
let make i = _make (2 * i)
|
||||
|
||||
let fresh () =
|
||||
incr max_fresh;
|
||||
_make (2 * !max_fresh + 1)
|
||||
|
||||
(*
|
||||
let iter: (t -> unit) -> unit = fun f ->
|
||||
for j = 1 to !max_index do
|
||||
f j
|
||||
done
|
||||
*)
|
||||
|
||||
let pp fmt a =
|
||||
Format.fprintf fmt "%s%s%d"
|
||||
(if a < 0 then "~" else "")
|
||||
(if a mod 2 = 0 then "v" else "f")
|
||||
((abs a) / 2)
|
||||
33
src/sat/src/sat/Int_lit.mli
Normal file
33
src/sat/src/sat/Int_lit.mli
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
|
||||
(** {1 The module defining formulas} *)
|
||||
|
||||
(** SAT Formulas
|
||||
|
||||
This modules implements formuals adequate for use in a pure SAT Solver.
|
||||
Atomic formuals are represented using integers, that should allow
|
||||
near optimal efficiency (both in terms of space and time).
|
||||
*)
|
||||
|
||||
include Solver_intf.FORMULA
|
||||
(** This modules implements the requirements for implementing an SAT Solver. *)
|
||||
|
||||
val make : int -> t
|
||||
(** Make a proposition from an integer. *)
|
||||
|
||||
val to_int : t -> int
|
||||
|
||||
val fresh : unit -> t
|
||||
(** Make a fresh atom *)
|
||||
|
||||
val compare : t -> t -> int
|
||||
(** Compare atoms *)
|
||||
|
||||
val sign : t -> bool
|
||||
(** Is the given atom positive ? *)
|
||||
|
||||
val apply_sign : bool -> t -> t
|
||||
(** [apply_sign b] is the identity if [b] is [true], and the negation
|
||||
function if [b] is [false]. *)
|
||||
|
||||
val set_sign : bool -> t -> t
|
||||
(** Return the atom with the sign set. *)
|
||||
11
src/sat/src/sat/Msat_sat.ml
Normal file
11
src/sat/src/sat/Msat_sat.ml
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2016 Guillaume Bury
|
||||
*)
|
||||
|
||||
module Int_lit = Int_lit
|
||||
include Msat.Make_pure_sat(struct
|
||||
module Formula = Int_lit
|
||||
type proof = unit
|
||||
end)
|
||||
|
||||
19
src/sat/src/sat/Msat_sat.mli
Normal file
19
src/sat/src/sat/Msat_sat.mli
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2016 Guillaume Bury
|
||||
*)
|
||||
|
||||
(** Sat solver
|
||||
|
||||
This modules instanciates a pure sat solver using integers to represent
|
||||
atomic propositions.
|
||||
*)
|
||||
|
||||
module Int_lit = Int_lit
|
||||
|
||||
include Msat.S
|
||||
with type Formula.t = Int_lit.t
|
||||
and type theory = unit
|
||||
and type lemma = unit
|
||||
(** A functor that can generate as many solvers as needed. *)
|
||||
|
||||
11
src/sat/src/sat/dune
Normal file
11
src/sat/src/sat/dune
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(library
|
||||
(name msat_sat)
|
||||
(public_name msat.sat)
|
||||
(synopsis "purely boolean interface to Msat")
|
||||
(libraries msat)
|
||||
(flags :standard -warn-error -3 -w +a-4-42-44-48-50-58-32-60@8 -color always -safe-string -open Msat)
|
||||
(ocamlopt_flags :standard -O3 -color always
|
||||
-unbox-closures -unbox-closures-factor 20)
|
||||
)
|
||||
|
||||
9
src/sat/src/sudoku/dune
Normal file
9
src/sat/src/sudoku/dune
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(executable
|
||||
(name sudoku_solve)
|
||||
(modes native)
|
||||
(libraries msat msat.backtrack iter containers)
|
||||
(flags :standard -warn-error -a -w +a-4-42-44-48-50-58-32-60@8 -color always -safe-string)
|
||||
(ocamlopt_flags :standard -O3 -bin-annot
|
||||
-unbox-closures -unbox-closures-factor 20)
|
||||
)
|
||||
331
src/sat/src/sudoku/sudoku_solve.ml
Normal file
331
src/sat/src/sudoku/sudoku_solve.ml
Normal file
|
|
@ -0,0 +1,331 @@
|
|||
|
||||
(** {1 simple sudoku solver} *)
|
||||
|
||||
module Fmt = CCFormat
|
||||
module Log = Msat.Log
|
||||
module Vec = Msat.Vec
|
||||
|
||||
let errorf msg = CCFormat.kasprintf failwith msg
|
||||
|
||||
module Cell : sig
|
||||
type t = private int
|
||||
val equal : t -> t -> bool
|
||||
val neq : t -> t -> bool
|
||||
val hash : t -> int
|
||||
val empty : t
|
||||
val is_empty : t -> bool
|
||||
val is_full : t -> bool
|
||||
val make : int -> t
|
||||
val pp : t Fmt.printer
|
||||
end = struct
|
||||
type t = int
|
||||
let empty = 0
|
||||
let[@inline] make i = assert (i >= 0 && i <= 9); i
|
||||
let[@inline] is_empty x = x = 0
|
||||
let[@inline] is_full x = x > 0
|
||||
let hash = CCHash.int
|
||||
let[@inline] equal (a:t) b = a=b
|
||||
let[@inline] neq (a:t) b = a<>b
|
||||
let pp out i = if i=0 then Fmt.char out '.' else Fmt.int out i
|
||||
end
|
||||
|
||||
module Grid : sig
|
||||
type t
|
||||
|
||||
val get : t -> int -> int -> Cell.t
|
||||
val set : t -> int -> int -> Cell.t -> t
|
||||
|
||||
(** A set of related cells *)
|
||||
type set = (int*int*Cell.t) Iter.t
|
||||
|
||||
val rows : t -> set Iter.t
|
||||
val cols : t -> set Iter.t
|
||||
val squares : t -> set Iter.t
|
||||
|
||||
val all_cells : t -> (int*int*Cell.t) Iter.t
|
||||
|
||||
val parse : string -> t
|
||||
val is_full : t -> bool
|
||||
val is_valid : t -> bool
|
||||
val matches : pat:t -> t -> bool
|
||||
val pp : t Fmt.printer
|
||||
end = struct
|
||||
type t = Cell.t array
|
||||
|
||||
let[@inline] get (s:t) i j = s.(i*9 + j)
|
||||
|
||||
let[@inline] set (s:t) i j n =
|
||||
let s' = Array.copy s in
|
||||
s'.(i*9 + j) <- n;
|
||||
s'
|
||||
|
||||
(** A set of related cells *)
|
||||
type set = (int*int*Cell.t) Iter.t
|
||||
|
||||
open Iter.Infix
|
||||
|
||||
let all_cells (g:t) =
|
||||
0 -- 8 >>= fun i ->
|
||||
0 -- 8 >|= fun j -> (i,j,get g i j)
|
||||
|
||||
let rows (g:t) =
|
||||
0 -- 8 >|= fun i ->
|
||||
( 0 -- 8 >|= fun j -> (i,j,get g i j))
|
||||
|
||||
let cols g =
|
||||
0 -- 8 >|= fun j ->
|
||||
( 0 -- 8 >|= fun i -> (i,j,get g i j))
|
||||
|
||||
let squares g =
|
||||
0 -- 2 >>= fun sq_i ->
|
||||
0 -- 2 >|= fun sq_j ->
|
||||
( 0 -- 2 >>= fun off_i ->
|
||||
0 -- 2 >|= fun off_j ->
|
||||
let i = 3*sq_i + off_i in
|
||||
let j = 3*sq_j + off_j in
|
||||
(i,j,get g i j))
|
||||
|
||||
let is_full g = Array.for_all Cell.is_full g
|
||||
|
||||
let is_valid g =
|
||||
let all_distinct (s:set) =
|
||||
(s >|= fun (_,_,c) -> c)
|
||||
|> Iter.diagonal
|
||||
|> Iter.for_all (fun (c1,c2) -> Cell.neq c1 c2)
|
||||
in
|
||||
Iter.for_all all_distinct @@ rows g &&
|
||||
Iter.for_all all_distinct @@ cols g &&
|
||||
Iter.for_all all_distinct @@ squares g
|
||||
|
||||
let matches ~pat:g1 g2 : bool =
|
||||
all_cells g1
|
||||
|> Iter.filter (fun (_,_,c) -> Cell.is_full c)
|
||||
|> Iter.for_all (fun (x,y,c) -> Cell.equal c @@ get g2 x y)
|
||||
|
||||
let pp out g =
|
||||
Fmt.fprintf out "@[<v>";
|
||||
Array.iteri
|
||||
(fun i n ->
|
||||
Cell.pp out n;
|
||||
if i mod 9 = 8 then Fmt.fprintf out "@,")
|
||||
g;
|
||||
Fmt.fprintf out "@]"
|
||||
|
||||
let parse (s:string) : t =
|
||||
if String.length s < 81 then (
|
||||
errorf "line is too short, expected 81 chars, not %d" (String.length s);
|
||||
);
|
||||
let a = Array.make 81 Cell.empty in
|
||||
for i = 0 to 80 do
|
||||
let c = String.get s i in
|
||||
let n = if c = '.' then 0 else Char.code c - Char.code '0' in
|
||||
if n < 0 || n > 9 then errorf "invalid char %c" c;
|
||||
a.(i) <- Cell.make n
|
||||
done;
|
||||
a
|
||||
end
|
||||
|
||||
module B_ref = Msat_backtrack.Ref
|
||||
|
||||
module Solver : sig
|
||||
type t
|
||||
val create : Grid.t -> t
|
||||
val solve : t -> Grid.t option
|
||||
end = struct
|
||||
open Msat.Solver_intf
|
||||
|
||||
(* formulas *)
|
||||
module F = struct
|
||||
type t = bool*int*int*Cell.t
|
||||
let equal (sign1,x1,y1,c1)(sign2,x2,y2,c2) =
|
||||
sign1=sign2 && x1=x2 && y1=y2 && Cell.equal c1 c2
|
||||
let hash (sign,x,y,c) = CCHash.(combine4 (bool sign)(int x)(int y)(Cell.hash c))
|
||||
let pp out (sign,x,y,c) =
|
||||
Fmt.fprintf out "[@[(%d,%d) %s %a@]]" x y (if sign then "=" else "!=") Cell.pp c
|
||||
let neg (sign,x,y,c) = (not sign,x,y,c)
|
||||
let norm ((sign,_,_,_) as f) =
|
||||
if sign then f, Same_sign else neg f, Negated
|
||||
|
||||
let make sign x y (c:Cell.t) : t = (sign,x,y,c)
|
||||
end
|
||||
|
||||
module Theory = struct
|
||||
type proof = unit
|
||||
module Formula = F
|
||||
type t = {
|
||||
grid: Grid.t B_ref.t;
|
||||
}
|
||||
|
||||
let create g : t = {grid=B_ref.create g}
|
||||
let[@inline] grid self : Grid.t = B_ref.get self.grid
|
||||
let[@inline] set_grid self g : unit = B_ref.set self.grid g
|
||||
|
||||
let push_level self = B_ref.push_level self.grid
|
||||
let pop_levels self n = B_ref.pop_levels self.grid n
|
||||
|
||||
let pp_c_ = Fmt.(list ~sep:(return "@ ∨ ")) F.pp
|
||||
let[@inline] logs_conflict kind c : unit =
|
||||
Log.debugf 4 (fun k->k "(@[conflict.%s@ %a@])" kind pp_c_ c)
|
||||
|
||||
(* check that all cells are full *)
|
||||
let check_full_ (self:t) acts : unit =
|
||||
Grid.all_cells (grid self)
|
||||
(fun (x,y,c) ->
|
||||
if Cell.is_empty c then (
|
||||
let c =
|
||||
CCList.init 9
|
||||
(fun c -> F.make true x y (Cell.make (c+1)))
|
||||
in
|
||||
Log.debugf 4 (fun k->k "(@[add-clause@ %a@])" pp_c_ c);
|
||||
acts.acts_add_clause ~keep:true c ();
|
||||
))
|
||||
|
||||
(* check constraints *)
|
||||
let check_ (self:t) acts : unit =
|
||||
Log.debugf 4 (fun k->k "(@[sudoku.check@ @[:g %a@]@])" Grid.pp (B_ref.get self.grid));
|
||||
let[@inline] all_diff kind f =
|
||||
let pairs =
|
||||
f (grid self)
|
||||
|> Iter.flat_map
|
||||
(fun set ->
|
||||
set
|
||||
|> Iter.filter (fun (_,_,c) -> Cell.is_full c)
|
||||
|> Iter.diagonal)
|
||||
in
|
||||
pairs
|
||||
(fun ((x1,y1,c1),(x2,y2,c2)) ->
|
||||
if Cell.equal c1 c2 then (
|
||||
assert (x1<>x2 || y1<>y2);
|
||||
let c = [F.make false x1 y1 c1; F.make false x2 y2 c2] in
|
||||
logs_conflict ("all-diff." ^ kind) c;
|
||||
acts.acts_raise_conflict c ()
|
||||
))
|
||||
in
|
||||
all_diff "rows" Grid.rows;
|
||||
all_diff "cols" Grid.cols;
|
||||
all_diff "squares" Grid.squares;
|
||||
()
|
||||
|
||||
let trail_ (acts:_ Msat.acts) =
|
||||
acts.acts_iter_assumptions
|
||||
|> Iter.map
|
||||
(function
|
||||
| Assign _ -> assert false
|
||||
| Lit f -> f)
|
||||
|
||||
(* update current grid with the given slice *)
|
||||
let add_slice (self:t) acts : unit =
|
||||
trail_ acts
|
||||
(function
|
||||
| false,_,_,_ -> ()
|
||||
| true,x,y,c ->
|
||||
assert (Cell.is_full c);
|
||||
let grid = grid self in
|
||||
let c' = Grid.get grid x y in
|
||||
if Cell.is_empty c' then (
|
||||
set_grid self (Grid.set grid x y c);
|
||||
) else if Cell.neq c c' then (
|
||||
(* conflict: at most one value *)
|
||||
let c = [F.make false x y c; F.make false x y c'] in
|
||||
logs_conflict "at-most-one" c;
|
||||
acts.acts_raise_conflict c ()
|
||||
)
|
||||
)
|
||||
|
||||
let partial_check (self:t) acts : unit =
|
||||
Log.debugf 4
|
||||
(fun k->k "(@[sudoku.partial-check@ :trail [@[%a@]]@])"
|
||||
(Fmt.list F.pp) (trail_ acts |> Iter.to_list));
|
||||
add_slice self acts;
|
||||
check_ self acts
|
||||
|
||||
let final_check (self:t) acts : unit =
|
||||
Log.debugf 4 (fun k->k "(@[sudoku.final-check@])");
|
||||
check_full_ self acts;
|
||||
check_ self acts
|
||||
|
||||
end
|
||||
|
||||
module S = Msat.Make_cdcl_t(Theory)
|
||||
|
||||
type t = {
|
||||
grid0: Grid.t;
|
||||
solver: S.t;
|
||||
}
|
||||
|
||||
let solve (self:t) : _ option =
|
||||
let assumptions =
|
||||
Grid.all_cells self.grid0
|
||||
|> Iter.filter (fun (_,_,c) -> Cell.is_full c)
|
||||
|> Iter.map (fun (x,y,c) -> F.make true x y c)
|
||||
|> Iter.map (S.make_atom self.solver)
|
||||
|> Iter.to_rev_list
|
||||
in
|
||||
Log.debugf 2
|
||||
(fun k->k "(@[sudoku.solve@ :assumptions %a@])" (Fmt.Dump.list S.Atom.pp) assumptions);
|
||||
let r =
|
||||
match S.solve self.solver ~assumptions with
|
||||
| S.Sat _ -> Some (Theory.grid (S.theory self.solver))
|
||||
| S.Unsat _ -> None
|
||||
in
|
||||
(* TODO: print some stats *)
|
||||
r
|
||||
|
||||
let create g : t =
|
||||
{ solver=S.create ~store_proof:false (Theory.create g); grid0=g }
|
||||
end
|
||||
|
||||
let solve_grid (g:Grid.t) : Grid.t option =
|
||||
let s = Solver.create g in
|
||||
Solver.solve s
|
||||
|
||||
let solve_file file =
|
||||
Format.printf "solve grids in file %S@." file;
|
||||
let start = Sys.time() in
|
||||
let grids =
|
||||
CCIO.with_in file CCIO.read_lines_l
|
||||
|> CCList.filter_map
|
||||
(fun s ->
|
||||
let s = String.trim s in
|
||||
if s="" then None
|
||||
else match Grid.parse s with
|
||||
| g -> Some g
|
||||
| exception e ->
|
||||
errorf "cannot parse sudoku %S: %s@." s (Printexc.to_string e))
|
||||
in
|
||||
Format.printf "parsed %d grids (in %.3fs)@." (List.length grids) (Sys.time()-.start);
|
||||
List.iter
|
||||
(fun g ->
|
||||
Format.printf "@[<v>@,#########################@,@[<2>solve grid:@ %a@]@]@." Grid.pp g;
|
||||
let start=Sys.time() in
|
||||
match solve_grid g with
|
||||
| None -> Format.printf "no solution (in %.3fs)@." (Sys.time()-.start)
|
||||
| Some g' when not @@ Grid.is_full g' ->
|
||||
errorf "grid %a@ is not full" Grid.pp g'
|
||||
| Some g' when not @@ Grid.is_valid g' ->
|
||||
errorf "grid %a@ is not valid" Grid.pp g'
|
||||
| Some g' when not @@ Grid.matches ~pat:g g' ->
|
||||
errorf "grid %a@ @[<2>does not match original@ %a@]" Grid.pp g' Grid.pp g
|
||||
| Some g' ->
|
||||
Format.printf "@[<v>@[<2>solution (in %.3fs):@ %a@]@,###################@]@."
|
||||
(Sys.time()-.start) Grid.pp g')
|
||||
grids;
|
||||
Format.printf "@.solved %d grids (in %.3fs)@." (List.length grids) (Sys.time()-.start);
|
||||
()
|
||||
|
||||
let () =
|
||||
Fmt.set_color_default true;
|
||||
let files = ref [] in
|
||||
let debug = ref 0 in
|
||||
let opts = [
|
||||
"--debug", Arg.Set_int debug, " debug";
|
||||
"-d", Arg.Set_int debug, " debug";
|
||||
] |> Arg.align in
|
||||
Arg.parse opts (fun f -> files := f :: !files) "sudoku_solve [options] <file>";
|
||||
Msat.Log.set_debug !debug;
|
||||
try
|
||||
List.iter (fun f -> solve_file f) !files;
|
||||
with
|
||||
| Failure msg | Invalid_argument msg ->
|
||||
Format.printf "@{<Red>Error@}:@.%s@." msg;
|
||||
exit 1
|
||||
326
src/sat/src/tseitin/Msat_tseitin.ml
Normal file
326
src/sat/src/tseitin/Msat_tseitin.ml
Normal file
|
|
@ -0,0 +1,326 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* Alt-Ergo Zero *)
|
||||
(* *)
|
||||
(* Sylvain Conchon and Alain Mebsout *)
|
||||
(* Universite Paris-Sud 11 *)
|
||||
(* *)
|
||||
(* Copyright 2011. This file is distributed under the terms of the *)
|
||||
(* Apache Software License version 2.0 *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
module type Arg = Tseitin_intf.Arg
|
||||
|
||||
module type S = Tseitin_intf.S
|
||||
|
||||
module Make (F : Tseitin_intf.Arg) = struct
|
||||
|
||||
exception Empty_Or
|
||||
type combinator = And | Or | Imp | Not
|
||||
|
||||
type atom = F.t
|
||||
type t =
|
||||
| True
|
||||
| Lit of atom
|
||||
| Comb of combinator * t list
|
||||
|
||||
let rec pp fmt phi =
|
||||
match phi with
|
||||
| True -> Format.fprintf fmt "true"
|
||||
| Lit a -> F.pp fmt a
|
||||
| Comb (Not, [f]) ->
|
||||
Format.fprintf fmt "not (%a)" pp f
|
||||
| Comb (And, l) -> Format.fprintf fmt "(%a)" (pp_list "and") l
|
||||
| Comb (Or, l) -> Format.fprintf fmt "(%a)" (pp_list "or") l
|
||||
| Comb (Imp, [f1; f2]) ->
|
||||
Format.fprintf fmt "(%a => %a)" pp f1 pp f2
|
||||
| _ -> assert false
|
||||
and pp_list sep fmt = function
|
||||
| [] -> ()
|
||||
| [f] -> pp fmt f
|
||||
| f::l -> Format.fprintf fmt "%a %s %a" pp f sep (pp_list sep) l
|
||||
|
||||
let make comb l = Comb (comb, l)
|
||||
|
||||
let make_atom p = Lit p
|
||||
|
||||
let f_true = True
|
||||
let f_false = Comb(Not, [True])
|
||||
|
||||
let rec flatten comb acc = function
|
||||
| [] -> acc
|
||||
| (Comb (c, l)) :: r when c = comb ->
|
||||
flatten comb (List.rev_append l acc) r
|
||||
| a :: r ->
|
||||
flatten comb (a :: acc) r
|
||||
|
||||
let rec opt_rev_map f acc = function
|
||||
| [] -> acc
|
||||
| a :: r -> begin match f a with
|
||||
| None -> opt_rev_map f acc r
|
||||
| Some b -> opt_rev_map f (b :: acc) r
|
||||
end
|
||||
|
||||
let remove_true l =
|
||||
let aux = function
|
||||
| True -> None
|
||||
| f -> Some f
|
||||
in
|
||||
opt_rev_map aux [] l
|
||||
|
||||
let remove_false l =
|
||||
let aux = function
|
||||
| Comb(Not, [True]) -> None
|
||||
| f -> Some f
|
||||
in
|
||||
opt_rev_map aux [] l
|
||||
|
||||
|
||||
let make_not f = make Not [f]
|
||||
|
||||
let make_and l =
|
||||
let l' = remove_true (flatten And [] l) in
|
||||
if List.exists ((=) f_false) l' then
|
||||
f_false
|
||||
else
|
||||
make And l'
|
||||
|
||||
let make_or l =
|
||||
let l' = remove_false (flatten Or [] l) in
|
||||
if List.exists ((=) f_true) l' then
|
||||
f_true
|
||||
else match l' with
|
||||
| [] -> raise Empty_Or
|
||||
| [a] -> a
|
||||
| _ -> Comb (Or, l')
|
||||
|
||||
let make_imply f1 f2 = make Imp [f1; f2]
|
||||
let make_equiv f1 f2 = make_and [ make_imply f1 f2; make_imply f2 f1]
|
||||
let make_xor f1 f2 = make_or [ make_and [ make_not f1; f2 ];
|
||||
make_and [ f1; make_not f2 ] ]
|
||||
|
||||
(* simplify formula *)
|
||||
let (%%) f g x = f (g x)
|
||||
|
||||
let rec sform f k = match f with
|
||||
| True | Comb (Not, [True]) -> k f
|
||||
| Comb (Not, [Lit a]) -> k (Lit (F.neg a))
|
||||
| Comb (Not, [Comb (Not, [f])]) -> sform f k
|
||||
| Comb (Not, [Comb (Or, l)]) -> sform_list_not [] l (k %% make_and)
|
||||
| Comb (Not, [Comb (And, l)]) -> sform_list_not [] l (k %% make_or)
|
||||
| Comb (And, l) -> sform_list [] l (k %% make_and)
|
||||
| Comb (Or, l) -> sform_list [] l (k %% make_or)
|
||||
| Comb (Imp, [f1; f2]) ->
|
||||
sform (make_not f1) (fun f1' -> sform f2 (fun f2' -> k (make_or [f1'; f2'])))
|
||||
| Comb (Not, [Comb (Imp, [f1; f2])]) ->
|
||||
sform f1 (fun f1' -> sform (make_not f2) (fun f2' -> k (make_and [f1';f2'])))
|
||||
| Comb ((Imp | Not), _) -> assert false
|
||||
| Lit _ -> k f
|
||||
and sform_list acc l k = match l with
|
||||
| [] -> k acc
|
||||
| f :: tail ->
|
||||
sform f (fun f' -> sform_list (f'::acc) tail k)
|
||||
and sform_list_not acc l k = match l with
|
||||
| [] -> k acc
|
||||
| f :: tail ->
|
||||
sform (make_not f) (fun f' -> sform_list_not (f'::acc) tail k)
|
||||
|
||||
let ( @@ ) l1 l2 = List.rev_append l1 l2
|
||||
(* let ( @ ) = `Use_rev_append_instead (* prevent use of non-tailrec append *) *)
|
||||
|
||||
(*
|
||||
let distrib l_and l_or =
|
||||
let l =
|
||||
if l_or = [] then l_and
|
||||
else
|
||||
List.rev_map
|
||||
(fun x ->
|
||||
match x with
|
||||
| Lit _ -> Comb (Or, x::l_or)
|
||||
| Comb (Or, l) -> Comb (Or, l @@ l_or)
|
||||
| _ -> assert false
|
||||
) l_and
|
||||
in
|
||||
Comb (And, l)
|
||||
|
||||
let rec flatten_or = function
|
||||
| [] -> []
|
||||
| Comb (Or, l)::r -> l @@ (flatten_or r)
|
||||
| Lit a :: r -> (Lit a)::(flatten_or r)
|
||||
| _ -> assert false
|
||||
|
||||
let rec flatten_and = function
|
||||
| [] -> []
|
||||
| Comb (And, l)::r -> l @@ (flatten_and r)
|
||||
| a :: r -> a::(flatten_and r)
|
||||
|
||||
|
||||
let rec cnf f =
|
||||
match f with
|
||||
| Comb (Or, l) ->
|
||||
begin
|
||||
let l = List.rev_map cnf l in
|
||||
let l_and, l_or =
|
||||
List.partition (function Comb(And,_) -> true | _ -> false) l in
|
||||
match l_and with
|
||||
| [ Comb(And, l_conj) ] ->
|
||||
let u = flatten_or l_or in
|
||||
distrib l_conj u
|
||||
|
||||
| Comb(And, l_conj) :: r ->
|
||||
let u = flatten_or l_or in
|
||||
cnf (Comb(Or, (distrib l_conj u)::r))
|
||||
|
||||
| _ ->
|
||||
begin
|
||||
match flatten_or l_or with
|
||||
| [] -> assert false
|
||||
| [r] -> r
|
||||
| v -> Comb (Or, v)
|
||||
end
|
||||
end
|
||||
| Comb (And, l) ->
|
||||
Comb (And, List.rev_map cnf l)
|
||||
| f -> f
|
||||
|
||||
let rec mk_cnf = function
|
||||
| Comb (And, l) ->
|
||||
List.fold_left (fun acc f -> (mk_cnf f) @@ acc) [] l
|
||||
|
||||
| Comb (Or, [f1;f2]) ->
|
||||
let ll1 = mk_cnf f1 in
|
||||
let ll2 = mk_cnf f2 in
|
||||
List.fold_left
|
||||
(fun acc l1 -> (List.rev_map (fun l2 -> l1 @@ l2)ll2) @@ acc) [] ll1
|
||||
|
||||
| Comb (Or, f1 :: l) ->
|
||||
let ll1 = mk_cnf f1 in
|
||||
let ll2 = mk_cnf (Comb (Or, l)) in
|
||||
List.fold_left
|
||||
(fun acc l1 -> (List.rev_map (fun l2 -> l1 @@ l2)ll2) @@ acc) [] ll1
|
||||
|
||||
| Lit a -> [[a]]
|
||||
| Comb (Not, [Lit a]) -> [[F.neg a]]
|
||||
| _ -> assert false
|
||||
|
||||
|
||||
let rec unfold mono f =
|
||||
match f with
|
||||
| Lit a -> a::mono
|
||||
| Comb (Not, [Lit a]) ->
|
||||
(F.neg a)::mono
|
||||
| Comb (Or, l) ->
|
||||
List.fold_left unfold mono l
|
||||
| _ -> assert false
|
||||
|
||||
let rec init monos f =
|
||||
match f with
|
||||
| Comb (And, l) ->
|
||||
List.fold_left init monos l
|
||||
| f -> (unfold [] f)::monos
|
||||
|
||||
let make_cnf f =
|
||||
let sfnc = cnf (sform f) in
|
||||
init [] sfnc
|
||||
*)
|
||||
|
||||
let mk_proxy = F.fresh
|
||||
|
||||
let acc_or = ref []
|
||||
let acc_and = ref []
|
||||
|
||||
(* build a clause by flattening (if sub-formulas have the
|
||||
same combinator) and proxy-ing sub-formulas that have the
|
||||
opposite operator. *)
|
||||
let rec cnf f = match f with
|
||||
| Lit a -> None, [a]
|
||||
| Comb (Not, [Lit a]) -> None, [F.neg a]
|
||||
|
||||
| Comb (And, l) ->
|
||||
List.fold_left
|
||||
(fun (_, acc) f ->
|
||||
match cnf f with
|
||||
| _, [] -> assert false
|
||||
| _cmb, [a] -> Some And, a :: acc
|
||||
| Some And, l ->
|
||||
Some And, l @@ acc
|
||||
(* let proxy = mk_proxy () in *)
|
||||
(* acc_and := (proxy, l) :: !acc_and; *)
|
||||
(* proxy :: acc *)
|
||||
| Some Or, l ->
|
||||
let proxy = mk_proxy () in
|
||||
acc_or := (proxy, l) :: !acc_or;
|
||||
Some And, proxy :: acc
|
||||
| None, l -> Some And, l @@ acc
|
||||
| _ -> assert false
|
||||
) (None, []) l
|
||||
|
||||
| Comb (Or, l) ->
|
||||
List.fold_left
|
||||
(fun (_, acc) f ->
|
||||
match cnf f with
|
||||
| _, [] -> assert false
|
||||
| _cmb, [a] -> Some Or, a :: acc
|
||||
| Some Or, l ->
|
||||
Some Or, l @@ acc
|
||||
(* let proxy = mk_proxy () in *)
|
||||
(* acc_or := (proxy, l) :: !acc_or; *)
|
||||
(* proxy :: acc *)
|
||||
| Some And, l ->
|
||||
let proxy = mk_proxy () in
|
||||
acc_and := (proxy, l) :: !acc_and;
|
||||
Some Or, proxy :: acc
|
||||
| None, l -> Some Or, l @@ acc
|
||||
| _ -> assert false
|
||||
) (None, []) l
|
||||
| _ -> assert false
|
||||
|
||||
let cnf f =
|
||||
let acc = match f with
|
||||
| True -> []
|
||||
| Comb(Not, [True]) -> [[]]
|
||||
| Comb (And, l) -> List.rev_map (fun f -> snd(cnf f)) l
|
||||
| _ -> [snd (cnf f)]
|
||||
in
|
||||
let proxies = ref [] in
|
||||
(* encore clauses that make proxies in !acc_and equivalent to
|
||||
their clause *)
|
||||
let acc =
|
||||
List.fold_left
|
||||
(fun acc (p,l) ->
|
||||
proxies := p :: !proxies;
|
||||
let np = F.neg p in
|
||||
(* build clause [cl = l1 & l2 & ... & ln => p] where [l = [l1;l2;..]]
|
||||
also add clauses [p => l1], [p => l2], etc. *)
|
||||
let cl, acc =
|
||||
List.fold_left
|
||||
(fun (cl,acc) a -> (F.neg a :: cl), [np; a] :: acc)
|
||||
([p],acc) l in
|
||||
cl :: acc
|
||||
) acc !acc_and
|
||||
in
|
||||
(* encore clauses that make proxies in !acc_or equivalent to
|
||||
their clause *)
|
||||
let acc =
|
||||
List.fold_left
|
||||
(fun acc (p,l) ->
|
||||
proxies := p :: !proxies;
|
||||
(* add clause [p => l1 | l2 | ... | ln], and add clauses
|
||||
[l1 => p], [l2 => p], etc. *)
|
||||
let acc = List.fold_left (fun acc a -> [p; F.neg a]::acc)
|
||||
acc l in
|
||||
(F.neg p :: l) :: acc
|
||||
) acc !acc_or
|
||||
in
|
||||
acc
|
||||
|
||||
let make_cnf f =
|
||||
acc_or := [];
|
||||
acc_and := [];
|
||||
cnf (sform f (fun f' -> f'))
|
||||
|
||||
(* Naive CNF XXX remove???
|
||||
let make_cnf f = mk_cnf (sform f)
|
||||
*)
|
||||
end
|
||||
22
src/sat/src/tseitin/Msat_tseitin.mli
Normal file
22
src/sat/src/tseitin/Msat_tseitin.mli
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
(*
|
||||
MSAT is free software, using the Apache license, see file LICENSE
|
||||
Copyright 2014 Guillaume Bury
|
||||
Copyright 2014 Simon Cruanes
|
||||
*)
|
||||
|
||||
(** Tseitin CNF conversion
|
||||
|
||||
This modules implements Tseitin's Conjunctive Normal Form conversion, i.e.
|
||||
the ability to transform an arbitrary boolean formula into an equi-satisfiable
|
||||
CNF, that can then be fed to a SAT/SMT/McSat solver.
|
||||
*)
|
||||
|
||||
module type Arg = Tseitin_intf.Arg
|
||||
(** The implementation of formulas required to implement Tseitin's CNF conversion. *)
|
||||
|
||||
module type S = Tseitin_intf.S
|
||||
(** The exposed interface of Tseitin's CNF conversion. *)
|
||||
|
||||
module Make : functor (F : Arg) -> S with type atom = F.t
|
||||
(** This functor provides an implementation of Tseitin's CNF conversion. *)
|
||||
|
||||
85
src/sat/src/tseitin/Tseitin_intf.ml
Normal file
85
src/sat/src/tseitin/Tseitin_intf.ml
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* Alt-Ergo Zero *)
|
||||
(* *)
|
||||
(* Sylvain Conchon and Alain Mebsout *)
|
||||
(* Universite Paris-Sud 11 *)
|
||||
(* *)
|
||||
(* Copyright 2011. This file is distributed under the terms of the *)
|
||||
(* Apache Software License version 2.0 *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
(** Interfaces for Tseitin's CNF conversion *)
|
||||
|
||||
module type Arg = sig
|
||||
(** Formulas
|
||||
|
||||
This defines what is needed of formulas in order to implement
|
||||
Tseitin's CNF conversion.
|
||||
*)
|
||||
|
||||
type t
|
||||
(** Type of atomic formulas. *)
|
||||
|
||||
val neg : t -> t
|
||||
(** Negation of atomic formulas. *)
|
||||
|
||||
val fresh : unit -> t
|
||||
(** Generate fresh formulas (that are different from any other). *)
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
(** Print the given formula. *)
|
||||
|
||||
end
|
||||
|
||||
module type S = sig
|
||||
(** CNF conversion
|
||||
|
||||
This modules converts arbitrary boolean formulas into CNF.
|
||||
*)
|
||||
|
||||
type atom
|
||||
(** The type of atomic formulas. *)
|
||||
|
||||
type t
|
||||
(** The type of arbitrary boolean formulas. Arbitrary boolean formulas
|
||||
can be built using functions in this module, and then converted
|
||||
to a CNF, which is a list of clauses that only use atomic formulas. *)
|
||||
|
||||
val f_true : t
|
||||
(** The [true] formula, i.e a formula that is always satisfied. *)
|
||||
|
||||
val f_false : t
|
||||
(** The [false] formula, i.e a formula that cannot be satisfied. *)
|
||||
|
||||
val make_atom : atom -> t
|
||||
(** [make_atom p] builds the boolean formula equivalent to the atomic formula [p]. *)
|
||||
|
||||
val make_not : t -> t
|
||||
(** Creates the negation of a boolean formula. *)
|
||||
|
||||
val make_and : t list -> t
|
||||
(** Creates the conjunction of a list of formulas. An empty conjunction is always satisfied. *)
|
||||
|
||||
val make_or : t list -> t
|
||||
(** Creates the disjunction of a list of formulas. An empty disjunction is never satisfied. *)
|
||||
|
||||
val make_xor : t -> t -> t
|
||||
(** [make_xor p q] creates the boolean formula "[p] xor [q]". *)
|
||||
|
||||
val make_imply : t -> t -> t
|
||||
(** [make_imply p q] creates the boolean formula "[p] implies [q]". *)
|
||||
|
||||
val make_equiv : t -> t -> t
|
||||
(** [make_equiv p q] creates the boolena formula "[p] is equivalent to [q]". *)
|
||||
|
||||
val make_cnf : t -> atom list list
|
||||
(** [make_cnf f] returns a conjunctive normal form of [f] under the form: a
|
||||
list (which is a conjunction) of lists (which are disjunctions) of
|
||||
atomic formulas. *)
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
(** [print fmt f] prints the formula on the formatter [fmt].*)
|
||||
|
||||
end
|
||||
11
src/sat/src/tseitin/dune
Normal file
11
src/sat/src/tseitin/dune
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(library
|
||||
(name msat_tseitin)
|
||||
(public_name msat.tseitin)
|
||||
(synopsis "Tseitin transformation for msat")
|
||||
(libraries msat)
|
||||
(flags :standard -w +a-4-42-44-48-50-58-32-60@8 -color always -safe-string)
|
||||
(ocamlopt_flags :standard -O3 -bin-annot
|
||||
-unbox-closures -unbox-closures-factor 20)
|
||||
)
|
||||
|
||||
Loading…
Add table
Reference in a new issue