├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject ├── src ├── cvc4Solver.ml ├── polyaSolver.ml ├── smtTactic.mllib ├── solver.ml ├── solver.mli ├── tactic.ml4 └── z3Solver.ml ├── test-suite ├── Makefile ├── Test.v └── _CoqProject └── theories └── Tactic.v /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.vo 3 | *.v.d 4 | *.glob 5 | *.cmi 6 | *.cmo 7 | *.cmx 8 | *.cmxs 9 | *.ml4.d 10 | *.o 11 | Makefile.coq 12 | Makefile.coq.bak 13 | *.aux 14 | *.ml.d 15 | *.mli.d 16 | .merlin 17 | *.a 18 | *.cma 19 | *.cmxa 20 | *.mllib.d -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Gregory Malecha 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: coq clean 2 | 3 | coq: Makefile.coq 4 | $(MAKE) -f Makefile.coq 5 | 6 | Makefile.coq: Makefile $(MODULES) 7 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 8 | 9 | install: Makefile.coq 10 | $(MAKE) -f Makefile.coq install 11 | 12 | uninstall: Makefile.coq 13 | $(MAKE) -f Makefile.coq uninstall 14 | 15 | clean:: Makefile.coq 16 | $(MAKE) -f Makefile.coq clean 17 | rm -f Makefile.coq 18 | 19 | tests: coq 20 | make -C test-suite 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | coq-smt-check 2 | ============= 3 | 4 | This is a simple way to invoke an SMT solver on Coq goals. 5 | It does *NOT* generate proof objects. It is meant purely for sanity checking 6 | goals. 7 | 8 | The main tactic is 'smt solve' which invokes an smt on the current goal. The 9 | core of the plugin is the conversion from Coq to SMT2 format. At the moment, 10 | the conversion handles the following: 11 | 12 | - boolean connectives, /\, \/, not 13 | - equality 14 | - variables 15 | - real numbers, +, -, /, constants 16 | 17 | If your problem fits in this fragment (it can contain other facts as well), then 18 | you can run: 19 | 20 | smt solve. 21 | 22 | If the solver solves the goal then the tactic will succeed. If the solver 23 | returns an unsat core then the tactic will act like 24 | 25 | clear - . 26 | 27 | otherwise it will simply act like idtac (doing nothing to the goal). 28 | If the solver fails to solve the goal then the tactic will fail and 29 | display the sat model if the solver returns one. A common way to use 30 | the tactic is something like the following: 31 | 32 | smt solve; admit. 33 | 34 | which will admit the goal only if it is solved by the SMT solver. 35 | 36 | You can also specify the solver to use in the tactic using the syntax: 37 | 38 | smt solve calling "". 39 | 40 | Where `' is, e.g. z3 or cvc4. 41 | 42 | See the test-suite directory for examples. 43 | 44 | Solvers 45 | ------- 46 | 47 | Currently, the code supports Z3 and CVC4. You need to set the solver using 48 | 49 | Set SMT Solver "z3". 50 | 51 | or 52 | 53 | Set SMT Solver "cvc4". 54 | 55 | You can toggle debugging globally using: 56 | 57 | Set SMT Debug. 58 | Unset SMT Debug. 59 | 60 | Implementing Your Own Solver 61 | ---------------------------- 62 | 63 | You can implement your own solver interface using a Coq Plugin. At the high 64 | level, you should call: 65 | 66 | SmtTactic.register_smt_solver : -> ( -> ) -> unit 67 | 68 | and then set up the solver appropriately. Note that solver names can *NOT* 69 | contain colons (:). The string passed will be split on the first colon (if 70 | one exists) and the rest of the string will be passed as `options` above. 71 | 72 | Install from OPAM 73 | ----------------- 74 | Make sure you added the [Coq repository](coq.io/opam/): 75 | 76 | opam repo add coq-released https://coq.inria.fr/opam/released 77 | 78 | and run: 79 | 80 | opam install coq-smt-check 81 | 82 | Contributors 83 | ------------ 84 | 85 | This plugin was started by Vignesh Gowada at UCSD as part of the [VeriDrone](http://veridrone.ucsd.edu/) project. It was updated and is currently maintained by Gregory Malecha. 86 | 87 | External contributions are always welcome. 88 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -I src 2 | -Q theories SMTC 3 | 4 | -I $(COQLIB)/user-contrib/PluginUtils/ 5 | 6 | src/tactic.ml4 7 | src/solver.mli 8 | src/solver.ml 9 | src/z3Solver.ml 10 | src/cvc4Solver.ml 11 | src/polyaSolver.ml 12 | src/smtTactic.mllib 13 | 14 | theories/Tactic.v 15 | -------------------------------------------------------------------------------- /src/cvc4Solver.ml: -------------------------------------------------------------------------------- 1 | open Solver 2 | 3 | module CVC4Exec : (Exec with type instance = RealInstance.instance) = 4 | struct 5 | open RealInstance 6 | 7 | type instance = RealInstance.instance 8 | 9 | let ptrn_success = Str.regexp "^unsat" 10 | let ptrn_failure = Str.regexp "^sat" 11 | let ptrn_unknown = Str.regexp "^unknown" 12 | let ptrn_split = Str.regexp " " 13 | 14 | let ptrn_def = Str.regexp "(define-fun \\(\\w+\\) () Real[ \n\r\t]+(?\\(-? [0-9]*.[0-9]*\\))?)" 15 | 16 | let extract_model debug inst = 17 | let rec extract_model start result = 18 | debug (fun _ -> Pp.(str "extract model: " ++ fnl () ++ 19 | str (String.sub result start (String.length result - start)) ++ fnl ())) ; 20 | try 21 | let _ = Str.search_forward ptrn_def result start in 22 | let var = RealInstance.get_variable (Str.matched_group 1 result) inst in 23 | let value = Str.matched_group 2 result in 24 | (var, value) :: extract_model (Str.match_end ()) result 25 | with 26 | Not_found -> [] 27 | in extract_model 28 | 29 | let filter_map f = 30 | let rec filter_map = function 31 | [] -> [] 32 | | x :: xs -> 33 | match f x with 34 | None -> filter_map xs 35 | | Some x -> x :: filter_map xs 36 | in filter_map 37 | 38 | let parse_result debug inst result = 39 | let _ = 40 | debug (fun _ -> Pp.(str "CVC4 output" ++ fnl () ++ str result)) 41 | in 42 | let result = Str.global_replace (Str.regexp (Str.quote "\n")) " " result in 43 | let result = Str.global_replace (Str.regexp (Str.quote "\r")) "" result in 44 | if Str.string_partial_match ptrn_success result 0 then 45 | Unsat None 46 | else if Str.string_match ptrn_failure result 0 then 47 | Sat [] 48 | else if Str.string_match ptrn_unknown result 0 then 49 | Unknown 50 | else 51 | let _ = Format.eprintf "Bad CVC4 output:\n%s" result in 52 | assert false 53 | 54 | let execute ~debug inst = 55 | let (in_channel,out_channel) = Unix.open_process "cvc4 --lang smt -" in 56 | let _ = 57 | begin 58 | let fmt = Format.formatter_of_out_channel out_channel in 59 | Format.fprintf fmt "(set-option :produce-models true)\n" ; 60 | Format.fprintf fmt "(set-logic AUFLIRA)\n" ; 61 | RealInstance.write_instance fmt inst ; 62 | Format.fprintf fmt "(check-sat)" ; 63 | Format.pp_print_flush fmt () ; 64 | flush out_channel ; 65 | close_out out_channel 66 | end 67 | in 68 | let buffer_size = 2048 in 69 | let buffer = Buffer.create buffer_size in 70 | let string = String.create buffer_size in 71 | let chars_read = ref 1 in 72 | while !chars_read <> 0 do 73 | chars_read := input in_channel string 0 buffer_size; 74 | Buffer.add_substring buffer string 0 !chars_read 75 | done; 76 | ignore (Unix.close_process (in_channel, out_channel)); 77 | let result = Buffer.contents buffer in 78 | parse_result debug inst result 79 | 80 | end 81 | 82 | module CVC4RealSolver = Solver.Make (Solver.RealInstance) (CVC4Exec) ;; 83 | 84 | Tactic.SmtTactic.register_smt_solver "cvc4" (fun _ -> CVC4RealSolver.solve) 85 | -------------------------------------------------------------------------------- /src/polyaSolver.ml: -------------------------------------------------------------------------------- 1 | open Solver 2 | 3 | module PolyaExec : (Exec with type instance = RealInstance.instance) = 4 | struct 5 | open RealInstance 6 | 7 | type instance = RealInstance.instance 8 | 9 | let ptrn_success = Str.regexp "^unsat" 10 | let ptrn_failure = Str.regexp "^sat" 11 | let ptrn_unknown = Str.regexp "^unknown" 12 | let ptrn_split = Str.regexp " " 13 | 14 | let ptrn_def = Str.regexp "(define-fun \\(\\w+\\) () Real[ \n\r\t]+(?\\(-? [0-9]*.[0-9]*\\))?)" 15 | 16 | let extract_model debug inst = 17 | let rec extract_model start result = 18 | debug (fun _ -> Pp.(str "extract model: " ++ fnl () ++ 19 | str (String.sub result start (String.length result - start)) ++ fnl ())) ; 20 | try 21 | let _ = Str.search_forward ptrn_def result start in 22 | let var = RealInstance.get_variable (Str.matched_group 1 result) inst in 23 | let value = Str.matched_group 2 result in 24 | (var, value) :: extract_model (Str.match_end ()) result 25 | with 26 | Not_found -> [] 27 | in extract_model 28 | 29 | let filter_map f = 30 | let rec filter_map = function 31 | [] -> [] 32 | | x :: xs -> 33 | match f x with 34 | None -> filter_map xs 35 | | Some x -> x :: filter_map xs 36 | in filter_map 37 | 38 | let parse_result debug inst result = 39 | let _ = 40 | debug (fun _ -> Pp.(str "Polya output" ++ fnl () ++ str result)) 41 | in 42 | let result = Str.global_replace (Str.regexp (Str.quote "\n")) " " result in 43 | let result = Str.global_replace (Str.regexp (Str.quote "\r")) "" result in 44 | if Str.string_partial_match ptrn_success result 0 then 45 | Unsat None 46 | else if Str.string_match ptrn_failure result 0 then 47 | Sat [] 48 | else if Str.string_match ptrn_unknown result 0 then 49 | Unknown 50 | else 51 | let _ = Format.eprintf "Bad Polya output:\n%s" result in 52 | assert false 53 | 54 | let execute ~debug inst = 55 | let (in_channel,out_channel) = Unix.open_process "polya STDIN" in 56 | let _ = 57 | begin 58 | let fmt = Format.formatter_of_out_channel out_channel in 59 | RealInstance.write_instance fmt inst ; 60 | Format.fprintf fmt "(check-sat)" ; 61 | Format.pp_print_flush fmt () ; 62 | flush out_channel ; 63 | close_out out_channel 64 | end 65 | in 66 | let buffer_size = 2048 in 67 | let buffer = Buffer.create buffer_size in 68 | let string = String.create buffer_size in 69 | let chars_read = ref 1 in 70 | while !chars_read <> 0 do 71 | chars_read := input in_channel string 0 buffer_size; 72 | Buffer.add_substring buffer string 0 !chars_read 73 | done; 74 | ignore (Unix.close_process (in_channel, out_channel)); 75 | let result = Buffer.contents buffer in 76 | parse_result debug inst result 77 | 78 | end 79 | 80 | module PolyaRealSolver = Solver.Make (Solver.RealInstance) (PolyaExec) ;; 81 | 82 | Tactic.SmtTactic.register_smt_solver "polya" (fun _ -> PolyaRealSolver.solve) 83 | -------------------------------------------------------------------------------- /src/smtTactic.mllib: -------------------------------------------------------------------------------- 1 | Solver 2 | Tactic 3 | Z3Solver 4 | Cvc4Solver -------------------------------------------------------------------------------- /src/solver.ml: -------------------------------------------------------------------------------- 1 | open Plugin_utils 2 | 3 | module type Solver = 4 | sig 5 | val solve : debug:bool -> verbose:bool -> unit Proofview.tactic 6 | end 7 | 8 | module type Instance = 9 | sig 10 | type instance 11 | 12 | val parse_conclusion : Environ.env -> Evd.evar_map -> 13 | Term.constr -> instance 14 | 15 | val parse_hypothesis : Environ.env -> Evd.evar_map -> 16 | Names.Id.t -> Term.constr -> instance -> instance 17 | 18 | val write_instance : ?pretty:bool -> Format.formatter -> instance -> unit 19 | 20 | val get_variable : string -> instance -> Term.constr 21 | 22 | (* Returning [None] means the conclusion *) 23 | val get_hypothesis : string -> instance -> Names.identifier option 24 | end 25 | 26 | module ParseOnlyProp (P : Instance) : 27 | (Instance with type instance = P.instance) = 28 | struct 29 | type instance = P.instance 30 | 31 | let is_a_prop env evm t = 32 | let (_,ty) = Typing.type_of env evm t in 33 | Term.eq_constr ty Term.mkProp 34 | 35 | let parse_conclusion env evm c = 36 | if is_a_prop env evm c then 37 | P.parse_conclusion env evm c 38 | else 39 | raise (Failure "Conclusion is not a proposition") 40 | 41 | let parse_hypothesis env evm name typ i = 42 | if is_a_prop env evm typ then 43 | P.parse_hypothesis env evm name typ i 44 | else i 45 | 46 | let write_instance = P.write_instance 47 | let get_variable = P.get_variable 48 | let get_hypothesis = P.get_hypothesis 49 | end 50 | 51 | type smt_result = 52 | Sat of (Term.constr * string) list 53 | | Unsat of (bool * Names.identifier list) option (* the core *) 54 | | Unknown 55 | 56 | module type Exec = 57 | sig 58 | type instance 59 | 60 | val execute : debug:((unit -> Pp.std_ppcmds) -> unit) -> instance -> smt_result 61 | end 62 | 63 | module Make 64 | (Inst : Instance) 65 | (Exec : Exec with type instance = Inst.instance) : Solver = 66 | struct 67 | open Inst 68 | open Exec 69 | 70 | let parse_instance env evm hyps concl = 71 | let res = Inst.parse_conclusion env evm concl in 72 | List.fold_left (fun acc (name, _decl, typ) -> 73 | Inst.parse_hypothesis env evm name typ acc) res hyps 74 | 75 | module Std = Coqstd.Std 76 | (struct 77 | let contrib_name = "smt-check-real-instance" 78 | end) 79 | 80 | let false_type : Term.constr Lazy.t = 81 | Std.resolve_symbol ["Coq";"Init";"Logic"] "False" 82 | 83 | let pr_model env evm = 84 | Pp.pr_vertical_list 85 | (fun (var,value) -> 86 | Pp.(Printer.pr_constr_env env evm var ++ 87 | spc () ++ str "=" ++ spc () ++ str value)) 88 | 89 | let solve ~debug ~verbose = 90 | Proofview.Goal.nf_enter begin fun gl -> 91 | let goal = Proofview.Goal.concl gl in 92 | let hyps = Proofview.Goal.hyps gl in 93 | let env = Proofview.Goal.env gl in 94 | let evm = Proofview.Goal.sigma gl in 95 | let debug = 96 | if debug then (fun x -> Pp.msg_debug (x ())) 97 | else fun _ -> () 98 | in 99 | 100 | try 101 | let inst = parse_instance env evm hyps goal in 102 | match Exec.execute debug inst with 103 | Sat model when verbose -> 104 | let msg = 105 | Pp.( str "solver failed to solve the goal." 106 | ++ fnl () 107 | ++ pr_model env evm model) 108 | in 109 | Tacticals.New.tclFAIL 0 msg 110 | | Sat _ -> 111 | Tacticals.New.tclFAIL 0 Pp.(str "Satisfiable") 112 | | Unsat (Some (need_concl, core)) -> 113 | let open Proofview.Monad in 114 | (if not need_concl 115 | then Tactics.elim_type (Lazy.force false_type) 116 | else Proofview.tclUNIT ()) >> 117 | (Tactics.keep core) 118 | | Unsat None -> 119 | Tacticals.New.tclIDTAC 120 | | Unknown -> 121 | Tacticals.New.tclFAIL 0 Pp.(str "solver returned unkown") 122 | with 123 | Failure msg -> 124 | Tacticals.New.tclFAIL 0 Pp.(str "failed to parse the goal") 125 | end 126 | 127 | end 128 | 129 | 130 | module RealInstance : Instance = 131 | struct 132 | 133 | module Std = Coqstd.Std 134 | (struct 135 | let contrib_name = "smt-check-real-instance" 136 | end) 137 | 138 | let r_pkg = ["Coq";"Reals";"Rdefinitions"] 139 | let logic_pkg = ["Coq";"Init";"Logic"] 140 | 141 | let c_R = Std.resolve_symbol r_pkg "R" 142 | let c_0 = Std.resolve_symbol r_pkg "R0" 143 | let c_1 = Std.resolve_symbol r_pkg "R1" 144 | let c_Rplus = Std.resolve_symbol r_pkg "Rplus" 145 | let c_Rminus = Std.resolve_symbol r_pkg "Rminus" 146 | let c_Rdiv = Std.resolve_symbol r_pkg "Rdiv" 147 | let c_Rmult = Std.resolve_symbol r_pkg "Rmult" 148 | let c_Ropp = Std.resolve_symbol r_pkg "Ropp" 149 | let c_Rinv = Std.resolve_symbol r_pkg "Rinv" 150 | 151 | let c_Rlt = Std.resolve_symbol r_pkg "Rlt" 152 | let c_Rle = Std.resolve_symbol r_pkg "Rle" 153 | let c_Rgt = Std.resolve_symbol r_pkg "Rgt" 154 | let c_Rge = Std.resolve_symbol r_pkg "Rge" 155 | 156 | let c_and = Std.resolve_symbol logic_pkg "and" 157 | let c_or = Std.resolve_symbol logic_pkg "or" 158 | let c_True = Std.resolve_symbol logic_pkg "True" 159 | let c_False = Std.resolve_symbol logic_pkg "False" 160 | let c_Not = Std.resolve_symbol logic_pkg "not" 161 | let c_eq = Std.resolve_symbol logic_pkg "eq" 162 | let c_Prop = Term.mkProp 163 | 164 | module ConstrOrd = 165 | struct 166 | type t = Term.constr 167 | let compare = Term.constr_ord 168 | end 169 | 170 | module Cmap = Map.Make (ConstrOrd) 171 | 172 | type r_type = Prop | R 173 | 174 | type r_expr = 175 | RConst of float 176 | | Rplus of r_expr * r_expr 177 | | Rminus of r_expr * r_expr 178 | | Rmult of r_expr * r_expr 179 | | Rdiv of r_expr * r_expr 180 | | Ropp of r_expr 181 | | Rinv of r_expr 182 | | Ropaque of int 183 | 184 | type r_prop = 185 | | Rtrue 186 | | Rfalse 187 | | Rlt of r_expr * r_expr 188 | | Rle of r_expr * r_expr 189 | | Rgt of r_expr * r_expr 190 | | Rge of r_expr * r_expr 191 | | Req of r_expr * r_expr 192 | | Rand of r_prop * r_prop 193 | | Ror of r_prop * r_prop 194 | | Rimpl of r_prop * r_prop 195 | | Rnot of r_prop 196 | | Popaque of int 197 | 198 | type instance = 199 | { vars : (int * r_type) Cmap.t 200 | ; assertions : (Names.identifier * r_prop) list 201 | ; concl : r_prop } 202 | 203 | let get_opaque x t i = 204 | try fst (Cmap.find x i), i 205 | with 206 | Not_found -> 207 | let nxt = Cmap.cardinal i in 208 | nxt, (Cmap.add x (nxt, t) i) 209 | 210 | 211 | let parse_uop recur constr op = 212 | (Term_match.apps (Term_match.Glob constr) 213 | [Term_match.get 0], 214 | fun tbl bindings -> 215 | let (res,tbl) = recur tbl (Hashtbl.find bindings 0) in 216 | (op res, tbl)) 217 | 218 | let parse_bop recur constr op = 219 | (Term_match.apps (Term_match.Glob constr) 220 | [Term_match.get 0;Term_match.get 1], 221 | fun tbl bindings -> 222 | let (l,tbl) = recur tbl (Hashtbl.find bindings 0) in 223 | let (r,tbl) = recur tbl (Hashtbl.find bindings 1) in 224 | (op l r, tbl)) 225 | 226 | let rec parse_expr tbl = 227 | Term_match.matches tbl 228 | [ (Term_match.Glob c_0, fun tbl _ -> (RConst 0., tbl)) 229 | ; (Term_match.Glob c_1, fun tbl _ -> (RConst 1., tbl)) 230 | ; parse_bop parse_expr c_Rplus (fun a b -> Rplus (a,b)) 231 | ; parse_bop parse_expr c_Rminus (fun a b -> Rminus (a,b)) 232 | ; parse_bop parse_expr c_Rmult (fun a b -> Rmult (a,b)) 233 | ; parse_bop parse_expr c_Rdiv (fun a b -> Rdiv (a,b)) 234 | ; parse_uop parse_expr c_Ropp (fun a -> Ropp a) 235 | ; parse_uop parse_expr c_Rinv (fun a -> Rinv a) 236 | ; (Term_match.get 0, 237 | fun tbl binders -> 238 | let trm = Hashtbl.find binders 0 in 239 | try 240 | (Ropaque (fst (Cmap.find trm tbl)), tbl) 241 | with 242 | Not_found -> 243 | let nxt = Cmap.cardinal tbl in 244 | (Ropaque nxt, Cmap.add trm (nxt,R) tbl)) 245 | ] 246 | 247 | let rec parse_prop tbl = 248 | Term_match.matches tbl 249 | [ parse_bop parse_expr c_Rlt (fun a b -> Rlt (a,b)) 250 | ; parse_bop parse_expr c_Rle (fun a b -> Rle (a,b)) 251 | ; parse_bop parse_expr c_Rgt (fun a b -> Rgt (a,b)) 252 | ; parse_bop parse_expr c_Rge (fun a b -> Rge (a,b)) 253 | ; (Term_match.apps (Term_match.Glob c_eq) 254 | [Term_match.Glob c_R; 255 | Term_match.get 0; 256 | Term_match.get 1], 257 | fun tbl bindings -> 258 | let (l,tbl) = parse_expr tbl (Hashtbl.find bindings 0) in 259 | let (r,tbl) = parse_expr tbl (Hashtbl.find bindings 1) in 260 | (Req (l, r), tbl)) 261 | ; parse_bop parse_prop c_and (fun a b -> Rand (a,b)) 262 | ; parse_bop parse_prop c_or (fun a b -> Ror (a,b)) 263 | ; (Term_match.apps (Term_match.Glob c_Not) 264 | [Term_match.get 0], fun tbl bindings -> 265 | let (l,tbl) = parse_prop tbl (Hashtbl.find bindings 0) in 266 | (Rnot l, tbl)) 267 | ; (Term_match.Glob c_True, fun tbl _ -> (Rtrue, tbl)) 268 | ; (Term_match.Glob c_False, fun tbl _ -> (Rfalse, tbl)) 269 | ; (Term_match.get 0, 270 | fun tbl binders -> 271 | let trm = Hashtbl.find binders 0 in 272 | let (o,tbl) = get_opaque trm Prop tbl in 273 | (Popaque o, tbl)) 274 | ] 275 | 276 | let parse_hypothesis _ _ name typ i = 277 | let (h,vs) = parse_prop i.vars typ in 278 | { i with vars = vs ; assertions = (name, h) :: i.assertions } 279 | 280 | let parse_conclusion _ _ x = 281 | let (c,vs) = parse_prop Cmap.empty x in 282 | { vars = vs ; assertions = [] ; concl = c } 283 | 284 | (** Printing **) 285 | let rec print_r_expr out e = 286 | match e with 287 | RConst f -> Format.fprintf out "%f" f 288 | | Rplus (l,r) -> Format.fprintf out "(+ %a %a)" print_r_expr l print_r_expr r 289 | | Rminus (l,r) -> Format.fprintf out "(- %a %a)" print_r_expr l print_r_expr r 290 | | Rmult (l,r) -> Format.fprintf out "(* %a %a)" print_r_expr l print_r_expr r 291 | | Rdiv (l,r) -> Format.fprintf out "(/ %a %a)" print_r_expr l print_r_expr r 292 | | Ropp l -> Format.fprintf out "(- 0 %a)" print_r_expr l 293 | | Rinv l -> Format.fprintf out "(/ 1 %a)" print_r_expr l 294 | | Ropaque l -> Format.fprintf out "x%d" l 295 | 296 | let rec print_r_prop out e = 297 | match e with 298 | Rtrue -> Format.fprintf out "true" 299 | | Rfalse -> Format.fprintf out "false" 300 | | Rnot l -> Format.fprintf out "(not %a)" print_r_prop l 301 | | Popaque x -> Format.fprintf out "x%d" x 302 | | Rand (l,r) -> Format.fprintf out "(and %a %a)" print_r_prop l print_r_prop r 303 | | Ror (l,r) -> Format.fprintf out "(or %a %a)" print_r_prop l print_r_prop r 304 | | Rimpl (l,r) -> Format.fprintf out "(=> %a %a)" print_r_prop l print_r_prop r 305 | | Rle (l,r) -> Format.fprintf out "(<= %a %a)" print_r_expr l print_r_expr r 306 | | Rlt (l,r) -> Format.fprintf out "(< %a %a)" print_r_expr l print_r_expr r 307 | | Rge (l,r) -> Format.fprintf out "(>= %a %a)" print_r_expr l print_r_expr r 308 | | Rgt (l,r) -> Format.fprintf out "(> %a %a)" print_r_expr l print_r_expr r 309 | | Req (l,r) -> Format.fprintf out "(= %a %a)" print_r_expr l print_r_expr r 310 | 311 | 312 | let print_identifier out id = 313 | Format.fprintf out "%s" (Names.string_of_id id) 314 | 315 | let print_named_assert pr_id out (nm,e) = 316 | Format.fprintf out "(assert (! %a :named %a))" print_r_prop e pr_id nm 317 | 318 | let print_type out t = 319 | match t with 320 | Prop -> Format.fprintf out "Bool" 321 | | R -> Format.fprintf out "Real" 322 | 323 | let pr_list sep pr = 324 | let rec pr_list out ls = 325 | match ls with 326 | [] -> () 327 | | [l] -> Format.fprintf out "%a" pr l 328 | | l :: ls -> Format.fprintf out "%a%s%a" pr l sep pr_list ls 329 | in 330 | pr_list 331 | 332 | let pr_decls out = 333 | Cmap.iter (fun _ (k,v) -> 334 | Format.fprintf out "(declare-const x%d %a)" k print_type v) 335 | 336 | let print_a_string out s = 337 | Format.fprintf out "%s" s 338 | 339 | let conclusion_name = "__CONCLUSION__" 340 | 341 | let write_instance ?pretty:(pretty=false) out inst = 342 | let sep = if pretty then "\n" else "" in 343 | Format.fprintf out "%a%a%s%a" 344 | pr_decls inst.vars 345 | (pr_list sep (print_named_assert print_identifier)) inst.assertions 346 | sep 347 | (print_named_assert print_a_string) (conclusion_name, Rnot inst.concl) 348 | 349 | let get_variable x inst = 350 | assert (String.length x > 1) ; 351 | let x = 352 | let rest = String.sub x 1 (String.length x - 1) in 353 | int_of_string rest 354 | in 355 | match 356 | Cmap.fold (fun k (var, _) acc -> 357 | if var = x then Some k else acc) 358 | inst.vars None 359 | with 360 | None -> raise Not_found 361 | | Some x -> x 362 | 363 | let get_hypothesis x inst = 364 | if x = conclusion_name then None 365 | else Some (Names.id_of_string x) 366 | 367 | end 368 | -------------------------------------------------------------------------------- /src/solver.mli: -------------------------------------------------------------------------------- 1 | module type Solver = 2 | sig 3 | val solve : debug:bool -> verbose:bool -> unit Proofview.tactic 4 | end 5 | 6 | 7 | module type Instance = 8 | sig 9 | type instance 10 | 11 | val parse_conclusion : Environ.env -> Evd.evar_map -> 12 | Term.constr -> instance 13 | 14 | val parse_hypothesis : Environ.env -> Evd.evar_map -> 15 | Names.Id.t -> Term.constr -> instance -> instance 16 | 17 | val write_instance : ?pretty:bool -> Format.formatter -> instance -> unit 18 | 19 | val get_variable : string -> instance -> Term.constr 20 | 21 | (* Returning [None] means the conclusion *) 22 | val get_hypothesis : string -> instance -> Names.identifier option 23 | end 24 | 25 | module ParseOnlyProp (I : Instance) : Instance with type instance = I.instance 26 | 27 | type smt_result = 28 | Sat of (Term.constr * string) list 29 | | Unsat of (bool * Names.identifier list) option (* the core *) 30 | | Unknown 31 | 32 | module type Exec = 33 | sig 34 | type instance 35 | 36 | val execute : debug:((unit -> Pp.std_ppcmds) -> unit) -> instance -> smt_result 37 | end 38 | 39 | module Make 40 | (Parse : Instance) 41 | (Exec : Exec with type instance = Parse.instance) : Solver 42 | 43 | module RealInstance : Instance 44 | -------------------------------------------------------------------------------- /src/tactic.ml4: -------------------------------------------------------------------------------- 1 | open Util 2 | open Pp 3 | open Names 4 | 5 | open Evd 6 | open Goal 7 | open Printf 8 | open Unix 9 | open Errors 10 | open Plugin_utils 11 | 12 | DECLARE PLUGIN "smtTactic" 13 | 14 | module SmtTactic 15 | : sig 16 | val smtTactic : ?debug:bool -> ?verbose:bool -> string option -> unit Proofview.tactic 17 | val register_smt_solver : string -> (string -> debug:bool -> verbose:bool -> unit Proofview.tactic) -> unit 18 | end = 19 | struct 20 | 21 | let contrib_name = "smt-check" 22 | 23 | module Scmp = 24 | struct 25 | type t = string 26 | let compare = String.compare 27 | end 28 | module Smap = Map.Make (Scmp) 29 | 30 | let smt_debug = ref false 31 | 32 | let all_solvers : (string -> debug:bool -> verbose:bool -> unit Proofview.tactic) Smap.t ref = 33 | ref Smap.empty 34 | 35 | let register_smt_solver (name : string) 36 | (solver : string -> debug:bool -> verbose:bool -> unit Proofview.tactic) = 37 | all_solvers := Smap.add name solver !all_solvers 38 | 39 | type smtSolver = 40 | { name : string 41 | ; run : debug:bool -> verbose:bool -> unit Proofview.tactic } 42 | 43 | let the_solver = 44 | ref { name = "" 45 | ; run = fun ~debug ~verbose -> 46 | Tacticals.New.tclFAIL 0 Pp.(str "solver not set") } 47 | 48 | let smt_parser s = 49 | let (name, args) = 50 | try 51 | let split = String.index s ':' in 52 | let first = String.sub s 0 (split - 1) in 53 | let arg = String.sub s split (String.length s - split) in 54 | (first, arg) 55 | with 56 | Not_found -> (s,"") 57 | in 58 | try 59 | let solver = Smap.find name !all_solvers in 60 | { name = 61 | if args = "" then name 62 | else name ^ ": " ^ args 63 | ; run = solver args } 64 | with 65 | Not_found -> 66 | raise (Failure ("Unknown solver: " ^ name)) 67 | 68 | let smt_reader () = !the_solver.name 69 | let smt_setter s = 70 | the_solver := smt_parser s 71 | 72 | let _ = 73 | Goptions.(declare_string_option 74 | { optsync = false 75 | ; optdepr = false 76 | ; optkey = ["SMT"; "Solver"] 77 | ; optname = "set the smt solver for the smt-check plugin to use" 78 | ; optread = smt_reader 79 | ; optwrite = smt_setter }) 80 | 81 | let _ = 82 | Goptions.(declare_bool_option 83 | { optsync = false 84 | ; optdepr = false 85 | ; optkey = ["SMT"; "Debug"] 86 | ; optname = "print debugging output" 87 | ; optread = (fun () -> !smt_debug) 88 | ; optwrite = (:=) smt_debug }) 89 | 90 | (** This is the entry-point to the tactic **) 91 | let smtTactic ?debug ?verbose opt = 92 | let debug = Option.default !smt_debug debug in 93 | let verbose = Option.default false verbose in 94 | match opt with 95 | None -> (!the_solver).run ~debug ~verbose 96 | | Some solver -> 97 | try 98 | (smt_parser solver).run ~debug ~verbose 99 | with 100 | Not_found -> 101 | let msg = Pp.(str "No SMT solver named: " ++ qstring solver) in 102 | Tacticals.New.tclFAIL 1 msg 103 | 104 | end 105 | 106 | (** TODO: Clean this up **) 107 | 108 | TACTIC EXTEND smt_tac_solve 109 | | ["smt" "solve"] -> [SmtTactic.smtTactic ~verbose:true None] 110 | END;; 111 | 112 | TACTIC EXTEND smt_tac_solve_dbg 113 | | ["smt" "solve_dbg"] -> 114 | [SmtTactic.smtTactic ~debug:true ~verbose:true None] 115 | END;; 116 | 117 | TACTIC EXTEND smt_tac_solve_dbg_calling 118 | | ["smt" "solve_dbg" "calling" string(s) ] -> 119 | [SmtTactic.smtTactic ~debug:true ~verbose:true (Some s)] 120 | END;; 121 | 122 | TACTIC EXTEND smt_tac_solve_calling 123 | | ["smt" "solve" "calling" string(s)] -> [SmtTactic.smtTactic ~verbose:true (Some s)] 124 | END;; 125 | -------------------------------------------------------------------------------- /src/z3Solver.ml: -------------------------------------------------------------------------------- 1 | open Solver 2 | 3 | module Z3Exec : (Exec with type instance = RealInstance.instance) = 4 | struct 5 | open RealInstance 6 | 7 | type instance = RealInstance.instance 8 | 9 | let ptrn_success = Str.regexp "^unsat (\\([^)]*\\))" 10 | let ptrn_failure = Str.regexp "^sat ([^)]*) (model\\(.+\\)) ?$" 11 | let ptrn_unknown = Str.regexp "^unknown" 12 | let ptrn_split = Str.regexp " " 13 | 14 | let ptrn_def = 15 | Str.regexp "(define-fun \\([^ ]+\\) () Real[ \r\n]+\\([^)]+\\))" 16 | 17 | let extract_model debug inst start result = 18 | debug (fun _ -> 19 | Pp.(str "extract model: " ++ fnl () ++ 20 | str (String.sub result start (String.length result - start)) ++ fnl ())) ; 21 | let rec extract_model start result = 22 | try 23 | let _ = Str.search_forward ptrn_def result start in 24 | let var = RealInstance.get_variable (Str.matched_group 1 result) inst in 25 | let value = Str.matched_group 2 result in 26 | (var, value) :: extract_model (Str.match_end ()) result 27 | with 28 | Not_found -> [] 29 | in extract_model start result 30 | 31 | let filter_map f = 32 | let rec filter_map = function 33 | [] -> [] 34 | | x :: xs -> 35 | match f x with 36 | None -> filter_map xs 37 | | Some x -> x :: filter_map xs 38 | in filter_map 39 | 40 | let parse_result debug inst result = 41 | let _ = 42 | debug (fun _ -> Pp.(str "Z3 output" ++ fnl () ++ str result)) 43 | in 44 | let result = Str.global_replace (Str.regexp (Str.quote "\n")) " " result in 45 | let result = Str.global_replace (Str.regexp (Str.quote "\r")) "" result in 46 | if Str.string_partial_match ptrn_success result 0 then 47 | let lst = Str.matched_group 1 result in 48 | let names = Str.split ptrn_split lst in 49 | let names = List.map (fun x -> RealInstance.get_hypothesis x inst) names in 50 | Unsat (Some (List.exists (function None -> true | _ -> false) names, 51 | filter_map (fun x -> x) names)) 52 | else if Str.string_match ptrn_failure result 0 then 53 | let result = Str.matched_group 1 result in 54 | Sat (extract_model debug inst 0 result) 55 | else if Str.string_match ptrn_unknown result 0 then 56 | Unknown 57 | else 58 | let _ = Format.eprintf "Bad Z3 output:\n%s" result in 59 | assert false 60 | 61 | let execute ~debug inst = 62 | let (in_channel,out_channel) = Unix.open_process "z3 -in -smt2" in 63 | let _ = 64 | begin 65 | let fmt = Format.formatter_of_out_channel out_channel in 66 | Format.fprintf fmt "(set-option :produce-unsat-cores true)\n" ; 67 | Format.fprintf fmt "(set-option :produce-models true)\n" ; 68 | RealInstance.write_instance fmt inst ; 69 | Format.fprintf fmt "(check-sat)\n(get-unsat-core)\n(get-model)" ; 70 | Format.pp_print_flush fmt () ; 71 | flush out_channel ; 72 | close_out out_channel 73 | end 74 | in 75 | let buffer_size = 2048 in 76 | let buffer = Buffer.create buffer_size in 77 | let string = Bytes.create buffer_size in 78 | let chars_read = ref 1 in 79 | while !chars_read <> 0 do 80 | chars_read := input in_channel string 0 buffer_size; 81 | Buffer.add_substring buffer string 0 !chars_read 82 | done; 83 | ignore (Unix.close_process (in_channel, out_channel)); 84 | let result = Buffer.contents buffer in 85 | parse_result debug inst result 86 | 87 | end 88 | 89 | module Z3RealSolver = Solver.Make (Solver.RealInstance) (Z3Exec) ;; 90 | 91 | Tactic.SmtTactic.register_smt_solver "z3" (fun _ -> Z3RealSolver.solve) 92 | -------------------------------------------------------------------------------- /test-suite/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: coq clean 2 | 3 | coq: Makefile.coq 4 | $(MAKE) -f Makefile.coq 5 | 6 | Makefile.coq: Makefile _CoqProject 7 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 8 | 9 | clean:: Makefile.coq 10 | $(MAKE) -f Makefile.coq clean 11 | rm -f Makefile.coq 12 | -------------------------------------------------------------------------------- /test-suite/Test.v: -------------------------------------------------------------------------------- 1 | Require Import SMTC.Tactic. 2 | Require Import Coq.Strings.String. 3 | Require Import Coq.Reals.Rdefinitions. 4 | Require Import Coq.Reals.RIneq. 5 | 6 | Set SMT Solver "z3". 7 | Set SMT Debug. 8 | 9 | Goal forall A B : Prop, A /\ B -> B. 10 | Proof. 11 | intros. 12 | smt solve. 13 | tauto. 14 | Qed. 15 | 16 | Goal forall A B : Prop, True -> False -> A /\ B. 17 | intros. 18 | smt solve calling "z3". 19 | tauto. 20 | Qed. 21 | 22 | Local Open Scope R_scope. 23 | 24 | Goal forall x : R, x < 0 -> x + x < x. 25 | Proof. 26 | intros. 27 | smt solve. 28 | Abort. 29 | 30 | Goal forall x : R, ~(x = -1). 31 | Proof. 32 | intros. 33 | Fail smt solve. 34 | Abort. 35 | 36 | Goal forall x : R, ~(x = 1). 37 | Proof. 38 | intros. 39 | Fail smt solve. 40 | Abort. -------------------------------------------------------------------------------- /test-suite/_CoqProject: -------------------------------------------------------------------------------- 1 | -I ../src 2 | -Q ../theories SMTC 3 | -R . 4 | 5 | -I $(COQLIB)/user-contrib/PluginUtils/ 6 | 7 | Test.v 8 | -------------------------------------------------------------------------------- /theories/Tactic.v: -------------------------------------------------------------------------------- 1 | Require Coq.Reals.Rdefinitions. 2 | Require Import PluginUtils.PluginUtils. 3 | Declare ML Module "smtTactic". 4 | --------------------------------------------------------------------------------