├── README.md └── code ├── OCaml ├── LICENSE ├── LICENSE.txt ├── Makefile ├── Mk_ml_file ├── Quotexpander.ml ├── atp_interactive.ml ├── bdd.ml ├── combining.ml ├── completion.ml ├── complex.ml ├── cong.ml ├── cooper.ml ├── decidable.ml ├── defcnf.ml ├── dp.ml ├── eqelim.ml ├── equal.ml ├── example.ml ├── fol.ml ├── folderived.ml ├── format.ml ├── formulas.ml ├── full_test.ml ├── geom.ml ├── grobner.ml ├── herbrand.ml ├── init.ml ├── initialization.ml ├── interpolation.ml ├── intro.ml ├── lcf.ml ├── lcffol.ml ├── lcfprop.ml ├── lib.ml ├── limitations.ml ├── make.ml ├── meson.ml ├── order.ml ├── paramodulation.ml ├── prolog.ml ├── prop.ml ├── propexamples.ml ├── qelim.ml ├── real.ml ├── resolution.ml ├── rewrite.ml ├── skolem.ml ├── skolems.ml ├── stal.ml ├── tableaux.ml ├── tactics.ml ├── unif.ml └── verbose_functions.ml ├── README.txt ├── SML ├── Init.thy ├── LICENSE ├── LICENSE.txt ├── NOTES.txt ├── Proven-Init.thy ├── Proven-init.sml ├── Proven-init_nj.sml ├── Proven-lcf.sml ├── Proven.sml ├── Proven.thy ├── eqelim.sml ├── equal.sml ├── fol.sml ├── folderived.sml ├── format.sml ├── format_simple.sml ├── formulas.sml ├── full_test.sml ├── init.sml ├── init_nj.sml ├── initialization.sml ├── intro.sml ├── lcf.sml ├── lcffol.sml ├── lcfprop.sml ├── lib.sml ├── order.sml ├── prop.sml ├── resolution.sml ├── skolem.sml ├── tableaux.sml ├── tactics.sml ├── timing.sml ├── timing_nj.sml ├── unif.sml └── verbose_functions.sml ├── auxi └── cleaner.sml └── tests ├── executionOCaml.txt ├── executionSML.txt ├── resultOCaml.txt └── resultSML.txt /README.md: -------------------------------------------------------------------------------- 1 | # SML-Handbook - SML version of code for John Harrison's "Handbook of Practical Logic and Automated Reasoning" (Chapter 6 on Interactive Theorem Proving only) 2 | 3 | *For Isabelle, Moscow ML, Standard ML of New Jersey and Poly/ML.* 4 | 5 | New entry in the Archive of Formal Proofs: https://www.isa-afp.org/entries/FOL_Harrison.shtml 6 | 7 | The verification in Isabelle of the kernel is described here: 8 | 9 | Alexander Birch Jensen, Anders Schlichtkrull, Jørgen Villadsen: Verification of an LCF-Style First-Order Prover with Equality. Isabelle Workshop 2016: http://www21.in.tum.de/~nipkow/Isabelle2016/ 10 | 11 | Please provide feedback to Associate Professor Jørgen Villadsen, DTU Compute, Denmark: http://people.compute.dtu.dk/jovi/ 12 | -------------------------------------------------------------------------------- /code/OCaml/LICENSE.txt: -------------------------------------------------------------------------------- 1 | IMPORTANT: READ BEFORE DOWNLOADING, COPYING, INSTALLING OR USING. 2 | By downloading, copying, installing or using the software you agree 3 | to this license. If you do not agree to this license, do not 4 | download, install, copy or use the software. 5 | 6 | Copyright (c) 2003-2007, John Harrison 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | * Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | * Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in the 18 | documentation and/or other materials provided with the distribution. 19 | 20 | * The name of John Harrison may not be used to endorse or promote 21 | products derived from this software without specific prior written 22 | permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 27 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 28 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 30 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 31 | USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 32 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 33 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 34 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 35 | SUCH DAMAGE. 36 | -------------------------------------------------------------------------------- /code/OCaml/Makefile: -------------------------------------------------------------------------------- 1 | # List of ML files to compile as a library. This leaves out the following 2 | # which are probably not much use: 3 | # 4 | # sigma.ml (Sigma-formulas and evaluator-by-proof) 5 | # turing.ml (OCaml implementation of Turing machines) 6 | # undecidable.ml (Proofs related to undecidability results) 7 | # bhk.ml (Trivial instance of BHK interpretation) 8 | # many.ml (Example relevant to many-sorted logic) 9 | # hol.ml (Simple higher order logic setup) 10 | 11 | # Use camlp5 for versions of OCaml >= 3.10 12 | # Download this from http://pauillac.inria.fr/~ddr/camlp5/ 13 | 14 | USE_CAMLP5=test `ocamlc -version | cut -c3` != "0" 15 | 16 | MLFILES = initialization.ml lib.ml intro.ml formulas.ml prop.ml propexamples.ml \ 17 | defcnf.ml dp.ml stal.ml bdd.ml fol.ml skolem.ml \ 18 | herbrand.ml unif.ml tableaux.ml resolution.ml prolog.ml \ 19 | meson.ml skolems.ml equal.ml cong.ml rewrite.ml \ 20 | order.ml completion.ml eqelim.ml \ 21 | paramodulation.ml decidable.ml qelim.ml cooper.ml \ 22 | complex.ml real.ml grobner.ml geom.ml interpolation.ml \ 23 | combining.ml lcf.ml lcfprop.ml folderived.ml lcffol.ml \ 24 | tactics.ml limitations.ml 25 | 26 | # The default is an interactive session skipping the examples. 27 | 28 | interactive: atp_interactive.ml init.ml; echo '#use "init.ml";;' >.ocamlinit; (sleep 3s; rm -f .ocamlinit) & ocaml 29 | 30 | # Build a bytecode executable 31 | 32 | bytecode: example.ml atp_batch.cmo; \ 33 | if ${USE_CAMLP5}; \ 34 | then ocamlc -pp "camlp5o ./Quotexpander.cmo" -o example nums.cma atp_batch.cmo example.ml; \ 35 | else ocamlc -pp "camlp4o ./Quotexpander.cmo" -o example nums.cma atp_batch.cmo example.ml; \ 36 | fi 37 | 38 | # Alternatively, produce native code 39 | 40 | compiled: example.ml atp_batch.cmx; \ 41 | if ${USE_CAMLP5}; \ 42 | then ocamlopt -pp "camlp5o ./Quotexpander.cmo" -o example nums.cmxa atp_batch.cmx example.ml; \ 43 | else ocamlopt -pp "camlp4o ./Quotexpander.cmo" -o example nums.cmxa atp_batch.cmx example.ml; \ 44 | fi 45 | 46 | # Make the appropriate object for the main body of code 47 | 48 | atp_batch.cmx: Quotexpander.cmo atp_batch.ml; \ 49 | if ${USE_CAMLP5}; \ 50 | then ocamlopt -pp "camlp5o ./Quotexpander.cmo" -w ax -c atp_batch.ml; \ 51 | else ocamlopt -pp "camlp4o ./Quotexpander.cmo" -w ax -c atp_batch.ml; \ 52 | fi 53 | 54 | atp_batch.cmo: Quotexpander.cmo atp_batch.ml; \ 55 | if ${USE_CAMLP5}; \ 56 | then ocamlc -pp "camlp5o ./Quotexpander.cmo" -w ax -c atp_batch.ml; \ 57 | else ocamlc -pp "camlp4o ./Quotexpander.cmo" -w ax -c atp_batch.ml; \ 58 | fi 59 | 60 | # Make the camlp4 or camlp5 quotation expander 61 | 62 | Quotexpander.cmo: Quotexpander.ml; if ${USE_CAMLP5}; \ 63 | then ocamlc -I +camlp5 -c Quotexpander.ml; \ 64 | else ocamlc -I +camlp4 -c Quotexpander.ml; \ 65 | fi 66 | 67 | # Extract the non-interactive part of the code 68 | 69 | atp_interactive.ml: $(MLFILES); ./Mk_ml_file $(MLFILES) >atp_interactive.ml 70 | 71 | atp_batch.ml: $(MLFILES); ./Mk_ml_file $(MLFILES) | grep -v install_printer >atp_batch.ml 72 | 73 | # Clean up 74 | 75 | clean:; -rm -f atp_batch.cma atp_batch.cmi atp_batch.cmo atp_batch.cmx atp_batch.o atp_batch.ml example example.exe example.cmi example.cmo example.cmx example.o Quotexpander.cmo Quotexpander.cmi atp_interactive.ml .ocamlinit 76 | -------------------------------------------------------------------------------- /code/OCaml/Mk_ml_file: -------------------------------------------------------------------------------- 1 | echo "open Num;;" 2 | echo "open Format;;" 3 | 4 | cat $@ | sed 's/START_INTERACTIVE;;/(\*/' | sed 's/END_INTERACTIVE;;/\*)/' 5 | -------------------------------------------------------------------------------- /code/OCaml/Quotexpander.ml: -------------------------------------------------------------------------------- 1 | let quotexpander s = 2 | if String.sub s 0 1 = "|" & String.sub s (String.length s - 1) 1 = "|" then 3 | "secondary_parser \""^ 4 | (String.escaped (String.sub s 1 (String.length s - 2)))^"\"" 5 | else "default_parser \""^(String.escaped s)^"\"";; 6 | 7 | Quotation.add "" (Quotation.ExStr (fun x -> quotexpander));; 8 | -------------------------------------------------------------------------------- /code/OCaml/bdd.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Binary decision diagrams (BDDs) using complement edges. *) 3 | (* *) 4 | (* In practice one would use hash tables, but we use abstract finite *) 5 | (* partial functions here. They might also look nicer imperatively. *) 6 | (* *) 7 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 8 | (* ========================================================================= *) 9 | 10 | type bddnode = prop * int * int;; 11 | 12 | (* ------------------------------------------------------------------------- *) 13 | (* A BDD contains a variable order, unique and computed table. *) 14 | (* ------------------------------------------------------------------------- *) 15 | 16 | type bdd = Bdd of ((bddnode,int)func * (int,bddnode)func * int) * 17 | (prop->prop->bool);; 18 | 19 | let print_bdd (Bdd((unique,uback,n),ord)) = 20 | print_string ("");; 21 | 22 | #install_printer print_bdd;; 23 | 24 | (* ------------------------------------------------------------------------- *) 25 | (* Map a BDD node back to its components. *) 26 | (* ------------------------------------------------------------------------- *) 27 | 28 | let expand_node (Bdd((_,expand,_),_)) n = 29 | if n >= 0 then tryapplyd expand n (P"",1,1) 30 | else let (p,l,r) = tryapplyd expand (-n) (P"",1,1) in (p,-l,-r);; 31 | 32 | (* ------------------------------------------------------------------------- *) 33 | (* Lookup or insertion if not there in unique table. *) 34 | (* ------------------------------------------------------------------------- *) 35 | 36 | let lookup_unique (Bdd((unique,expand,n),ord) as bdd) node = 37 | try bdd,apply unique node with Failure _ -> 38 | Bdd(((node|->n) unique,(n|->node) expand,n+1),ord),n;; 39 | 40 | (* ------------------------------------------------------------------------- *) 41 | (* Produce a BDD node (old or new). *) 42 | (* ------------------------------------------------------------------------- *) 43 | 44 | let mk_node bdd (s,l,r) = 45 | if l = r then bdd,l 46 | else if l >= 0 then lookup_unique bdd (s,l,r) 47 | else let bdd',n = lookup_unique bdd (s,-l,-r) in bdd',-n;; 48 | 49 | (* ------------------------------------------------------------------------- *) 50 | (* Create a new BDD with a given ordering. *) 51 | (* ------------------------------------------------------------------------- *) 52 | 53 | let mk_bdd ord = Bdd((undefined,undefined,2),ord);; 54 | 55 | (* ------------------------------------------------------------------------- *) 56 | (* Extract the ordering field of a BDD. *) 57 | (* ------------------------------------------------------------------------- *) 58 | 59 | let order (Bdd(_,ord)) p1 p2 = (p2 = P"" & p1 <> P"") or ord p1 p2;; 60 | 61 | (* ------------------------------------------------------------------------- *) 62 | (* Threading state through. *) 63 | (* ------------------------------------------------------------------------- *) 64 | 65 | let thread s g (f1,x1) (f2,x2) = 66 | let s',y1 = f1 s x1 in let s'',y2 = f2 s' x2 in g s'' (y1,y2);; 67 | 68 | (* ------------------------------------------------------------------------- *) 69 | (* Perform an AND operation on BDDs, maintaining canonicity. *) 70 | (* ------------------------------------------------------------------------- *) 71 | 72 | let rec bdd_and (bdd,comp as bddcomp) (m1,m2) = 73 | if m1 = -1 or m2 = -1 then bddcomp,-1 74 | else if m1 = 1 then bddcomp,m2 else if m2 = 1 then bddcomp,m1 else 75 | try bddcomp,apply comp (m1,m2) with Failure _ -> 76 | try bddcomp,apply comp (m2,m1) with Failure _ -> 77 | let (p1,l1,r1) = expand_node bdd m1 78 | and (p2,l2,r2) = expand_node bdd m2 in 79 | let (p,lpair,rpair) = 80 | if p1 = p2 then p1,(l1,l2),(r1,r2) 81 | else if order bdd p1 p2 then p1,(l1,m2),(r1,m2) 82 | else p2,(m1,l2),(m1,r2) in 83 | let (bdd',comp'),(lnew,rnew) = 84 | thread bddcomp (fun s z -> s,z) (bdd_and,lpair) (bdd_and,rpair) in 85 | let bdd'',n = mk_node bdd' (p,lnew,rnew) in 86 | (bdd'',((m1,m2) |-> n) comp'),n;; 87 | 88 | (* ------------------------------------------------------------------------- *) 89 | (* The other binary connectives. *) 90 | (* ------------------------------------------------------------------------- *) 91 | 92 | let bdd_or bdc (m1,m2) = let bdc1,n = bdd_and bdc (-m1,-m2) in bdc1,-n;; 93 | 94 | let bdd_imp bdc (m1,m2) = bdd_or bdc (-m1,m2);; 95 | 96 | let bdd_iff bdc (m1,m2) = 97 | thread bdc bdd_or (bdd_and,(m1,m2)) (bdd_and,(-m1,-m2));; 98 | 99 | (* ------------------------------------------------------------------------- *) 100 | (* Formula to BDD conversion. *) 101 | (* ------------------------------------------------------------------------- *) 102 | 103 | let rec mkbdd (bdd,comp as bddcomp) fm = 104 | match fm with 105 | False -> bddcomp,-1 106 | | True -> bddcomp,1 107 | | Atom(s) -> let bdd',n = mk_node bdd (s,1,-1) in (bdd',comp),n 108 | | Not(p) -> let bddcomp',n = mkbdd bddcomp p in bddcomp',-n 109 | | And(p,q) -> thread bddcomp bdd_and (mkbdd,p) (mkbdd,q) 110 | | Or(p,q) -> thread bddcomp bdd_or (mkbdd,p) (mkbdd,q) 111 | | Imp(p,q) -> thread bddcomp bdd_imp (mkbdd,p) (mkbdd,q) 112 | | Iff(p,q) -> thread bddcomp bdd_iff (mkbdd,p) (mkbdd,q);; 113 | 114 | (* ------------------------------------------------------------------------- *) 115 | (* Tautology checking using BDDs. *) 116 | (* ------------------------------------------------------------------------- *) 117 | 118 | let bddtaut fm = snd(mkbdd (mk_bdd (<),undefined) fm) = 1;; 119 | 120 | (* ------------------------------------------------------------------------- *) 121 | (* Examples. *) 122 | (* ------------------------------------------------------------------------- *) 123 | 124 | START_INTERACTIVE;; 125 | bddtaut (mk_adder_test 4 2);; 126 | END_INTERACTIVE;; 127 | 128 | (* ------------------------------------------------------------------------- *) 129 | (* Towards a more intelligent treatment of "definitions". *) 130 | (* ------------------------------------------------------------------------- *) 131 | 132 | let dest_nimp fm = match fm with Not(p) -> p,False | _ -> dest_imp fm;; 133 | 134 | let rec dest_iffdef fm = 135 | match fm with 136 | Iff(Atom(x),r) | Iff(r,Atom(x)) -> x,r 137 | | _ -> failwith "not a defining equivalence";; 138 | 139 | let restore_iffdef (x,e) fm = Imp(Iff(Atom(x),e),fm);; 140 | 141 | let suitable_iffdef defs (x,q) = 142 | let fvs = atoms q in not (exists (fun (x',_) -> mem x' fvs) defs);; 143 | 144 | let rec sort_defs acc defs fm = 145 | try let (x,e) = find (suitable_iffdef defs) defs in 146 | let ps,nonps = partition (fun (x',_) -> x' = x) defs in 147 | let ps' = subtract ps [x,e] in 148 | sort_defs ((x,e)::acc) nonps (itlist restore_iffdef ps' fm) 149 | with Failure _ -> rev acc,itlist restore_iffdef defs fm;; 150 | 151 | (* ------------------------------------------------------------------------- *) 152 | (* Improved setup. *) 153 | (* ------------------------------------------------------------------------- *) 154 | 155 | let rec mkbdde sfn (bdd,comp as bddcomp) fm = 156 | match fm with 157 | False -> bddcomp,-1 158 | | True -> bddcomp,1 159 | | Atom(s) -> (try bddcomp,apply sfn s with Failure _ -> 160 | let bdd',n = mk_node bdd (s,1,-1) in (bdd',comp),n) 161 | | Not(p) -> let bddcomp',n = mkbdde sfn bddcomp p in bddcomp',-n 162 | | And(p,q) -> thread bddcomp bdd_and (mkbdde sfn,p) (mkbdde sfn,q) 163 | | Or(p,q) -> thread bddcomp bdd_or (mkbdde sfn,p) (mkbdde sfn,q) 164 | | Imp(p,q) -> thread bddcomp bdd_imp (mkbdde sfn,p) (mkbdde sfn,q) 165 | | Iff(p,q) -> thread bddcomp bdd_iff (mkbdde sfn,p) (mkbdde sfn,q);; 166 | 167 | let rec mkbdds sfn bdd defs fm = 168 | match defs with 169 | [] -> mkbdde sfn bdd fm 170 | | (p,e)::odefs -> let bdd',b = mkbdde sfn bdd e in 171 | mkbdds ((p |-> b) sfn) bdd' odefs fm;; 172 | 173 | let ebddtaut fm = 174 | let l,r = try dest_nimp fm with Failure _ -> True,fm in 175 | let eqs,noneqs = partition (can dest_iffdef) (conjuncts l) in 176 | let defs,fm' = sort_defs [] (map dest_iffdef eqs) 177 | (itlist mk_imp noneqs r) in 178 | snd(mkbdds undefined (mk_bdd (<),undefined) defs fm') = 1;; 179 | 180 | (* ------------------------------------------------------------------------- *) 181 | (* Examples. *) 182 | (* ------------------------------------------------------------------------- *) 183 | 184 | START_INTERACTIVE;; 185 | ebddtaut (prime 101);; 186 | 187 | ebddtaut (mk_adder_test 9 5);; 188 | END_INTERACTIVE;; 189 | -------------------------------------------------------------------------------- /code/OCaml/cong.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Simple congruence closure. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | let rec subterms tm = 8 | match tm with 9 | Fn(f,args) -> itlist (union ** subterms) args [tm] 10 | | _ -> [tm];; 11 | 12 | (* ------------------------------------------------------------------------- *) 13 | (* Test whether subterms are congruent under an equivalence. *) 14 | (* ------------------------------------------------------------------------- *) 15 | 16 | let congruent eqv (s,t) = 17 | match (s,t) with 18 | Fn(f,a1),Fn(g,a2) -> f = g & forall2 (equivalent eqv) a1 a2 19 | | _ -> false;; 20 | 21 | (* ------------------------------------------------------------------------- *) 22 | (* Merging of terms, with congruence closure. *) 23 | (* ------------------------------------------------------------------------- *) 24 | 25 | let rec emerge (s,t) (eqv,pfn) = 26 | let s' = canonize eqv s and t' = canonize eqv t in 27 | if s' = t' then (eqv,pfn) else 28 | let sp = tryapplyl pfn s' and tp = tryapplyl pfn t' in 29 | let eqv' = equate (s,t) eqv in 30 | let st' = canonize eqv' s' in 31 | let pfn' = (st' |-> union sp tp) pfn in 32 | itlist (fun (u,v) (eqv,pfn) -> 33 | if congruent eqv (u,v) then emerge (u,v) (eqv,pfn) 34 | else eqv,pfn) 35 | (allpairs (fun u v -> (u,v)) sp tp) (eqv',pfn');; 36 | 37 | (* ------------------------------------------------------------------------- *) 38 | (* Satisfiability of conjunction of ground equations and inequations. *) 39 | (* ------------------------------------------------------------------------- *) 40 | 41 | let predecessors t pfn = 42 | match t with 43 | Fn(f,a) -> itlist (fun s f -> (s |-> insert t (tryapplyl f s)) f) 44 | (setify a) pfn 45 | | _ -> pfn;; 46 | 47 | let ccsatisfiable fms = 48 | let pos,neg = partition positive fms in 49 | let eqps = map dest_eq pos and eqns = map (dest_eq ** negate) neg in 50 | let lrs = map fst eqps @ map snd eqps @ map fst eqns @ map snd eqns in 51 | let pfn = itlist predecessors (unions(map subterms lrs)) undefined in 52 | let eqv,_ = itlist emerge eqps (unequal,pfn) in 53 | forall (fun (l,r) -> not(equivalent eqv l r)) eqns;; 54 | 55 | (* ------------------------------------------------------------------------- *) 56 | (* Validity checking a universal formula. *) 57 | (* ------------------------------------------------------------------------- *) 58 | 59 | let ccvalid fm = 60 | let fms = simpdnf(askolemize(Not(generalize fm))) in 61 | not (exists ccsatisfiable fms);; 62 | 63 | (* ------------------------------------------------------------------------- *) 64 | (* Example. *) 65 | (* ------------------------------------------------------------------------- *) 66 | 67 | START_INTERACTIVE;; 68 | ccvalid < f(c) = c \/ f(g(c)) = g(f(c))>>;; 70 | 71 | ccvalid < f(c) = c>>;; 72 | 73 | (* ------------------------------------------------------------------------- *) 74 | (* For debugging. Maybe I will incorporate into a prettyprinter one day. *) 75 | (* ------------------------------------------------------------------------- *) 76 | 77 | (********** 78 | 79 | let showequiv ptn = 80 | let fn = reverseq (equated ptn) ptn in 81 | map (apply fn) (dom fn);; 82 | 83 | **********) 84 | 85 | END_INTERACTIVE;; 86 | -------------------------------------------------------------------------------- /code/OCaml/defcnf.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Definitional CNF. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | START_INTERACTIVE;; 8 | cnf <

(q <=> r)>>;; 9 | END_INTERACTIVE;; 10 | 11 | (* ------------------------------------------------------------------------- *) 12 | (* Make a stylized variable and update the index. *) 13 | (* ------------------------------------------------------------------------- *) 14 | 15 | let mkprop n = Atom(P("p_"^(string_of_num n))),n +/ Int 1;; 16 | 17 | (* ------------------------------------------------------------------------- *) 18 | (* Core definitional CNF procedure. *) 19 | (* ------------------------------------------------------------------------- *) 20 | 21 | let rec maincnf (fm,defs,n as trip) = 22 | match fm with 23 | And(p,q) -> defstep mk_and (p,q) trip 24 | | Or(p,q) -> defstep mk_or (p,q) trip 25 | | Iff(p,q) -> defstep mk_iff (p,q) trip 26 | | _ -> trip 27 | 28 | and defstep op (p,q) (fm,defs,n) = 29 | let fm1,defs1,n1 = maincnf (p,defs,n) in 30 | let fm2,defs2,n2 = maincnf (q,defs1,n1) in 31 | let fm' = op fm1 fm2 in 32 | try (fst(apply defs2 fm'),defs2,n2) with Failure _ -> 33 | let v,n3 = mkprop n2 in (v,(fm'|->(v,Iff(v,fm'))) defs2,n3);; 34 | 35 | (* ------------------------------------------------------------------------- *) 36 | (* Make n large enough that "v_m" won't clash with s for any m >= n *) 37 | (* ------------------------------------------------------------------------- *) 38 | 39 | let max_varindex pfx = 40 | let m = String.length pfx in 41 | fun s n -> 42 | let l = String.length s in 43 | if l <= m or String.sub s 0 m <> pfx then n else 44 | let s' = String.sub s m (l - m) in 45 | if forall numeric (explode s') then max_num n (num_of_string s') 46 | else n;; 47 | 48 | (* ------------------------------------------------------------------------- *) 49 | (* Overall definitional CNF. *) 50 | (* ------------------------------------------------------------------------- *) 51 | 52 | let mk_defcnf fn fm = 53 | let fm' = nenf fm in 54 | let n = Int 1 +/ overatoms (max_varindex "p_" ** pname) fm' (Int 0) in 55 | let (fm'',defs,_) = fn (fm',undefined,n) in 56 | let deflist = map (snd ** snd) (graph defs) in 57 | unions(simpcnf fm'' :: map simpcnf deflist);; 58 | 59 | let defcnf fm = list_conj(map list_disj(mk_defcnf maincnf fm));; 60 | 61 | (* ------------------------------------------------------------------------- *) 62 | (* Example. *) 63 | (* ------------------------------------------------------------------------- *) 64 | 65 | START_INTERACTIVE;; 66 | defcnf <<(p \/ (q /\ ~r)) /\ s>>;; 67 | END_INTERACTIVE;; 68 | 69 | (* ------------------------------------------------------------------------- *) 70 | (* Version tweaked to exploit initial structure. *) 71 | (* ------------------------------------------------------------------------- *) 72 | 73 | let subcnf sfn op (p,q) (fm,defs,n) = 74 | let fm1,defs1,n1 = sfn(p,defs,n) in 75 | let fm2,defs2,n2 = sfn(q,defs1,n1) in (op fm1 fm2,defs2,n2);; 76 | 77 | let rec orcnf (fm,defs,n as trip) = 78 | match fm with 79 | Or(p,q) -> subcnf orcnf mk_or (p,q) trip 80 | | _ -> maincnf trip;; 81 | 82 | let rec andcnf (fm,defs,n as trip) = 83 | match fm with 84 | And(p,q) -> subcnf andcnf mk_and (p,q) trip 85 | | _ -> orcnf trip;; 86 | 87 | let defcnfs fm = mk_defcnf andcnf fm;; 88 | 89 | let defcnf fm = list_conj (map list_disj (defcnfs fm));; 90 | 91 | (* ------------------------------------------------------------------------- *) 92 | (* Examples. *) 93 | (* ------------------------------------------------------------------------- *) 94 | 95 | START_INTERACTIVE;; 96 | defcnf <<(p \/ (q /\ ~r)) /\ s>>;; 97 | END_INTERACTIVE;; 98 | 99 | (* ------------------------------------------------------------------------- *) 100 | (* Version that guarantees 3-CNF. *) 101 | (* ------------------------------------------------------------------------- *) 102 | 103 | let rec andcnf3 (fm,defs,n as trip) = 104 | match fm with 105 | And(p,q) -> subcnf andcnf3 mk_and (p,q) trip 106 | | _ -> maincnf trip;; 107 | 108 | let defcnf3 fm = list_conj (map list_disj(mk_defcnf andcnf3 fm));; 109 | -------------------------------------------------------------------------------- /code/OCaml/dp.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* The Davis-Putnam and Davis-Putnam-Loveland-Logemann procedures. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* The DP procedure. *) 9 | (* ------------------------------------------------------------------------- *) 10 | 11 | let one_literal_rule clauses = 12 | let u = hd (find (fun cl -> length cl = 1) clauses) in 13 | let u' = negate u in 14 | let clauses1 = filter (fun cl -> not (mem u cl)) clauses in 15 | image (fun cl -> subtract cl [u']) clauses1;; 16 | 17 | let affirmative_negative_rule clauses = 18 | let neg',pos = partition negative (unions clauses) in 19 | let neg = image negate neg' in 20 | let pos_only = subtract pos neg and neg_only = subtract neg pos in 21 | let pure = union pos_only (image negate neg_only) in 22 | if pure = [] then failwith "affirmative_negative_rule" else 23 | filter (fun cl -> intersect cl pure = []) clauses;; 24 | 25 | let resolve_on p clauses = 26 | let p' = negate p and pos,notpos = partition (mem p) clauses in 27 | let neg,other = partition (mem p') notpos in 28 | let pos' = image (filter (fun l -> l <> p)) pos 29 | and neg' = image (filter (fun l -> l <> p')) neg in 30 | let res0 = allpairs union pos' neg' in 31 | union other (filter (non trivial) res0);; 32 | 33 | let resolution_blowup cls l = 34 | let m = length(filter (mem l) cls) 35 | and n = length(filter (mem (negate l)) cls) in 36 | m * n - m - n;; 37 | 38 | let resolution_rule clauses = 39 | let pvs = filter positive (unions clauses) in 40 | let p = minimize (resolution_blowup clauses) pvs in 41 | resolve_on p clauses;; 42 | 43 | (* ------------------------------------------------------------------------- *) 44 | (* Overall procedure. *) 45 | (* ------------------------------------------------------------------------- *) 46 | 47 | let rec dp clauses = 48 | if clauses = [] then true else if mem [] clauses then false else 49 | try dp (one_literal_rule clauses) with Failure _ -> 50 | try dp (affirmative_negative_rule clauses) with Failure _ -> 51 | dp(resolution_rule clauses);; 52 | 53 | (* ------------------------------------------------------------------------- *) 54 | (* Davis-Putnam satisfiability tester and tautology checker. *) 55 | (* ------------------------------------------------------------------------- *) 56 | 57 | let dpsat fm = dp(defcnfs fm);; 58 | 59 | let dptaut fm = not(dpsat(Not fm));; 60 | 61 | (* ------------------------------------------------------------------------- *) 62 | (* Examples. *) 63 | (* ------------------------------------------------------------------------- *) 64 | 65 | START_INTERACTIVE;; 66 | tautology(prime 11);; 67 | 68 | dptaut(prime 11);; 69 | END_INTERACTIVE;; 70 | 71 | (* ------------------------------------------------------------------------- *) 72 | (* The same thing but with the DPLL procedure. *) 73 | (* ------------------------------------------------------------------------- *) 74 | 75 | let posneg_count cls l = 76 | let m = length(filter (mem l) cls) 77 | and n = length(filter (mem (negate l)) cls) in 78 | m + n;; 79 | 80 | let rec dpll clauses = 81 | if clauses = [] then true else if mem [] clauses then false else 82 | try dpll(one_literal_rule clauses) with Failure _ -> 83 | try dpll(affirmative_negative_rule clauses) with Failure _ -> 84 | let pvs = filter positive (unions clauses) in 85 | let p = maximize (posneg_count clauses) pvs in 86 | dpll (insert [p] clauses) or dpll (insert [negate p] clauses);; 87 | 88 | let dpllsat fm = dpll(defcnfs fm);; 89 | 90 | let dplltaut fm = not(dpllsat(Not fm));; 91 | 92 | (* ------------------------------------------------------------------------- *) 93 | (* Example. *) 94 | (* ------------------------------------------------------------------------- *) 95 | 96 | START_INTERACTIVE;; 97 | dplltaut(prime 11);; 98 | END_INTERACTIVE;; 99 | 100 | (* ------------------------------------------------------------------------- *) 101 | (* Iterative implementation with explicit trail instead of recursion. *) 102 | (* ------------------------------------------------------------------------- *) 103 | 104 | type trailmix = Guessed | Deduced;; 105 | 106 | let unassigned = 107 | let litabs p = match p with Not q -> q | _ -> p in 108 | fun cls trail -> subtract (unions(image (image litabs) cls)) 109 | (image (litabs ** fst) trail);; 110 | 111 | let rec unit_subpropagate (cls,fn,trail) = 112 | let cls' = map (filter ((not) ** defined fn ** negate)) cls in 113 | let uu = function [c] when not(defined fn c) -> [c] | _ -> failwith "" in 114 | let newunits = unions(mapfilter uu cls') in 115 | if newunits = [] then (cls',fn,trail) else 116 | let trail' = itlist (fun p t -> (p,Deduced)::t) newunits trail 117 | and fn' = itlist (fun u -> (u |-> ())) newunits fn in 118 | unit_subpropagate (cls',fn',trail');; 119 | 120 | let unit_propagate (cls,trail) = 121 | let fn = itlist (fun (x,_) -> (x |-> ())) trail undefined in 122 | let cls',fn',trail' = unit_subpropagate (cls,fn,trail) in cls',trail';; 123 | 124 | let rec backtrack trail = 125 | match trail with 126 | (p,Deduced)::tt -> backtrack tt 127 | | _ -> trail;; 128 | 129 | let rec dpli cls trail = 130 | let cls',trail' = unit_propagate (cls,trail) in 131 | if mem [] cls' then 132 | match backtrack trail with 133 | (p,Guessed)::tt -> dpli cls ((negate p,Deduced)::tt) 134 | | _ -> false 135 | else 136 | match unassigned cls trail' with 137 | [] -> true 138 | | ps -> let p = maximize (posneg_count cls') ps in 139 | dpli cls ((p,Guessed)::trail');; 140 | 141 | let dplisat fm = dpli (defcnfs fm) [];; 142 | 143 | let dplitaut fm = not(dplisat(Not fm));; 144 | 145 | (* ------------------------------------------------------------------------- *) 146 | (* With simple non-chronological backjumping and learning. *) 147 | (* ------------------------------------------------------------------------- *) 148 | 149 | let rec backjump cls p trail = 150 | match backtrack trail with 151 | (q,Guessed)::tt -> 152 | let cls',trail' = unit_propagate (cls,(p,Guessed)::tt) in 153 | if mem [] cls' then backjump cls p tt else trail 154 | | _ -> trail;; 155 | 156 | let rec dplb cls trail = 157 | let cls',trail' = unit_propagate (cls,trail) in 158 | if mem [] cls' then 159 | match backtrack trail with 160 | (p,Guessed)::tt -> 161 | let trail' = backjump cls p tt in 162 | let declits = filter (fun (_,d) -> d = Guessed) trail' in 163 | let conflict = insert (negate p) (image (negate ** fst) declits) in 164 | dplb (conflict::cls) ((negate p,Deduced)::trail') 165 | | _ -> false 166 | else 167 | match unassigned cls trail' with 168 | [] -> true 169 | | ps -> let p = maximize (posneg_count cls') ps in 170 | dplb cls ((p,Guessed)::trail');; 171 | 172 | let dplbsat fm = dplb (defcnfs fm) [];; 173 | 174 | let dplbtaut fm = not(dplbsat(Not fm));; 175 | 176 | (* ------------------------------------------------------------------------- *) 177 | (* Examples. *) 178 | (* ------------------------------------------------------------------------- *) 179 | 180 | START_INTERACTIVE;; 181 | dplitaut(prime 101);; 182 | dplbtaut(prime 101);; 183 | END_INTERACTIVE;; 184 | -------------------------------------------------------------------------------- /code/OCaml/eqelim.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Equality elimination including Brand transformation and relatives. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | START_INTERACTIVE;; 8 | 9 | (* ------------------------------------------------------------------------- *) 10 | (* The x^2 = 1 implies Abelian problem. *) 11 | (* ------------------------------------------------------------------------- *) 12 | 13 | meson 14 | <<(forall x. P(1,x,x)) /\ 15 | (forall x. P(x,x,1)) /\ 16 | (forall u v w x y z. P(x,y,u) /\ P(y,z,w) 17 | ==> (P(x,w,v) <=> P(u,z,v))) 18 | ==> forall a b c. P(a,b,c) ==> P(b,a,c)>>;; 19 | 20 | (* ------------------------------------------------------------------------- *) 21 | (* Lemma for equivalence elimination. *) 22 | (* ------------------------------------------------------------------------- *) 23 | 24 | meson 25 | <<(forall x. R(x,x)) /\ 26 | (forall x y. R(x,y) ==> R(y,x)) /\ 27 | (forall x y z. R(x,y) /\ R(y,z) ==> R(x,z)) 28 | <=> (forall x y. R(x,y) <=> (forall z. R(x,z) <=> R(y,z)))>>;; 29 | 30 | END_INTERACTIVE;; 31 | 32 | (* ------------------------------------------------------------------------- *) 33 | (* Brand's S and T modifications on clauses. *) 34 | (* ------------------------------------------------------------------------- *) 35 | 36 | let rec modify_S cl = 37 | try let (s,t) = tryfind dest_eq cl in 38 | let eq1 = mk_eq s t and eq2 = mk_eq t s in 39 | let sub = modify_S (subtract cl [eq1]) in 40 | map (insert eq1) sub @ map (insert eq2) sub 41 | with Failure _ -> [cl];; 42 | 43 | let rec modify_T cl = 44 | match cl with 45 | (Atom(R("=",[s;t])) as eq)::ps -> 46 | let ps' = modify_T ps in 47 | let w = Var(variant "w" (itlist (union ** fv) ps' (fv eq))) in 48 | Not(mk_eq t w)::(mk_eq s w)::ps' 49 | | p::ps -> p::(modify_T ps) 50 | | [] -> [];; 51 | 52 | (* ------------------------------------------------------------------------- *) 53 | (* Finding nested non-variable subterms. *) 54 | (* ------------------------------------------------------------------------- *) 55 | 56 | let is_nonvar = function (Var x) -> false | _ -> true;; 57 | 58 | let find_nestnonvar tm = 59 | match tm with 60 | Var x -> failwith "findnvsubt" 61 | | Fn(f,args) -> find is_nonvar args;; 62 | 63 | let rec find_nvsubterm fm = 64 | match fm with 65 | Atom(R("=",[s;t])) -> tryfind find_nestnonvar [s;t] 66 | | Atom(R(p,args)) -> find is_nonvar args 67 | | Not p -> find_nvsubterm p;; 68 | 69 | (* ------------------------------------------------------------------------- *) 70 | (* Replacement (substitution for non-variable) in term and literal. *) 71 | (* ------------------------------------------------------------------------- *) 72 | 73 | let rec replacet rfn tm = 74 | try apply rfn tm with Failure _ -> 75 | match tm with 76 | Fn(f,args) -> Fn(f,map (replacet rfn) args) 77 | | _ -> tm;; 78 | 79 | let replace rfn = onformula (replacet rfn);; 80 | 81 | (* ------------------------------------------------------------------------- *) 82 | (* E-modification of a clause. *) 83 | (* ------------------------------------------------------------------------- *) 84 | 85 | let rec emodify fvs cls = 86 | try let t = tryfind find_nvsubterm cls in 87 | let w = variant "w" fvs in 88 | let cls' = map (replace (t |=> Var w)) cls in 89 | emodify (w::fvs) (Not(mk_eq t (Var w))::cls') 90 | with Failure _ -> cls;; 91 | 92 | let modify_E cls = emodify (itlist (union ** fv) cls []) cls;; 93 | 94 | (* ------------------------------------------------------------------------- *) 95 | (* Overall Brand transformation. *) 96 | (* ------------------------------------------------------------------------- *) 97 | 98 | let brand cls = 99 | let cls1 = map modify_E cls in 100 | let cls2 = itlist (union ** modify_S) cls1 [] in 101 | [mk_eq (Var "x") (Var "x")]::(map modify_T cls2);; 102 | 103 | (* ------------------------------------------------------------------------- *) 104 | (* Incorporation into MESON. *) 105 | (* ------------------------------------------------------------------------- *) 106 | 107 | let bpuremeson fm = 108 | let cls = brand(simpcnf(specialize(pnf fm))) in 109 | let rules = itlist ((@) ** contrapositives) cls [] in 110 | deepen (fun n -> 111 | mexpand rules [] False (fun x -> x) (undefined,n,0); n) 0;; 112 | 113 | let bmeson fm = 114 | let fm1 = askolemize(Not(generalize fm)) in 115 | map (bpuremeson ** list_conj) (simpdnf fm1);; 116 | 117 | (* ------------------------------------------------------------------------- *) 118 | (* Examples. *) 119 | (* ------------------------------------------------------------------------- *) 120 | 121 | START_INTERACTIVE;; 122 | time bmeson 123 | <<(exists x. x = f(g(x)) /\ forall x'. x' = f(g(x')) ==> x = x') <=> 124 | (exists y. y = g(f(y)) /\ forall y'. y' = g(f(y')) ==> y = y')>>;; 125 | 126 | time emeson 127 | <<(exists x. x = f(g(x)) /\ forall x'. x' = f(g(x')) ==> x = x') <=> 128 | (exists y. y = g(f(y)) /\ forall y'. y' = g(f(y')) ==> y = y')>>;; 129 | 130 | time bmeson 131 | <<(forall x y z. x * (y * z) = (x * y) * z) /\ 132 | (forall x. e * x = x) /\ 133 | (forall x. i(x) * x = e) 134 | ==> forall x. x * i(x) = e>>;; 135 | END_INTERACTIVE;; 136 | 137 | (* ------------------------------------------------------------------------- *) 138 | (* Older stuff not now in the text. *) 139 | (* ------------------------------------------------------------------------- *) 140 | 141 | START_INTERACTIVE;; 142 | let emeson fm = meson (equalitize fm);; 143 | 144 | let ewd = 145 | <<(forall x. f(x) ==> g(x)) /\ 146 | (exists x. f(x)) /\ 147 | (forall x y. g(x) /\ g(y) ==> x = y) 148 | ==> forall y. g(y) ==> f(y)>>;; 149 | 150 | let wishnu = 151 | <<(exists x. x = f(g(x)) /\ forall x'. x' = f(g(x')) ==> x = x') <=> 152 | (exists y. y = g(f(y)) /\ forall y'. y' = g(f(y')) ==> y = y')>>;; 153 | 154 | let group1 = 155 | <<(forall x y z. x * (y * z) = (x * y) * z) /\ 156 | (forall x. e * x = x) /\ 157 | (forall x. i(x) * x = e) 158 | ==> forall x. x * e = x>>;; 159 | 160 | let group2 = 161 | <<(forall x y z. x * (y * z) = (x * y) * z) /\ 162 | (forall x. e * x = x) /\ 163 | (forall x. i(x) * x = e) 164 | ==> forall x. x * i(x) = e>>;; 165 | 166 | time bmeson ewd;; 167 | time emeson ewd;; 168 | 169 | (*********** 170 | 171 | time bmeson wishnu;; 172 | time emeson wishnu;; 173 | 174 | time bmeson group1;; 175 | time emeson group1;; 176 | 177 | time bmeson group2;; 178 | time emeson group2;; 179 | 180 | *************) 181 | 182 | (* ------------------------------------------------------------------------- *) 183 | (* Nice function composition exercise from "Conceptual Mathematics". *) 184 | (* ------------------------------------------------------------------------- *) 185 | 186 | (************** 187 | 188 | let fm = 189 | <<(forall x y z. x * (y * z) = (x * y) * z) /\ p * q * p = p 190 | ==> exists q'. p * q' * p = p /\ q' * p * q' = q'>>;; 191 | 192 | time bmeson fm;; (** Seems to take a bit longer than below version **) 193 | 194 | time emeson fm;; (** Works in 64275 seconds(!), depth 30, on laptop **) 195 | 196 | ****************) 197 | 198 | (**** Some other predicate formulations no longer in the main text 199 | 200 | meson 201 | <<(forall x. P(1,x,x)) /\ 202 | (forall x. P(i(x),x,1)) /\ 203 | (forall u v w x y z. P(x,y,u) /\ P(y,z,w) ==> (P(x,w,v) <=> P(u,z,v))) 204 | ==> forall x. P(x,1,x)>>;; 205 | 206 | meson 207 | <<(forall x. P(1,x,x)) /\ 208 | (forall x. P(i(x),x,1)) /\ 209 | (forall u v w x y z. P(x,y,u) /\ P(y,z,w) ==> (P(x,w,v) <=> P(u,z,v))) 210 | ==> forall x. P(x,i(x),1)>>;; 211 | 212 | (* ------------------------------------------------------------------------- *) 213 | (* See how efficiency drops when we assert completeness. *) 214 | (* ------------------------------------------------------------------------- *) 215 | 216 | meson 217 | <<(forall x. P(1,x,x)) /\ 218 | (forall x. P(x,x,1)) /\ 219 | (forall x y. exists z. P(x,y,z)) /\ 220 | (forall u v w x y z. P(x,y,u) /\ P(y,z,w) ==> (P(x,w,v) <=> P(u,z,v))) 221 | ==> forall a b c. P(a,b,c) ==> P(b,a,c)>>;; 222 | 223 | ****) 224 | 225 | (*** More reductions, not now explicitly in the text. 226 | 227 | meson 228 | <<(forall x. R(x,x)) /\ 229 | (forall x y z. R(x,y) /\ R(y,z) ==> R(x,z)) 230 | <=> (forall x y. R(x,y) <=> (forall z. R(y,z) ==> R(x,z)))>>;; 231 | 232 | meson 233 | <<(forall x y. R(x,y) ==> R(y,x)) <=> 234 | (forall x y. R(x,y) <=> R(x,y) /\ R(y,x))>>;; 235 | 236 | (* ------------------------------------------------------------------------- *) 237 | (* Show how Equiv' reduces to triviality. *) 238 | (* ------------------------------------------------------------------------- *) 239 | 240 | meson 241 | <<(forall x. (forall w. R'(x,w) <=> R'(x,w))) /\ 242 | (forall x y. (forall w. R'(x,w) <=> R'(y,w)) 243 | ==> (forall w. R'(y,w) <=> R'(x,w))) /\ 244 | (forall x y z. (forall w. R'(x,w) <=> R'(y,w)) /\ 245 | (forall w. R'(y,w) <=> R'(z,w)) 246 | ==> (forall w. R'(x,w) <=> R'(z,w)))>>;; 247 | 248 | (* ------------------------------------------------------------------------- *) 249 | (* More auxiliary proofs for Brand's S and T modification. *) 250 | (* ------------------------------------------------------------------------- *) 251 | 252 | meson 253 | <<(forall x y. R(x,y) <=> (forall z. R'(x,z) <=> R'(y,z))) /\ 254 | (forall x. R'(x,x)) 255 | ==> forall x y. ~R'(x,y) ==> ~R(x,y)>>;; 256 | 257 | meson 258 | <<(forall x y. R(x,y) <=> (forall z. R'(y,z) ==> R'(x,z))) /\ 259 | (forall x. R'(x,x)) 260 | ==> forall x y. ~R'(x,y) ==> ~R(x,y)>>;; 261 | 262 | meson 263 | <<(forall x y. R(x,y) <=> R'(x,y) /\ R'(y,x)) 264 | ==> forall x y. ~R'(x,y) ==> ~R(x,y)>>;; 265 | 266 | ***) 267 | 268 | END_INTERACTIVE;; 269 | -------------------------------------------------------------------------------- /code/OCaml/example.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Some examples illustrating how the theorem-proving code can be used. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | include Atp_batch;; 8 | (*include Format;;*) 9 | 10 | print_string "Starting examples\n";; 11 | 12 | (* ------------------------------------------------------------------------- *) 13 | (* Printer for formulas, to give feedback when not using toplevel. *) 14 | (* ------------------------------------------------------------------------- *) 15 | 16 | let print_formula fm = print_qformula print_atom fm; print_newline();; 17 | 18 | (* ------------------------------------------------------------------------- *) 19 | (* Prove Dijkstra's "Golden Rule" via naive tautology algorithm. *) 20 | (* ------------------------------------------------------------------------- *) 21 | 22 | let gold = <

((p <=> q) <=> p \/ q)>> in 23 | if tautology gold then print_formula gold else failwith "Not a tautology";; 24 | 25 | (* ------------------------------------------------------------------------- *) 26 | (* Solve some instances of Urquhart problems using Stalmarck's algorithm. *) 27 | (* ------------------------------------------------------------------------- *) 28 | 29 | let urquhart n = 30 | let pvs = map (fun n -> Atom(P("p_"^(string_of_int n)))) (1 -- n) in 31 | end_itlist (fun p q -> Iff(p,q)) (pvs @ pvs);; 32 | 33 | do_list (time stalmarck ** urquhart) [1;2;4;8;16];; 34 | 35 | (* ------------------------------------------------------------------------- *) 36 | (* Print a propositional formula asserting that 11 is a prime number. *) 37 | (* ------------------------------------------------------------------------- *) 38 | 39 | let prf = prime 11 in 40 | print_qformula print_propvar prf; print_newline();; 41 | 42 | (* ------------------------------------------------------------------------- *) 43 | (* Prove Agatha formula using simple tableaux after initial splitting. *) 44 | (* ------------------------------------------------------------------------- *) 45 | 46 | let p55 = 47 | < hates(x,y) /\ ~richer(x,y)) /\ 51 | (forall x. hates(agatha,x) ==> ~hates(charles,x)) /\ 52 | (hates(agatha,agatha) /\ hates(agatha,charles)) /\ 53 | (forall x. lives(x) /\ ~richer(x,agatha) ==> hates(butler,x)) /\ 54 | (forall x. hates(agatha,x) ==> hates(butler,x)) /\ 55 | (forall x. ~hates(x,agatha) \/ ~hates(x,butler) \/ ~hates(x,charles)) 56 | ==> killed(agatha,agatha) /\ 57 | ~killed(butler,agatha) /\ 58 | ~killed(charles,agatha)>> in 59 | if can (time splittab) p55 then print_formula p55 60 | else failwith "Proof failed";; 61 | 62 | (* ------------------------------------------------------------------------- *) 63 | (* Prove the Los formula using positive resolution. *) 64 | (* ------------------------------------------------------------------------- *) 65 | 66 | let los = 67 | <<(forall x y z. P(x,y) ==> P(y,z) ==> P(x,z)) /\ 68 | (forall x y z. Q(x,y) ==> Q(y,z) ==> Q(x,z)) /\ 69 | (forall x y. Q(x,y) ==> Q(y,x)) /\ 70 | (forall x y. P(x,y) \/ Q(x,y)) 71 | ==> (forall x y. P(x,y)) \/ (forall x y. Q(x,y))>> in 72 | if can (time presolution) los then print_formula los 73 | else failwith "Proof failed";; 74 | 75 | (* ------------------------------------------------------------------------- *) 76 | (* Prove Wishnu Prasetya's formula by just adding equality axioms. *) 77 | (* ------------------------------------------------------------------------- *) 78 | 79 | let wishnu = 80 | <<(exists x. x = f(g(x)) /\ forall x'. x' = f(g(x')) ==> x = x') <=> 81 | (exists y. y = g(f(y)) /\ forall y'. y' = g(f(y')) ==> y = y')>> in 82 | if can meson (equalitize wishnu) then print_formula wishnu 83 | else failwith "Formula was not proved";; 84 | 85 | (* ------------------------------------------------------------------------- *) 86 | (* Prove a formula from EWD1266a using paramodulation. *) 87 | (* ------------------------------------------------------------------------- *) 88 | 89 | let ewd = 90 | <<(forall x. f(x) ==> g(x)) /\ 91 | (exists x. f(x)) /\ 92 | (forall x y. g(x) /\ g(y) ==> x = y) 93 | ==> forall y. g(y) ==> f(y)>> in 94 | if can (time paramodulation) ewd then print_formula ewd 95 | else failwith "Proof failed";; 96 | 97 | (* ------------------------------------------------------------------------- *) 98 | (* Perform Knuth-Bendix completion on the group axioms. *) 99 | (* ------------------------------------------------------------------------- *) 100 | 101 | let eqs = 102 | complete_and_simplify 103 | ["1"; "*"; "i"] 104 | [<<1 * x = x>>; <>; <<(x * y) * z = x * y * z>>] in 105 | do_list print_formula eqs;; 106 | 107 | (* ------------------------------------------------------------------------- *) 108 | (* Produce all valid syllogisms (permitting empty relations). *) 109 | (* ------------------------------------------------------------------------- *) 110 | 111 | let all_valid_syllogisms = 112 | map anglicize_syllogism (filter aedecide all_possible_syllogisms) in 113 | do_list (fun syl -> print_string syl; print_newline()) all_valid_syllogisms;; 114 | 115 | (* ------------------------------------------------------------------------- *) 116 | (* Check a resultant (from Maple) by complex quantifier elimination. *) 117 | (* ------------------------------------------------------------------------- *) 118 | 119 | let result = 120 | time complex_qelim 121 | < 124 | d^2*c^2-2*d*c*a*f+a^2*f^2-e*d*b*c-e*b*a*f+a*e^2*c+f*d*b^2 = 0>> in 125 | print_formula result;; 126 | 127 | (* ------------------------------------------------------------------------- *) 128 | (* Perform real quantifier elimination on false and true quadratic criteria. *) 129 | (* ------------------------------------------------------------------------- *) 130 | 131 | let quad_f = 132 | time real_qelim 133 | < 134 | b^2 >= 4 * a * c>> in 135 | print_formula quad_f;; 136 | 137 | let quad_t = 138 | time real_qelim 139 | < 140 | a = 0 /\ (~(b = 0) \/ c = 0) \/ 141 | ~(a = 0) /\ b^2 >= 4 * a * c>> in 142 | print_formula quad_t;; 143 | 144 | (* ------------------------------------------------------------------------- *) 145 | (* Prove a key lemma for Loeb's theorem by Mizar-like interactive proof and *) 146 | (* turn it into a strict LCF proof afterwards. *) 147 | (* ------------------------------------------------------------------------- *) 148 | 149 | let lob = prove 150 | <<(forall p. |--(p) ==> |--(Pr(p))) /\ 151 | (forall p q. |--(imp(Pr(imp(p,q)),imp(Pr(p),Pr(q))))) /\ 152 | (forall p. |--(imp(Pr(p),Pr(Pr(p))))) 153 | ==> (forall p q. |--(imp(p,q)) /\ |--(p) ==> |--(q)) /\ 154 | (forall p q. |--(imp(q,imp(p,q)))) /\ 155 | (forall p q r. |--(imp(imp(p,imp(q,r)),imp(imp(p,q),imp(p,r))))) 156 | ==> |--(imp(G,imp(Pr(G),S))) /\ |--(imp(imp(Pr(G),S),G)) 157 | ==> |--(imp(Pr(S),S)) ==> |--(S)>> 158 | [assume["lob1",< |--(Pr(p))>>; 159 | "lob2",<>; 160 | "lob3",<>]; 161 | assume["logic",<<(forall p q. |--(imp(p,q)) /\ |--(p) ==> |--(q)) /\ 162 | (forall p q. |--(imp(q,imp(p,q)))) /\ 163 | (forall p q r. |--(imp(imp(p,imp(q,r)), 164 | imp(imp(p,q),imp(p,r)))))>>]; 165 | assume ["fix1",<<|--(imp(G,imp(Pr(G),S)))>>; 166 | "fix2",<<|--(imp(imp(Pr(G),S),G))>>]; 167 | assume["consistency",<<|--(imp(Pr(S),S))>>]; 168 | have <<|--(Pr(imp(G,imp(Pr(G),S))))>> by ["lob1"; "fix1"]; 169 | so have <<|--(imp(Pr(G),Pr(imp(Pr(G),S))))>> by ["lob2"; "logic"]; 170 | so have <<|--(imp(Pr(G),imp(Pr(Pr(G)),Pr(S))))>> by ["lob2"; "logic"]; 171 | so have <<|--(imp(Pr(G),Pr(S)))>> by ["lob3"; "logic"]; 172 | so note("L",<<|--(imp(Pr(G),S))>>) by ["consistency"; "logic"]; 173 | so have <<|--(G)>> by ["fix2"; "logic"]; 174 | so have <<|--(Pr(G))>> by ["lob1"; "logic"]; 175 | so conclude <<|--(S)>> by ["L"; "logic"]; 176 | qed] in 177 | print_thm lob; print_newline();; 178 | -------------------------------------------------------------------------------- /code/OCaml/formulas.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Polymorphic type of formulas with parser and printer. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | type ('a)formula = False 8 | | True 9 | | Atom of 'a 10 | | Not of ('a)formula 11 | | And of ('a)formula * ('a)formula 12 | | Or of ('a)formula * ('a)formula 13 | | Imp of ('a)formula * ('a)formula 14 | | Iff of ('a)formula * ('a)formula 15 | | Forall of string * ('a)formula 16 | | Exists of string * ('a)formula;; 17 | 18 | (* ------------------------------------------------------------------------- *) 19 | (* General parsing of iterated infixes. *) 20 | (* ------------------------------------------------------------------------- *) 21 | 22 | let rec parse_ginfix opsym opupdate sof subparser inp = 23 | let e1,inp1 = subparser inp in 24 | if inp1 <> [] & hd inp1 = opsym then 25 | parse_ginfix opsym opupdate (opupdate sof e1) subparser (tl inp1) 26 | else sof e1,inp1;; 27 | 28 | let parse_left_infix opsym opcon = 29 | parse_ginfix opsym (fun f e1 e2 -> opcon(f e1,e2)) (fun x -> x);; 30 | 31 | let parse_right_infix opsym opcon = 32 | parse_ginfix opsym (fun f e1 e2 -> f(opcon(e1,e2))) (fun x -> x);; 33 | 34 | let parse_list opsym = 35 | parse_ginfix opsym (fun f e1 e2 -> (f e1)@[e2]) (fun x -> [x]);; 36 | 37 | (* ------------------------------------------------------------------------- *) 38 | (* Other general parsing combinators. *) 39 | (* ------------------------------------------------------------------------- *) 40 | 41 | let papply f (ast,rest) = (f ast,rest);; 42 | 43 | let nextin inp tok = inp <> [] & hd inp = tok;; 44 | 45 | let parse_bracketed subparser cbra inp = 46 | let ast,rest = subparser inp in 47 | if nextin rest cbra then ast,tl rest 48 | else failwith "Closing bracket expected";; 49 | 50 | (* ------------------------------------------------------------------------- *) 51 | (* Parsing of formulas, parametrized by atom parser "pfn". *) 52 | (* ------------------------------------------------------------------------- *) 53 | 54 | let rec parse_atomic_formula (ifn,afn) vs inp = 55 | match inp with 56 | [] -> failwith "formula expected" 57 | | "false"::rest -> False,rest 58 | | "true"::rest -> True,rest 59 | | "("::rest -> (try ifn vs inp with Failure _ -> 60 | parse_bracketed (parse_formula (ifn,afn) vs) ")" rest) 61 | | "~"::rest -> papply (fun p -> Not p) 62 | (parse_atomic_formula (ifn,afn) vs rest) 63 | | "forall"::x::rest -> 64 | parse_quant (ifn,afn) (x::vs) (fun (x,p) -> Forall(x,p)) x rest 65 | | "exists"::x::rest -> 66 | parse_quant (ifn,afn) (x::vs) (fun (x,p) -> Exists(x,p)) x rest 67 | | _ -> afn vs inp 68 | 69 | and parse_quant (ifn,afn) vs qcon x inp = 70 | match inp with 71 | [] -> failwith "Body of quantified term expected" 72 | | y::rest -> 73 | papply (fun fm -> qcon(x,fm)) 74 | (if y = "." then parse_formula (ifn,afn) vs rest 75 | else parse_quant (ifn,afn) (y::vs) qcon y rest) 76 | 77 | and parse_formula (ifn,afn) vs inp = 78 | parse_right_infix "<=>" (fun (p,q) -> Iff(p,q)) 79 | (parse_right_infix "==>" (fun (p,q) -> Imp(p,q)) 80 | (parse_right_infix "\\/" (fun (p,q) -> Or(p,q)) 81 | (parse_right_infix "/\\" (fun (p,q) -> And(p,q)) 82 | (parse_atomic_formula (ifn,afn) vs)))) inp;; 83 | 84 | (* ------------------------------------------------------------------------- *) 85 | (* Printing of formulas, parametrized by atom printer. *) 86 | (* ------------------------------------------------------------------------- *) 87 | 88 | let bracket p n f x y = 89 | (if p then print_string "(" else ()); 90 | open_box n; f x y; close_box(); 91 | (if p then print_string ")" else ());; 92 | 93 | let rec strip_quant fm = 94 | match fm with 95 | Forall(x,(Forall(y,p) as yp)) | Exists(x,(Exists(y,p) as yp)) -> 96 | let xs,q = strip_quant yp in x::xs,q 97 | | Forall(x,p) | Exists(x,p) -> [x],p 98 | | _ -> [],fm;; 99 | 100 | let print_formula pfn = 101 | let rec print_formula pr fm = 102 | match fm with 103 | False -> print_string "false" 104 | | True -> print_string "true" 105 | | Atom(pargs) -> pfn pr pargs 106 | | Not(p) -> bracket (pr > 10) 1 (print_prefix 10) "~" p 107 | | And(p,q) -> bracket (pr > 8) 0 (print_infix 8 "/\\") p q 108 | | Or(p,q) -> bracket (pr > 6) 0 (print_infix 6 "\\/") p q 109 | | Imp(p,q) -> bracket (pr > 4) 0 (print_infix 4 "==>") p q 110 | | Iff(p,q) -> bracket (pr > 2) 0 (print_infix 2 "<=>") p q 111 | | Forall(x,p) -> bracket (pr > 0) 2 print_qnt "forall" (strip_quant fm) 112 | | Exists(x,p) -> bracket (pr > 0) 2 print_qnt "exists" (strip_quant fm) 113 | and print_qnt qname (bvs,bod) = 114 | print_string qname; 115 | do_list (fun v -> print_string " "; print_string v) bvs; 116 | print_string "."; print_space(); open_box 0; 117 | print_formula 0 bod; 118 | close_box() 119 | and print_prefix newpr sym p = 120 | print_string sym; print_formula (newpr+1) p 121 | and print_infix newpr sym p q = 122 | print_formula (newpr+1) p; 123 | print_string(" "^sym); print_space(); 124 | print_formula newpr q in 125 | print_formula 0;; 126 | 127 | let print_qformula pfn fm = 128 | open_box 0; print_string "<<"; 129 | open_box 0; print_formula pfn fm; close_box(); 130 | print_string ">>"; close_box();; 131 | 132 | (* ------------------------------------------------------------------------- *) 133 | (* OCaml won't let us use the constructors. *) 134 | (* ------------------------------------------------------------------------- *) 135 | 136 | let mk_and p q = And(p,q) and mk_or p q = Or(p,q) 137 | and mk_imp p q = Imp(p,q) and mk_iff p q = Iff(p,q) 138 | and mk_forall x p = Forall(x,p) and mk_exists x p = Exists(x,p);; 139 | 140 | (* ------------------------------------------------------------------------- *) 141 | (* Destructors. *) 142 | (* ------------------------------------------------------------------------- *) 143 | 144 | let dest_iff fm = 145 | match fm with Iff(p,q) -> (p,q) | _ -> failwith "dest_iff";; 146 | 147 | let dest_and fm = 148 | match fm with And(p,q) -> (p,q) | _ -> failwith "dest_and";; 149 | 150 | let rec conjuncts fm = 151 | match fm with And(p,q) -> conjuncts p @ conjuncts q | _ -> [fm];; 152 | 153 | let dest_or fm = 154 | match fm with Or(p,q) -> (p,q) | _ -> failwith "dest_or";; 155 | 156 | let rec disjuncts fm = 157 | match fm with Or(p,q) -> disjuncts p @ disjuncts q | _ -> [fm];; 158 | 159 | let dest_imp fm = 160 | match fm with Imp(p,q) -> (p,q) | _ -> failwith "dest_imp";; 161 | 162 | let antecedent fm = fst(dest_imp fm);; 163 | let consequent fm = snd(dest_imp fm);; 164 | 165 | (* ------------------------------------------------------------------------- *) 166 | (* Apply a function to the atoms, otherwise keeping structure. *) 167 | (* ------------------------------------------------------------------------- *) 168 | 169 | let rec onatoms f fm = 170 | match fm with 171 | Atom a -> f a 172 | | Not(p) -> Not(onatoms f p) 173 | | And(p,q) -> And(onatoms f p,onatoms f q) 174 | | Or(p,q) -> Or(onatoms f p,onatoms f q) 175 | | Imp(p,q) -> Imp(onatoms f p,onatoms f q) 176 | | Iff(p,q) -> Iff(onatoms f p,onatoms f q) 177 | | Forall(x,p) -> Forall(x,onatoms f p) 178 | | Exists(x,p) -> Exists(x,onatoms f p) 179 | | _ -> fm;; 180 | 181 | (* ------------------------------------------------------------------------- *) 182 | (* Formula analog of list iterator "itlist". *) 183 | (* ------------------------------------------------------------------------- *) 184 | 185 | let rec overatoms f fm b = 186 | match fm with 187 | Atom(a) -> f a b 188 | | Not(p) -> overatoms f p b 189 | | And(p,q) | Or(p,q) | Imp(p,q) | Iff(p,q) -> 190 | overatoms f p (overatoms f q b) 191 | | Forall(x,p) | Exists(x,p) -> overatoms f p b 192 | | _ -> b;; 193 | 194 | (* ------------------------------------------------------------------------- *) 195 | (* Special case of a union of the results of a function over the atoms. *) 196 | (* ------------------------------------------------------------------------- *) 197 | 198 | let atom_union f fm = setify (overatoms (fun h t -> f(h)@t) fm []);; 199 | -------------------------------------------------------------------------------- /code/OCaml/full_test.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/OCaml/full_test.ml -------------------------------------------------------------------------------- /code/OCaml/geom.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Geometry theorem proving. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* List of geometric properties with their coordinate translations. *) 9 | (* ------------------------------------------------------------------------- *) 10 | 11 | let coordinations = 12 | ["collinear", (** Points 1, 2 and 3 lie on a common line **) 13 | <<(1_x - 2_x) * (2_y - 3_y) = (1_y - 2_y) * (2_x - 3_x)>>; 14 | "parallel", (** Lines (1,2) and (3,4) are parallel **) 15 | <<(1_x - 2_x) * (3_y - 4_y) = (1_y - 2_y) * (3_x - 4_x)>>; 16 | "perpendicular", (** Lines (1,2) and (3,4) are perpendicular **) 17 | <<(1_x - 2_x) * (3_x - 4_x) + (1_y - 2_y) * (3_y - 4_y) = 0>>; 18 | "lengths_eq", (** Lines (1,2) and (3,4) have the same length **) 19 | <<(1_x - 2_x)^2 + (1_y - 2_y)^2 = (3_x - 4_x)^2 + (3_y - 4_y)^2>>; 20 | "is_midpoint", (** Point 1 is the midpoint of line (2,3) **) 21 | <<2 * 1_x = 2_x + 3_x /\ 2 * 1_y = 2_y + 3_y>>; 22 | "is_intersection", (** Lines (2,3) and (4,5) meet at point 1 **) 23 | <<(1_x - 2_x) * (2_y - 3_y) = (1_y - 2_y) * (2_x - 3_x) /\ 24 | (1_x - 4_x) * (4_y - 5_y) = (1_y - 4_y) * (4_x - 5_x)>>; 25 | "=", (** Points 1 and 2 are the same **) 26 | <<(1_x = 2_x) /\ (1_y = 2_y)>>];; 27 | 28 | (* ------------------------------------------------------------------------- *) 29 | (* Convert formula into coordinate form. *) 30 | (* ------------------------------------------------------------------------- *) 31 | 32 | let coordinate = onatoms 33 | (fun (R(a,args)) -> 34 | let xtms,ytms = unzip 35 | (map (fun (Var v) -> Var(v^"_x"),Var(v^"_y")) args) in 36 | let xs = map (fun n -> string_of_int n^"_x") (1--length args) 37 | and ys = map (fun n -> string_of_int n^"_y") (1--length args) in 38 | subst (fpf (xs @ ys) (xtms @ ytms)) (assoc a coordinations));; 39 | 40 | (* ------------------------------------------------------------------------- *) 41 | (* Trivial example. *) 42 | (* ------------------------------------------------------------------------- *) 43 | 44 | START_INTERACTIVE;; 45 | coordinate < collinear(b,a,c)>>;; 46 | END_INTERACTIVE;; 47 | 48 | (* ------------------------------------------------------------------------- *) 49 | (* Verify equivalence under rotation. *) 50 | (* ------------------------------------------------------------------------- *) 51 | 52 | let invariant (x',y') ((s:string),z) = 53 | let m n f = 54 | let x = string_of_int n^"_x" and y = string_of_int n^"_y" in 55 | let i = fpf ["x";"y"] [Var x;Var y] in 56 | (x |-> tsubst i x') ((y |-> tsubst i y') f) in 57 | Iff(z,subst(itlist m (1--5) undefined) z);; 58 | 59 | let invariant_under_translation = invariant (<<|x + X|>>,<<|y + Y|>>);; 60 | 61 | START_INTERACTIVE;; 62 | forall (grobner_decide ** invariant_under_translation) coordinations;; 63 | END_INTERACTIVE;; 64 | 65 | let invariant_under_rotation fm = 66 | Imp(<>, 67 | invariant (<<|c * x - s * y|>>,<<|s * x + c * y|>>) fm);; 68 | 69 | START_INTERACTIVE;; 70 | forall (grobner_decide ** invariant_under_rotation) coordinations;; 71 | END_INTERACTIVE;; 72 | 73 | (* ------------------------------------------------------------------------- *) 74 | (* And show we can always invent such a transformation to zero a y: *) 75 | (* ------------------------------------------------------------------------- *) 76 | 77 | START_INTERACTIVE;; 78 | real_qelim 79 | <>;; 80 | END_INTERACTIVE;; 81 | 82 | (* ------------------------------------------------------------------------- *) 83 | (* Choose one point to be the origin and rotate to zero another y coordinate *) 84 | (* ------------------------------------------------------------------------- *) 85 | 86 | let originate fm = 87 | let a::b::ovs = fv fm in 88 | subst (fpf [a^"_x"; a^"_y"; b^"_y"] [zero; zero; zero]) 89 | (coordinate fm);; 90 | 91 | (* ------------------------------------------------------------------------- *) 92 | (* Other interesting invariances. *) 93 | (* ------------------------------------------------------------------------- *) 94 | 95 | let invariant_under_scaling fm = 96 | Imp(<<~(A = 0)>>,invariant(<<|A * x|>>,<<|A * y|>>) fm);; 97 | 98 | let invariant_under_shearing = invariant(<<|x + b * y|>>,<<|y|>>);; 99 | 100 | START_INTERACTIVE;; 101 | forall (grobner_decide ** invariant_under_scaling) coordinations;; 102 | 103 | partition (grobner_decide ** invariant_under_shearing) coordinations;; 104 | END_INTERACTIVE;; 105 | 106 | (* ------------------------------------------------------------------------- *) 107 | (* One from "Algorithms for Computer Algebra" *) 108 | (* ------------------------------------------------------------------------- *) 109 | 110 | START_INTERACTIVE;; 111 | (grobner_decide ** originate) 112 | < lengths_eq(a,b,b,c)>>;; 114 | 115 | (* ------------------------------------------------------------------------- *) 116 | (* Parallelogram theorem (Chou's expository example at the start). *) 117 | (* ------------------------------------------------------------------------- *) 118 | 119 | (grobner_decide ** originate) 120 | < lengths_eq(a,e,e,c)>>;; 123 | 124 | (grobner_decide ** originate) 125 | < lengths_eq(a,e,e,c)>>;; 128 | END_INTERACTIVE;; 129 | 130 | (* ------------------------------------------------------------------------- *) 131 | (* Reduce p using triangular set, collecting degenerate conditions. *) 132 | (* ------------------------------------------------------------------------- *) 133 | 134 | let rec pprove vars triang p degens = 135 | if p = zero then degens else 136 | match triang with 137 | [] -> (mk_eq p zero)::degens 138 | | (Fn("+",[c;Fn("*",[Var x;_])]) as q)::qs -> 139 | if x <> hd vars then 140 | if mem (hd vars) (fvt p) 141 | then itlist (pprove vars triang) (coefficients vars p) degens 142 | else pprove (tl vars) triang p degens 143 | else 144 | let k,p' = pdivide vars p q in 145 | if k = 0 then pprove vars qs p' degens else 146 | let degens' = Not(mk_eq (head vars q) zero)::degens in 147 | itlist (pprove vars qs) (coefficients vars p') degens';; 148 | 149 | (* ------------------------------------------------------------------------- *) 150 | (* Triangulate a set of polynomials. *) 151 | (* ------------------------------------------------------------------------- *) 152 | 153 | let rec triangulate vars consts pols = 154 | if vars = [] then pols else 155 | let cns,tpols = partition (is_constant vars) pols in 156 | if cns <> [] then triangulate vars (cns @ consts) tpols else 157 | if length pols <= 1 then pols @ triangulate (tl vars) [] consts else 158 | let n = end_itlist min (map (degree vars) pols) in 159 | let p = find (fun p -> degree vars p = n) pols in 160 | let ps = subtract pols [p] in 161 | triangulate vars consts (p::map (fun q -> snd(pdivide vars q p)) ps);; 162 | 163 | (* ------------------------------------------------------------------------- *) 164 | (* Trivial version of Wu's method based on repeated pseudo-division. *) 165 | (* ------------------------------------------------------------------------- *) 166 | 167 | let wu fm vars zeros = 168 | let gfm0 = coordinate fm in 169 | let gfm = subst(itlist (fun v -> v |-> zero) zeros undefined) gfm0 in 170 | if not (set_eq vars (fv gfm)) then failwith "wu: bad parameters" else 171 | let ant,con = dest_imp gfm in 172 | let pols = map (lhs ** polyatom vars) (conjuncts ant) 173 | and ps = map (lhs ** polyatom vars) (conjuncts con) in 174 | let tri = triangulate vars [] pols in 175 | itlist (fun p -> union(pprove vars tri p [])) ps [];; 176 | 177 | (* ------------------------------------------------------------------------- *) 178 | (* Simson's theorem. *) 179 | (* ------------------------------------------------------------------------- *) 180 | 181 | START_INTERACTIVE;; 182 | let simson = 183 | < collinear(e,f,g)>>;; 193 | 194 | let vars = 195 | ["g_y"; "g_x"; "f_y"; "f_x"; "e_y"; "e_x"; "d_y"; "d_x"; "c_y"; "c_x"; 196 | "b_y"; "b_x"; "o_x"] 197 | and zeros = ["a_x"; "a_y"; "o_y"];; 198 | 199 | wu simson vars zeros;; 200 | 201 | (* ------------------------------------------------------------------------- *) 202 | (* Try without special coordinates. *) 203 | (* ------------------------------------------------------------------------- *) 204 | 205 | wu simson (vars @ zeros) [];; 206 | 207 | (* ------------------------------------------------------------------------- *) 208 | (* Pappus (Chou's figure 6). *) 209 | (* ------------------------------------------------------------------------- *) 210 | 211 | let pappus = 212 | < collinear(d,e,f)>>;; 219 | 220 | let vars = ["f_y"; "f_x"; "e_y"; "e_x"; "d_y"; "d_x"; 221 | "b3_y"; "b2_y"; "b1_y"; "a3_x"; "a2_x"; "a1_x"] 222 | and zeros = ["a1_y"; "a2_y"; "a3_y"; "b1_x"; "b2_x"; "b3_x"];; 223 | 224 | wu pappus vars zeros;; 225 | 226 | (* ------------------------------------------------------------------------- *) 227 | (* The Butterfly (figure 9). *) 228 | (* ------------------------------------------------------------------------- *) 229 | 230 | (**** 231 | let butterfly = 232 | < is_midpoint(e,f,g)>>;; 237 | 238 | let vars = ["g_y"; "g_x"; "f_y"; "f_x"; "e_y"; "e_x"; "d_y"; "c_y"; 239 | "b_y"; "d_x"; "c_x"; "b_x"; "a_x"] 240 | and zeros = ["a_y"; "o_x"; "o_y"];; 241 | 242 | **** This one is costly (too big for laptop, but doable in about 300M) 243 | **** However, it gives exactly the same degenerate conditions as Chou 244 | 245 | wu butterfly vars zeros;; 246 | 247 | **** 248 | ****) 249 | END_INTERACTIVE;; 250 | 251 | (*** Other examples removed from text 252 | 253 | (* ------------------------------------------------------------------------- *) 254 | (* Centroid (Chou, example 142). *) 255 | (* ------------------------------------------------------------------------- *) 256 | 257 | (grobner_decide ** originate) 258 | < collinear(c,f,m)>>;; 261 | 262 | ****) 263 | -------------------------------------------------------------------------------- /code/OCaml/herbrand.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Relation between FOL and propositonal logic; Herbrand theorem. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* Propositional valuation. *) 9 | (* ------------------------------------------------------------------------- *) 10 | 11 | let pholds d fm = eval fm (fun p -> d(Atom p));; 12 | 13 | (* ------------------------------------------------------------------------- *) 14 | (* Get the constants for Herbrand base, adding nullary one if necessary. *) 15 | (* ------------------------------------------------------------------------- *) 16 | 17 | let herbfuns fm = 18 | let cns,fns = partition (fun (_,ar) -> ar = 0) (functions fm) in 19 | if cns = [] then ["c",0],fns else cns,fns;; 20 | 21 | (* ------------------------------------------------------------------------- *) 22 | (* Enumeration of ground terms and m-tuples, ordered by total fns. *) 23 | (* ------------------------------------------------------------------------- *) 24 | 25 | let rec groundterms cntms funcs n = 26 | if n = 0 then cntms else 27 | itlist (fun (f,m) l -> map (fun args -> Fn(f,args)) 28 | (groundtuples cntms funcs (n - 1) m) @ l) 29 | funcs [] 30 | 31 | and groundtuples cntms funcs n m = 32 | if m = 0 then if n = 0 then [[]] else [] else 33 | itlist (fun k l -> allpairs (fun h t -> h::t) 34 | (groundterms cntms funcs k) 35 | (groundtuples cntms funcs (n - k) (m - 1)) @ l) 36 | (0 -- n) [];; 37 | 38 | (* ------------------------------------------------------------------------- *) 39 | (* Iterate modifier "mfn" over ground terms till "tfn" fails. *) 40 | (* ------------------------------------------------------------------------- *) 41 | 42 | let rec herbloop mfn tfn fl0 cntms funcs fvs n fl tried tuples = 43 | print_string(string_of_int(length tried)^" ground instances tried; "^ 44 | string_of_int(length fl)^" items in list"); 45 | print_newline(); 46 | match tuples with 47 | [] -> let newtups = groundtuples cntms funcs n (length fvs) in 48 | herbloop mfn tfn fl0 cntms funcs fvs (n + 1) fl tried newtups 49 | | tup::tups -> 50 | let fl' = mfn fl0 (subst(fpf fvs tup)) fl in 51 | if not(tfn fl') then tup::tried else 52 | herbloop mfn tfn fl0 cntms funcs fvs n fl' (tup::tried) tups;; 53 | 54 | (* ------------------------------------------------------------------------- *) 55 | (* Hence a simple Gilmore-type procedure. *) 56 | (* ------------------------------------------------------------------------- *) 57 | 58 | let gilmore_loop = 59 | let mfn djs0 ifn djs = 60 | filter (non trivial) (distrib (image (image ifn) djs0) djs) in 61 | herbloop mfn (fun djs -> djs <> []);; 62 | 63 | let gilmore fm = 64 | let sfm = skolemize(Not(generalize fm)) in 65 | let fvs = fv sfm and consts,funcs = herbfuns sfm in 66 | let cntms = image (fun (c,_) -> Fn(c,[])) consts in 67 | length(gilmore_loop (simpdnf sfm) cntms funcs fvs 0 [[]] [] []);; 68 | 69 | (* ------------------------------------------------------------------------- *) 70 | (* First example and a little tracing. *) 71 | (* ------------------------------------------------------------------------- *) 72 | 73 | START_INTERACTIVE;; 74 | gilmore < P(y)>>;; 75 | 76 | let sfm = skolemize(Not < P(y)>>);; 77 | 78 | (* ------------------------------------------------------------------------- *) 79 | (* Quick example. *) 80 | (* ------------------------------------------------------------------------- *) 81 | 82 | let p24 = gilmore 83 | <<~(exists x. U(x) /\ Q(x)) /\ 84 | (forall x. P(x) ==> Q(x) \/ R(x)) /\ 85 | ~(exists x. P(x) ==> (exists x. Q(x))) /\ 86 | (forall x. Q(x) /\ R(x) ==> U(x)) 87 | ==> (exists x. P(x) /\ R(x))>>;; 88 | 89 | (* ------------------------------------------------------------------------- *) 90 | (* Slightly less easy example. *) 91 | (* ------------------------------------------------------------------------- *) 92 | 93 | let p45 = gilmore 94 | <<(forall x. P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) 95 | ==> (forall y. G(y) /\ H(x,y) ==> R(y))) /\ 96 | ~(exists y. L(y) /\ R(y)) /\ 97 | (exists x. P(x) /\ (forall y. H(x,y) ==> L(y)) /\ 98 | (forall y. G(y) /\ H(x,y) ==> J(x,y))) 99 | ==> (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;; 100 | END_INTERACTIVE;; 101 | 102 | (* ------------------------------------------------------------------------- *) 103 | (* Apparently intractable example. *) 104 | (* ------------------------------------------------------------------------- *) 105 | 106 | (********** 107 | 108 | let p20 = gilmore 109 | <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) 110 | ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;; 111 | 112 | **********) 113 | 114 | (* ------------------------------------------------------------------------- *) 115 | (* The Davis-Putnam procedure for first order logic. *) 116 | (* ------------------------------------------------------------------------- *) 117 | 118 | let dp_mfn cjs0 ifn cjs = union (image (image ifn) cjs0) cjs;; 119 | 120 | let dp_loop = herbloop dp_mfn dpll;; 121 | 122 | let davisputnam fm = 123 | let sfm = skolemize(Not(generalize fm)) in 124 | let fvs = fv sfm and consts,funcs = herbfuns sfm in 125 | let cntms = image (fun (c,_) -> Fn(c,[])) consts in 126 | length(dp_loop (simpcnf sfm) cntms funcs fvs 0 [] [] []);; 127 | 128 | (* ------------------------------------------------------------------------- *) 129 | (* Show how much better than the Gilmore procedure this can be. *) 130 | (* ------------------------------------------------------------------------- *) 131 | 132 | START_INTERACTIVE;; 133 | let p20 = davisputnam 134 | <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) 135 | ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;; 136 | END_INTERACTIVE;; 137 | 138 | (* ------------------------------------------------------------------------- *) 139 | (* Try to cut out useless instantiations in final result. *) 140 | (* ------------------------------------------------------------------------- *) 141 | 142 | let rec dp_refine cjs0 fvs dunno need = 143 | match dunno with 144 | [] -> need 145 | | cl::dknow -> 146 | let mfn = dp_mfn cjs0 ** subst ** fpf fvs in 147 | let need' = 148 | if dpll(itlist mfn (need @ dknow) []) then cl::need else need in 149 | dp_refine cjs0 fvs dknow need';; 150 | 151 | let dp_refine_loop cjs0 cntms funcs fvs n cjs tried tuples = 152 | let tups = dp_loop cjs0 cntms funcs fvs n cjs tried tuples in 153 | dp_refine cjs0 fvs tups [];; 154 | 155 | (* ------------------------------------------------------------------------- *) 156 | (* Show how few of the instances we really need. Hence unification! *) 157 | (* ------------------------------------------------------------------------- *) 158 | 159 | let davisputnam' fm = 160 | let sfm = skolemize(Not(generalize fm)) in 161 | let fvs = fv sfm and consts,funcs = herbfuns sfm in 162 | let cntms = image (fun (c,_) -> Fn(c,[])) consts in 163 | length(dp_refine_loop (simpcnf sfm) cntms funcs fvs 0 [] [] []);; 164 | 165 | START_INTERACTIVE;; 166 | let p36 = davisputnam' 167 | <<(forall x. exists y. P(x,y)) /\ 168 | (forall x. exists y. G(x,y)) /\ 169 | (forall x y. P(x,y) \/ G(x,y) 170 | ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z))) 171 | ==> (forall x. exists y. H(x,y))>>;; 172 | 173 | let p29 = davisputnam' 174 | <<(exists x. P(x)) /\ (exists x. G(x)) ==> 175 | ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=> 176 | (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;; 177 | END_INTERACTIVE;; 178 | -------------------------------------------------------------------------------- /code/OCaml/init.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Initialize theorem proving example code. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | #load "nums.cma";; (* For Ocaml 3.06 *) 8 | 9 | if let v = String.sub Sys.ocaml_version 0 4 in v >= "3.10" 10 | then (Topdirs.dir_directory "+camlp5"; 11 | Topdirs.dir_load Format.std_formatter "camlp5o.cma") 12 | else (Topdirs.dir_load Format.std_formatter "camlp4o.cma");; 13 | 14 | type dummy_interactive = START_INTERACTIVE | END_INTERACTIVE;; 15 | #use "initialization.ml";; 16 | #use "Quotexpander.ml";; 17 | #use "atp_interactive.ml";; 18 | -------------------------------------------------------------------------------- /code/OCaml/initialization.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Tweak OCaml default state ready for theorem proving code. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | Gc.set { (Gc.get()) with Gc.stack_limit = 16777216 };; (* Up the stack size *) 8 | Format.set_margin 72;; (* Reduce margins *) 9 | include Format;; (* Open formatting *) 10 | include Num;; (* Open bignums *) 11 | 12 | let print_num n = print_string(string_of_num n);; (* Avoid range limit *) 13 | START_INTERACTIVE;; 14 | #install_printer print_num;; (* when printing nums *) 15 | END_INTERACTIVE;; 16 | -------------------------------------------------------------------------------- /code/OCaml/interpolation.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Implementation/proof of the Craig-Robinson interpolation theorem. *) 3 | (* *) 4 | (* This is based on the proof in Kreisel & Krivine, which works very nicely *) 5 | (* in our context. *) 6 | (* *) 7 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 8 | (* ========================================================================= *) 9 | 10 | (* ------------------------------------------------------------------------- *) 11 | (* Interpolation for propositional logic. *) 12 | (* ------------------------------------------------------------------------- *) 13 | 14 | let pinterpolate p q = 15 | let orify a r = Or(psubst(a|=>False) r,psubst(a|=>True) r) in 16 | psimplify(itlist orify (subtract (atoms p) (atoms q)) p);; 17 | 18 | (* ------------------------------------------------------------------------- *) 19 | (* Relation-symbol interpolation for universal closed formulas. *) 20 | (* ------------------------------------------------------------------------- *) 21 | 22 | let urinterpolate p q = 23 | let fm = specialize(prenex(And(p,q))) in 24 | let fvs = fv fm and consts,funcs = herbfuns fm in 25 | let cntms = map (fun (c,_) -> Fn(c,[])) consts in 26 | let tups = dp_refine_loop (simpcnf fm) cntms funcs fvs 0 [] [] [] in 27 | let fmis = map (fun tup -> subst (fpf fvs tup) fm) tups in 28 | let ps,qs = unzip (map (fun (And(p,q)) -> p,q) fmis) in 29 | pinterpolate (list_conj(setify ps)) (list_conj(setify qs));; 30 | 31 | (* ------------------------------------------------------------------------- *) 32 | (* Example. *) 33 | (* ------------------------------------------------------------------------- *) 34 | 35 | START_INTERACTIVE;; 36 | let p = prenex 37 | <<(forall x. R(x,f(x))) /\ (forall x y. S(x,y) <=> R(x,y) \/ R(y,x))>> 38 | and q = prenex 39 | <<(forall x y z. S(x,y) /\ S(y,z) ==> T(x,z)) /\ ~T(0,0)>>;; 40 | 41 | let c = urinterpolate p q;; 42 | 43 | meson(Imp(p,c));; 44 | meson(Imp(q,Not c));; 45 | END_INTERACTIVE;; 46 | 47 | (* ------------------------------------------------------------------------- *) 48 | (* Pick the topmost terms starting with one of the given function symbols. *) 49 | (* ------------------------------------------------------------------------- *) 50 | 51 | let rec toptermt fns tm = 52 | match tm with 53 | Var x -> [] 54 | | Fn(f,args) -> if mem (f,length args) fns then [tm] 55 | else itlist (union ** toptermt fns) args [];; 56 | 57 | let topterms fns = atom_union 58 | (fun (R(p,args)) -> itlist (union ** toptermt fns) args []);; 59 | 60 | (* ------------------------------------------------------------------------- *) 61 | (* Interpolation for arbitrary universal formulas. *) 62 | (* ------------------------------------------------------------------------- *) 63 | 64 | let uinterpolate p q = 65 | let fp = functions p and fq = functions q in 66 | let rec simpinter tms n c = 67 | match tms with 68 | [] -> c 69 | | (Fn(f,args) as tm)::otms -> 70 | let v = "v_"^(string_of_int n) in 71 | let c' = replace (tm |=> Var v) c in 72 | let c'' = if mem (f,length args) fp 73 | then Exists(v,c') else Forall(v,c') in 74 | simpinter otms (n+1) c'' in 75 | let c = urinterpolate p q in 76 | let tts = topterms (union (subtract fp fq) (subtract fq fp)) c in 77 | let tms = sort (decreasing termsize) tts in 78 | simpinter tms 1 c;; 79 | 80 | (* ------------------------------------------------------------------------- *) 81 | (* The same example now gives a true interpolant. *) 82 | (* ------------------------------------------------------------------------- *) 83 | 84 | START_INTERACTIVE;; 85 | let c = uinterpolate p q;; 86 | 87 | meson(Imp(p,c));; 88 | meson(Imp(q,Not c));; 89 | END_INTERACTIVE;; 90 | 91 | (* ------------------------------------------------------------------------- *) 92 | (* Now lift to arbitrary formulas with no common free variables. *) 93 | (* ------------------------------------------------------------------------- *) 94 | 95 | let cinterpolate p q = 96 | let fm = nnf(And(p,q)) in 97 | let efm = itlist mk_exists (fv fm) fm 98 | and fns = map fst (functions fm) in 99 | let And(p',q'),_ = skolem efm fns in 100 | uinterpolate p' q';; 101 | 102 | (* ------------------------------------------------------------------------- *) 103 | (* Now to completely arbitrary formulas. *) 104 | (* ------------------------------------------------------------------------- *) 105 | 106 | let interpolate p q = 107 | let vs = map (fun v -> Var v) (intersect (fv p) (fv q)) 108 | and fns = functions (And(p,q)) in 109 | let n = itlist (max_varindex "c_" ** fst) fns (Int 0) +/ Int 1 in 110 | let cs = map (fun i -> Fn("c_"^(string_of_num i),[])) 111 | (n---(n+/Int(length vs-1))) in 112 | let fn_vc = fpf vs cs and fn_cv = fpf cs vs in 113 | let p' = replace fn_vc p and q' = replace fn_vc q in 114 | replace fn_cv (cinterpolate p' q');; 115 | 116 | (* ------------------------------------------------------------------------- *) 117 | (* Example. *) 118 | (* ------------------------------------------------------------------------- *) 119 | 120 | START_INTERACTIVE;; 121 | let p = 122 | <<(forall x. exists y. R(x,y)) /\ 123 | (forall x y. S(v,x,y) <=> R(x,y) \/ R(y,x))>> 124 | and q = 125 | <<(forall x y z. S(v,x,y) /\ S(v,y,z) ==> T(x,z)) /\ 126 | (exists u. ~T(u,u))>>;; 127 | 128 | let c = interpolate p q;; 129 | 130 | meson(Imp(p,c));; 131 | meson(Imp(q,Not c));; 132 | END_INTERACTIVE;; 133 | 134 | (* ------------------------------------------------------------------------- *) 135 | (* Lift to logic with equality. *) 136 | (* ------------------------------------------------------------------------- *) 137 | 138 | let einterpolate p q = 139 | let p' = equalitize p and q' = equalitize q in 140 | let p'' = if p' = p then p else And(fst(dest_imp p'),p) 141 | and q'' = if q' = q then q else And(fst(dest_imp q'),q) in 142 | interpolate p'' q'';; 143 | 144 | (* ------------------------------------------------------------------------- *) 145 | (* More examples, not in the text. *) 146 | (* ------------------------------------------------------------------------- *) 147 | 148 | START_INTERACTIVE;; 149 | let p = <<(p ==> q /\ r)>> 150 | and q = <<~((q ==> p) ==> s ==> (p <=> q))>>;; 151 | 152 | let c = interpolate p q;; 153 | 154 | tautology(Imp(And(p,q),False));; 155 | 156 | tautology(Imp(p,c));; 157 | tautology(Imp(q,Not c));; 158 | 159 | (* ------------------------------------------------------------------------- *) 160 | (* A more interesting example. *) 161 | (* ------------------------------------------------------------------------- *) 162 | 163 | let p = <<(forall x. exists y. R(x,y)) /\ 164 | (forall x y. S(x,y) <=> R(x,y) \/ R(y,x))>> 165 | and q = <<(forall x y z. S(x,y) /\ S(y,z) ==> T(x,z)) /\ ~T(u,u)>>;; 166 | 167 | meson(Imp(And(p,q),False));; 168 | 169 | let c = interpolate p q;; 170 | 171 | meson(Imp(p,c));; 172 | meson(Imp(q,Not c));; 173 | 174 | (* ------------------------------------------------------------------------- *) 175 | (* A variant where u is free in both parts. *) 176 | (* ------------------------------------------------------------------------- *) 177 | 178 | let p = <<(forall x. exists y. R(x,y)) /\ 179 | (forall x y. S(x,y) <=> R(x,y) \/ R(y,x)) /\ 180 | (forall v. R(u,v) ==> Q(v,u))>> 181 | and q = <<(forall x y z. S(x,y) /\ S(y,z) ==> T(x,z)) /\ ~T(u,u)>>;; 182 | 183 | meson(Imp(And(p,q),False));; 184 | 185 | let c = interpolate p q;; 186 | meson(Imp(p,c));; 187 | meson(Imp(q,Not c));; 188 | 189 | (* ------------------------------------------------------------------------- *) 190 | (* Way of generating examples quite easily (see K&K exercises). *) 191 | (* ------------------------------------------------------------------------- *) 192 | 193 | let test_interp fm = 194 | let p = generalize(skolemize fm) 195 | and q = generalize(skolemize(Not fm)) in 196 | let c = interpolate p q in 197 | meson(Imp(And(p,q),False)); meson(Imp(p,c)); meson(Imp(q,Not c)); c;; 198 | 199 | test_interp < exists y. forall z. P(z) ==> Q(y)>>;; 200 | 201 | test_interp < P(x,y,z,a)>>;; 203 | 204 | (* ------------------------------------------------------------------------- *) 205 | (* Hintikka's examples. *) 206 | (* ------------------------------------------------------------------------- *) 207 | 208 | let p = <> 209 | and q = <<(forall y. L(b,y) ==> m = y) /\ ~(m = b)>>;; 210 | 211 | let c = einterpolate p q;; 212 | 213 | meson(Imp(p,c));; 214 | meson(Imp(q,Not c));; 215 | 216 | let p = 217 | <<(forall x. A(x) /\ C(x) ==> B(x)) /\ (forall x. D(x) \/ ~D(x) ==> C(x))>> 218 | and q = 219 | <<~(forall x. E(x) ==> A(x) ==> B(x))>>;; 220 | 221 | let c = interpolate p q;; 222 | meson(Imp(p,c));; 223 | meson(Imp(q,Not c));; 224 | END_INTERACTIVE;; 225 | -------------------------------------------------------------------------------- /code/OCaml/intro.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Simple algebraic expression example from the introductory chapter. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | type expression = 8 | Var of string 9 | | Const of int 10 | | Add of expression * expression 11 | | Mul of expression * expression;; 12 | 13 | (* ------------------------------------------------------------------------- *) 14 | (* Trivial example of using the type constructors. *) 15 | (* ------------------------------------------------------------------------- *) 16 | 17 | START_INTERACTIVE;; 18 | Add(Mul(Const 2,Var "x"),Var "y");; 19 | END_INTERACTIVE;; 20 | 21 | (* ------------------------------------------------------------------------- *) 22 | (* Simplification example. *) 23 | (* ------------------------------------------------------------------------- *) 24 | 25 | let simplify1 expr = 26 | match expr with 27 | Add(Const(m),Const(n)) -> Const(m + n) 28 | | Mul(Const(m),Const(n)) -> Const(m * n) 29 | | Add(Const(0),x) -> x 30 | | Add(x,Const(0)) -> x 31 | | Mul(Const(0),x) -> Const(0) 32 | | Mul(x,Const(0)) -> Const(0) 33 | | Mul(Const(1),x) -> x 34 | | Mul(x,Const(1)) -> x 35 | | _ -> expr;; 36 | 37 | let rec simplify expr = 38 | match expr with 39 | Add(e1,e2) -> simplify1(Add(simplify e1,simplify e2)) 40 | | Mul(e1,e2) -> simplify1(Mul(simplify e1,simplify e2)) 41 | | _ -> simplify1 expr;; 42 | 43 | (* ------------------------------------------------------------------------- *) 44 | (* Example. *) 45 | (* ------------------------------------------------------------------------- *) 46 | START_INTERACTIVE;; 47 | let e = Add(Mul(Add(Mul(Const(0),Var "x"),Const(1)),Const(3)), 48 | Const(12));; 49 | simplify e;; 50 | END_INTERACTIVE;; 51 | 52 | (* ------------------------------------------------------------------------- *) 53 | (* Lexical analysis. *) 54 | (* ------------------------------------------------------------------------- *) 55 | 56 | let matches s = let chars = explode s in fun c -> mem c chars;; 57 | 58 | let space = matches " \t\n\r" 59 | and punctuation = matches "()[]{}," 60 | and symbolic = matches "~`!@#$%^&*-+=|\\:;<>.?/" 61 | and numeric = matches "0123456789" 62 | and alphanumeric = matches 63 | "abcdefghijklmnopqrstuvwxyz_'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";; 64 | 65 | let rec lexwhile prop inp = 66 | match inp with 67 | c::cs when prop c -> let tok,rest = lexwhile prop cs in c^tok,rest 68 | | _ -> "",inp;; 69 | 70 | let rec lex inp = 71 | match snd(lexwhile space inp) with 72 | [] -> [] 73 | | c::cs -> let prop = if alphanumeric(c) then alphanumeric 74 | else if symbolic(c) then symbolic 75 | else fun c -> false in 76 | let toktl,rest = lexwhile prop cs in 77 | (c^toktl)::lex rest;; 78 | 79 | START_INTERACTIVE;; 80 | lex(explode "2*((var_1 + x') + 11)");; 81 | lex(explode "if (*p1-- == *p2++) then f() else g()");; 82 | END_INTERACTIVE;; 83 | 84 | (* ------------------------------------------------------------------------- *) 85 | (* Parsing. *) 86 | (* ------------------------------------------------------------------------- *) 87 | 88 | let rec parse_expression i = 89 | match parse_product i with 90 | e1,"+"::i1 -> let e2,i2 = parse_expression i1 in Add(e1,e2),i2 91 | | e1,i1 -> e1,i1 92 | 93 | and parse_product i = 94 | match parse_atom i with 95 | e1,"*"::i1 -> let e2,i2 = parse_product i1 in Mul(e1,e2),i2 96 | | e1,i1 -> e1,i1 97 | 98 | and parse_atom i = 99 | match i with 100 | [] -> failwith "Expected an expression at end of input" 101 | | "("::i1 -> (match parse_expression i1 with 102 | e2,")"::i2 -> e2,i2 103 | | _ -> failwith "Expected closing bracket") 104 | | tok::i1 -> if forall numeric (explode tok) 105 | then Const(int_of_string tok),i1 106 | else Var(tok),i1;; 107 | 108 | (* ------------------------------------------------------------------------- *) 109 | (* Generic function to impose lexing and exhaustion checking on a parser. *) 110 | (* ------------------------------------------------------------------------- *) 111 | 112 | let make_parser pfn s = 113 | let expr,rest = pfn (lex(explode s)) in 114 | if rest = [] then expr else failwith "Unparsed input";; 115 | 116 | (* ------------------------------------------------------------------------- *) 117 | (* Our parser. *) 118 | (* ------------------------------------------------------------------------- *) 119 | 120 | let default_parser = make_parser parse_expression;; 121 | 122 | START_INTERACTIVE;; 123 | default_parser "x + 1";; 124 | 125 | (* ------------------------------------------------------------------------- *) 126 | (* Demonstrate automatic installation. *) 127 | (* ------------------------------------------------------------------------- *) 128 | 129 | <<(x1 + x2 + x3) * (1 + 2 + 3 * x + y)>>;; 130 | END_INTERACTIVE;; 131 | 132 | (* ------------------------------------------------------------------------- *) 133 | (* Conservatively bracketing first attempt at printer. *) 134 | (* ------------------------------------------------------------------------- *) 135 | 136 | let rec string_of_exp e = 137 | match e with 138 | Var s -> s 139 | | Const n -> string_of_int n 140 | | Add(e1,e2) -> "("^(string_of_exp e1)^" + "^(string_of_exp e2)^")" 141 | | Mul(e1,e2) -> "("^(string_of_exp e1)^" * "^(string_of_exp e2)^")";; 142 | 143 | (* ------------------------------------------------------------------------- *) 144 | (* Examples. *) 145 | (* ------------------------------------------------------------------------- *) 146 | 147 | START_INTERACTIVE;; 148 | string_of_exp <>;; 149 | END_INTERACTIVE;; 150 | 151 | (* ------------------------------------------------------------------------- *) 152 | (* Somewhat better attempt. *) 153 | (* ------------------------------------------------------------------------- *) 154 | 155 | let rec string_of_exp pr e = 156 | match e with 157 | Var s -> s 158 | | Const n -> string_of_int n 159 | | Add(e1,e2) -> 160 | let s = (string_of_exp 3 e1)^" + "^(string_of_exp 2 e2) in 161 | if 2 < pr then "("^s^")" else s 162 | | Mul(e1,e2) -> 163 | let s = (string_of_exp 5 e1)^" * "^(string_of_exp 4 e2) in 164 | if 4 < pr then "("^s^")" else s;; 165 | 166 | (* ------------------------------------------------------------------------- *) 167 | (* Install it. *) 168 | (* ------------------------------------------------------------------------- *) 169 | 170 | let print_exp e = Format.print_string ("<<"^string_of_exp 0 e^">>");; 171 | 172 | #install_printer print_exp;; 173 | 174 | (* ------------------------------------------------------------------------- *) 175 | (* Examples. *) 176 | (* ------------------------------------------------------------------------- *) 177 | 178 | START_INTERACTIVE;; 179 | <>;; 180 | <<(x + 3) * y>>;; 181 | <<1 + 2 + 3>>;; 182 | <<((1 + 2) + 3) + 4>>;; 183 | END_INTERACTIVE;; 184 | 185 | (* ------------------------------------------------------------------------- *) 186 | (* Example shows the problem. *) 187 | (* ------------------------------------------------------------------------- *) 188 | 189 | START_INTERACTIVE;; 190 | <<(x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10) * 191 | (y1 + y2 + y3 + y4 + y5 + y6 + y7 + y8 + y9 + y10)>>;; 192 | END_INTERACTIVE;; 193 | -------------------------------------------------------------------------------- /code/OCaml/lcf.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* LCF-style basis for Tarski-style Hilbert system of first order logic. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* Basic first order deductive system. *) 9 | (* *) 10 | (* This is based on Tarski's trick for avoiding use of a substitution *) 11 | (* primitive. It seems about the simplest possible system we could use. *) 12 | (* *) 13 | (* if |- p ==> q and |- p then |- q *) 14 | (* if |- p then |- forall x. p *) 15 | (* *) 16 | (* |- p ==> (q ==> p) *) 17 | (* |- (p ==> q ==> r) ==> (p ==> q) ==> (p ==> r) *) 18 | (* |- ((p ==> false) ==> false) ==> p *) 19 | (* |- (forall x. p ==> q) ==> (forall x. p) ==> (forall x. q) *) 20 | (* |- p ==> forall x. p [x not free in p] *) 21 | (* |- exists x. x = t [x not free in t] *) 22 | (* |- t = t *) 23 | (* |- s1 = t1 ==> ... ==> sn = tn ==> f(s1,..,sn) = f(t1,..,tn) *) 24 | (* |- s1 = t1 ==> ... ==> sn = tn ==> P(s1,..,sn) ==> P(t1,..,tn) *) 25 | (* *) 26 | (* |- (p <=> q) ==> p ==> q *) 27 | (* |- (p <=> q) ==> q ==> p *) 28 | (* |- (p ==> q) ==> (q ==> p) ==> (p <=> q) *) 29 | (* |- true <=> (false ==> false) *) 30 | (* |- ~p <=> (p ==> false) *) 31 | (* |- p /\ q <=> (p ==> q ==> false) ==> false *) 32 | (* |- p \/ q <=> ~(~p /\ ~q) *) 33 | (* |- (exists x. p) <=> ~(forall x. ~p) *) 34 | (* ------------------------------------------------------------------------- *) 35 | 36 | module type Proofsystem = 37 | sig type thm 38 | val modusponens : thm -> thm -> thm 39 | val gen : string -> thm -> thm 40 | val axiom_addimp : fol formula -> fol formula -> thm 41 | val axiom_distribimp : 42 | fol formula -> fol formula -> fol formula -> thm 43 | val axiom_doubleneg : fol formula -> thm 44 | val axiom_allimp : string -> fol formula -> fol formula -> thm 45 | val axiom_impall : string -> fol formula -> thm 46 | val axiom_existseq : string -> term -> thm 47 | val axiom_eqrefl : term -> thm 48 | val axiom_funcong : string -> term list -> term list -> thm 49 | val axiom_predcong : string -> term list -> term list -> thm 50 | val axiom_iffimp1 : fol formula -> fol formula -> thm 51 | val axiom_iffimp2 : fol formula -> fol formula -> thm 52 | val axiom_impiff : fol formula -> fol formula -> thm 53 | val axiom_true : thm 54 | val axiom_not : fol formula -> thm 55 | val axiom_and : fol formula -> fol formula -> thm 56 | val axiom_or : fol formula -> fol formula -> thm 57 | val axiom_exists : string -> fol formula -> thm 58 | val concl : thm -> fol formula 59 | end;; 60 | 61 | (* ------------------------------------------------------------------------- *) 62 | (* Auxiliary functions. *) 63 | (* ------------------------------------------------------------------------- *) 64 | 65 | let rec occurs_in s t = 66 | s = t or 67 | match t with 68 | Var y -> false 69 | | Fn(f,args) -> exists (occurs_in s) args;; 70 | 71 | let rec free_in t fm = 72 | match fm with 73 | False|True -> false 74 | | Atom(R(p,args)) -> exists (occurs_in t) args 75 | | Not(p) -> free_in t p 76 | | And(p,q)|Or(p,q)|Imp(p,q)|Iff(p,q) -> free_in t p or free_in t q 77 | | Forall(y,p)|Exists(y,p) -> not(occurs_in (Var y) t) & free_in t p;; 78 | 79 | (* ------------------------------------------------------------------------- *) 80 | (* Implementation of the abstract data type of theorems. *) 81 | (* ------------------------------------------------------------------------- *) 82 | 83 | module Proven : Proofsystem = 84 | struct 85 | type thm = fol formula 86 | let modusponens pq p = 87 | match pq with 88 | Imp(p',q) when p = p' -> q 89 | | _ -> failwith "modusponens" 90 | let gen x p = Forall(x,p) 91 | let axiom_addimp p q = Imp(p,Imp(q,p)) 92 | let axiom_distribimp p q r = 93 | Imp(Imp(p,Imp(q,r)),Imp(Imp(p,q),Imp(p,r))) 94 | let axiom_doubleneg p = Imp(Imp(Imp(p,False),False),p) 95 | let axiom_allimp x p q = 96 | Imp(Forall(x,Imp(p,q)),Imp(Forall(x,p),Forall(x,q))) 97 | let axiom_impall x p = 98 | if not (free_in (Var x) p) then Imp(p,Forall(x,p)) 99 | else failwith "axiom_impall: variable free in formula" 100 | let axiom_existseq x t = 101 | if not (occurs_in (Var x) t) then Exists(x,mk_eq (Var x) t) 102 | else failwith "axiom_existseq: variable free in term" 103 | let axiom_eqrefl t = mk_eq t t 104 | let axiom_funcong f lefts rights = 105 | itlist2 (fun s t p -> Imp(mk_eq s t,p)) lefts rights 106 | (mk_eq (Fn(f,lefts)) (Fn(f,rights))) 107 | let axiom_predcong p lefts rights = 108 | itlist2 (fun s t p -> Imp(mk_eq s t,p)) lefts rights 109 | (Imp(Atom(R(p,lefts)),Atom(R(p,rights)))) 110 | let axiom_iffimp1 p q = Imp(Iff(p,q),Imp(p,q)) 111 | let axiom_iffimp2 p q = Imp(Iff(p,q),Imp(q,p)) 112 | let axiom_impiff p q = Imp(Imp(p,q),Imp(Imp(q,p),Iff(p,q))) 113 | let axiom_true = Iff(True,Imp(False,False)) 114 | let axiom_not p = Iff(Not p,Imp(p,False)) 115 | let axiom_and p q = Iff(And(p,q),Imp(Imp(p,Imp(q,False)),False)) 116 | let axiom_or p q = Iff(Or(p,q),Not(And(Not(p),Not(q)))) 117 | let axiom_exists x p = Iff(Exists(x,p),Not(Forall(x,Not p))) 118 | let concl c = c 119 | end;; 120 | 121 | (* ------------------------------------------------------------------------- *) 122 | (* A printer for theorems. *) 123 | (* ------------------------------------------------------------------------- *) 124 | 125 | include Proven;; 126 | 127 | let print_thm th = 128 | open_box 0; 129 | print_string "|-"; print_space(); 130 | open_box 0; print_formula print_atom (concl th); close_box(); 131 | close_box();; 132 | 133 | #install_printer print_thm;; 134 | -------------------------------------------------------------------------------- /code/OCaml/make.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Load in theorem proving example code. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | #load "nums.cma";; (* For Ocaml 3.06 *) 8 | 9 | if let v = String.sub Sys.ocaml_version 0 4 in v >= "3.10" 10 | then (Topdirs.dir_directory "+camlp5"; 11 | Topdirs.dir_load Format.std_formatter "camlp5o.cma") 12 | else (Topdirs.dir_load Format.std_formatter "camlp4o.cma");; 13 | 14 | (* ------------------------------------------------------------------------- *) 15 | (* Dummy so we can just do #use. *) 16 | (* ------------------------------------------------------------------------- *) 17 | 18 | type dummy_interactive = START_INTERACTIVE | END_INTERACTIVE;; 19 | 20 | (* ------------------------------------------------------------------------- *) 21 | (* Various small tweaks to OCAML's default state. *) 22 | (* ------------------------------------------------------------------------- *) 23 | 24 | #use "initialization.ml";; 25 | 26 | (* ------------------------------------------------------------------------- *) 27 | (* Use the quotation expander. *) 28 | (* ------------------------------------------------------------------------- *) 29 | 30 | #use "Quotexpander.ml";; 31 | 32 | (* ------------------------------------------------------------------------- *) 33 | (* Basic background. *) 34 | (* ------------------------------------------------------------------------- *) 35 | 36 | #use "lib.ml";; (* Utility functions *) 37 | #use "intro.ml";; (* Trivial example from the introduction *) 38 | 39 | (* ------------------------------------------------------------------------- *) 40 | (* General type of formulas, parser and printer (used for prop and FOL). *) 41 | (* ------------------------------------------------------------------------- *) 42 | 43 | #use "formulas.ml";; 44 | 45 | (* ------------------------------------------------------------------------- *) 46 | (* Propositional logic. *) 47 | (* ------------------------------------------------------------------------- *) 48 | 49 | #use "prop.ml";; (* Basic propositional logic stuff *) 50 | #use "propexamples.ml";; (* Generate tautologies *) 51 | #use "defcnf.ml";; (* Definitional CNF *) 52 | #use "dp.ml";; (* Davis-Putnam procedure *) 53 | #use "stal.ml";; (* Stalmarck's algorithm *) 54 | #use "bdd.ml";; (* Binary decision diagrams *) 55 | 56 | (* ------------------------------------------------------------------------- *) 57 | (* First order logic. *) 58 | (* ------------------------------------------------------------------------- *) 59 | 60 | #use "fol.ml";; (* Basic first order logic stuff *) 61 | #use "skolem.ml";; (* Prenex and Skolem normal forms *) 62 | #use "herbrand.ml";; (* Herbrand theorem and mechanization *) 63 | #use "unif.ml";; (* Unification algorithm *) 64 | #use "tableaux.ml";; (* Tableaux *) 65 | #use "resolution.ml";; (* Resolution *) 66 | #use "prolog.ml";; (* Horn clauses and Prolog *) 67 | #use "meson.ml";; (* MESON-type model elimination *) 68 | #use "skolems.ml";; (* Skolemizing a set of formulas (theoretical) *) 69 | 70 | (* ------------------------------------------------------------------------- *) 71 | (* Equality handling. *) 72 | (* ------------------------------------------------------------------------- *) 73 | 74 | #use "equal.ml";; (* Naive equality axiomatization *) 75 | #use "cong.ml";; (* Congruence closure *) 76 | #use "rewrite.ml";; (* Rewriting *) 77 | #use "order.ml";; (* Simple term orderings including LPO *) 78 | #use "completion.ml";; (* Completion *) 79 | #use "eqelim.ml";; (* Equality elimination: Brand xform etc. *) 80 | #use "paramodulation.ml";; (* Paramodulation. *) 81 | 82 | (* ------------------------------------------------------------------------- *) 83 | (* Decidable problems. *) 84 | (* ------------------------------------------------------------------------- *) 85 | 86 | #use "decidable.ml";; (* Some decidable subsets of first-order logic *) 87 | #use "qelim.ml";; (* Quantifier elimination basics *) 88 | #use "cooper.ml";; (* Cooper's algorithm for Presburger arith. *) 89 | #use "complex.ml";; (* Complex quantifier elimination *) 90 | #use "real.ml";; (* Real quantifier elimination *) 91 | #use "grobner.ml";; (* Grobner bases *) 92 | #use "geom.ml";; (* Geometry theorem proving *) 93 | #use "interpolation.ml";; (* Constructive Craig/Robinson interpolation *) 94 | #use "combining.ml";; (* Combined decision procedure *) 95 | 96 | (* ------------------------------------------------------------------------- *) 97 | (* Interactive theorem proving. *) 98 | (* ------------------------------------------------------------------------- *) 99 | 100 | #use "lcf.ml";; (* LCF-style system for first-order logic *) 101 | #use "lcfprop.ml";; (* Propositional logic by inference *) 102 | #use "folderived.ml";; (* First-order specialization etc. *) 103 | #use "lcffol.ml";; (* LCF implementation of first-order tableaux *) 104 | #use "tactics.ml";; (* Tactics and Mizar-style proofs *) 105 | 106 | (* ------------------------------------------------------------------------- *) 107 | (* Limitations. *) 108 | (* ------------------------------------------------------------------------- *) 109 | 110 | #use "limitations.ml";; (* Various Goedelian-type stuff *) 111 | -------------------------------------------------------------------------------- /code/OCaml/order.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Term orderings. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | let rec termsize tm = 8 | match tm with 9 | Var x -> 1 10 | | Fn(f,args) -> itlist (fun t n -> termsize t + n) args 1;; 11 | 12 | (* ------------------------------------------------------------------------- *) 13 | (* This fails the rewrite properties. *) 14 | (* ------------------------------------------------------------------------- *) 15 | 16 | START_INTERACTIVE;; 17 | let s = <<|f(x,x,x)|>> and t = <<|g(x,y)|>>;; 18 | 19 | termsize s > termsize t;; 20 | 21 | let i = ("y" |=> <<|f(x,x,x)|>>);; 22 | 23 | termsize (tsubst i s) > termsize (tsubst i t);; 24 | END_INTERACTIVE;; 25 | 26 | (* ------------------------------------------------------------------------- *) 27 | (* Lexicographic path order. *) 28 | (* ------------------------------------------------------------------------- *) 29 | 30 | let rec lexord ord l1 l2 = 31 | match (l1,l2) with 32 | (h1::t1,h2::t2) -> if ord h1 h2 then length t1 = length t2 33 | else h1 = h2 & lexord ord t1 t2 34 | | _ -> false;; 35 | 36 | let rec lpo_gt w s t = 37 | match (s,t) with 38 | (_,Var x) -> 39 | not(s = t) & mem x (fvt s) 40 | | (Fn(f,fargs),Fn(g,gargs)) -> 41 | exists (fun si -> lpo_ge w si t) fargs or 42 | forall (lpo_gt w s) gargs & 43 | (f = g & lexord (lpo_gt w) fargs gargs or 44 | w (f,length fargs) (g,length gargs)) 45 | | _ -> false 46 | 47 | and lpo_ge w s t = (s = t) or lpo_gt w s t;; 48 | 49 | (* ------------------------------------------------------------------------- *) 50 | (* More convenient way of specifying weightings. *) 51 | (* ------------------------------------------------------------------------- *) 52 | 53 | let weight lis (f,n) (g,m) = if f = g then n > m else earlier lis g f;; 54 | -------------------------------------------------------------------------------- /code/OCaml/paramodulation.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Paramodulation. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* Find paramodulations with l = r inside a literal fm. *) 9 | (* ------------------------------------------------------------------------- *) 10 | 11 | let rec overlapl (l,r) fm rfn = 12 | match fm with 13 | Atom(R(f,args)) -> listcases (overlaps (l,r)) 14 | (fun i a -> rfn i (Atom(R(f,a)))) args [] 15 | | Not(p) -> overlapl (l,r) p (fun i p -> rfn i (Not(p))) 16 | | _ -> failwith "overlapl: not a literal";; 17 | 18 | (* ------------------------------------------------------------------------- *) 19 | (* Now find paramodulations within a clause. *) 20 | (* ------------------------------------------------------------------------- *) 21 | 22 | let overlapc (l,r) cl rfn acc = listcases (overlapl (l,r)) rfn cl acc;; 23 | 24 | (* ------------------------------------------------------------------------- *) 25 | (* Overall paramodulation of ocl by equations in pcl. *) 26 | (* ------------------------------------------------------------------------- *) 27 | 28 | let paramodulate pcl ocl = 29 | itlist (fun eq -> let pcl' = subtract pcl [eq] in 30 | let (l,r) = dest_eq eq 31 | and rfn i ocl' = image (subst i) (pcl' @ ocl') in 32 | overlapc (l,r) ocl rfn ** overlapc (r,l) ocl rfn) 33 | (filter is_eq pcl) [];; 34 | 35 | let para_clauses cls1 cls2 = 36 | let cls1' = rename "x" cls1 and cls2' = rename "y" cls2 in 37 | paramodulate cls1' cls2' @ paramodulate cls2' cls1';; 38 | 39 | (* ------------------------------------------------------------------------- *) 40 | (* Incorporation into resolution loop. *) 41 | (* ------------------------------------------------------------------------- *) 42 | 43 | let rec paraloop (used,unused) = 44 | match unused with 45 | [] -> failwith "No proof found" 46 | | cls::ros -> 47 | print_string(string_of_int(length used) ^ " used; "^ 48 | string_of_int(length unused) ^ " unused."); 49 | print_newline(); 50 | let used' = insert cls used in 51 | let news = 52 | itlist (@) (mapfilter (resolve_clauses cls) used') 53 | (itlist (@) (mapfilter (para_clauses cls) used') []) in 54 | if mem [] news then true else 55 | paraloop(used',itlist (incorporate cls) news ros);; 56 | 57 | let pure_paramodulation fm = 58 | paraloop([],[mk_eq (Var "x") (Var "x")]:: 59 | simpcnf(specialize(pnf fm)));; 60 | 61 | let paramodulation fm = 62 | let fm1 = askolemize(Not(generalize fm)) in 63 | map (pure_paramodulation ** list_conj) (simpdnf fm1);; 64 | 65 | (* ------------------------------------------------------------------------- *) 66 | (* Test. *) 67 | (* ------------------------------------------------------------------------- *) 68 | 69 | START_INTERACTIVE;; 70 | paramodulation 71 | <<(forall x. f(f(x)) = f(x)) /\ (forall x. exists y. f(y) = x) 72 | ==> forall x. f(x) = x>>;; 73 | END_INTERACTIVE;; 74 | -------------------------------------------------------------------------------- /code/OCaml/prolog.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Backchaining procedure for Horn clauses, and toy Prolog implementation. *) 3 | (* ========================================================================= *) 4 | 5 | (* ------------------------------------------------------------------------- *) 6 | (* Rename a rule. *) 7 | (* ------------------------------------------------------------------------- *) 8 | 9 | let renamerule k (asm,c) = 10 | let fvs = fv(list_conj(c::asm)) in 11 | let n = length fvs in 12 | let vvs = map (fun i -> "_" ^ string_of_int i) (k -- (k+n-1)) in 13 | let inst = subst(fpf fvs (map (fun x -> Var x) vvs)) in 14 | (map inst asm,inst c),k+n;; 15 | 16 | (* ------------------------------------------------------------------------- *) 17 | (* Basic prover for Horn clauses based on backchaining with unification. *) 18 | (* ------------------------------------------------------------------------- *) 19 | 20 | let rec backchain rules n k env goals = 21 | match goals with 22 | [] -> env 23 | | g::gs -> 24 | if n = 0 then failwith "Too deep" else 25 | tryfind (fun rule -> 26 | let (a,c),k' = renamerule k rule in 27 | backchain rules (n - 1) k' (unify_literals env (c,g)) (a @ gs)) 28 | rules;; 29 | 30 | let hornify cls = 31 | let pos,neg = partition positive cls in 32 | if length pos > 1 then failwith "non-Horn clause" 33 | else (map negate neg,if pos = [] then False else hd pos);; 34 | 35 | let hornprove fm = 36 | let rules = map hornify (simpcnf(skolemize(Not(generalize fm)))) in 37 | deepen (fun n -> backchain rules n 0 undefined [False],n) 0;; 38 | 39 | (* ------------------------------------------------------------------------- *) 40 | (* A Horn example. *) 41 | (* ------------------------------------------------------------------------- *) 42 | 43 | START_INTERACTIVE;; 44 | let p32 = hornprove 45 | <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\ 46 | (forall x. Q(x) /\ H(x) ==> J(x)) /\ 47 | (forall x. R(x) ==> H(x)) 48 | ==> (forall x. P(x) /\ R(x) ==> J(x))>>;; 49 | 50 | (* ------------------------------------------------------------------------- *) 51 | (* A non-Horn example. *) 52 | (* ------------------------------------------------------------------------- *) 53 | 54 | (**************** 55 | 56 | hornprove <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;; 57 | 58 | **********) 59 | END_INTERACTIVE;; 60 | 61 | (* ------------------------------------------------------------------------- *) 62 | (* Parsing rules in a Prolog-like syntax. *) 63 | (* ------------------------------------------------------------------------- *) 64 | 65 | let parserule s = 66 | let c,rest = 67 | parse_formula (parse_infix_atom,parse_atom) [] (lex(explode s)) in 68 | let asm,rest1 = 69 | if rest <> [] & hd rest = ":-" 70 | then parse_list "," 71 | (parse_formula (parse_infix_atom,parse_atom) []) (tl rest) 72 | else [],rest in 73 | if rest1 = [] then (asm,c) else failwith "Extra material after rule";; 74 | 75 | (* ------------------------------------------------------------------------- *) 76 | (* Prolog interpreter: just use depth-first search not iterative deepening. *) 77 | (* ------------------------------------------------------------------------- *) 78 | 79 | let simpleprolog rules gl = 80 | backchain (map parserule rules) (-1) 0 undefined [parse gl];; 81 | 82 | (* ------------------------------------------------------------------------- *) 83 | (* Ordering example. *) 84 | (* ------------------------------------------------------------------------- *) 85 | 86 | START_INTERACTIVE;; 87 | let lerules = ["0 <= X"; "S(X) <= S(Y) :- X <= Y"];; 88 | 89 | simpleprolog lerules "S(S(0)) <= S(S(S(0)))";; 90 | 91 | (*** simpleprolog lerules "S(S(0)) <= S(0)";; 92 | ***) 93 | 94 | let env = simpleprolog lerules "S(S(0)) <= X";; 95 | apply env "X";; 96 | END_INTERACTIVE;; 97 | 98 | (* ------------------------------------------------------------------------- *) 99 | (* With instantiation collection to produce a more readable result. *) 100 | (* ------------------------------------------------------------------------- *) 101 | 102 | let prolog rules gl = 103 | let i = solve(simpleprolog rules gl) in 104 | mapfilter (fun x -> Atom(R("=",[Var x; apply i x]))) (fv(parse gl));; 105 | 106 | (* ------------------------------------------------------------------------- *) 107 | (* Example again. *) 108 | (* ------------------------------------------------------------------------- *) 109 | 110 | START_INTERACTIVE;; 111 | prolog lerules "S(S(0)) <= X";; 112 | 113 | (* ------------------------------------------------------------------------- *) 114 | (* Append example, showing symmetry between inputs and outputs. *) 115 | (* ------------------------------------------------------------------------- *) 116 | 117 | let appendrules = 118 | ["append(nil,L,L)"; "append(H::T,L,H::A) :- append(T,L,A)"];; 119 | 120 | prolog appendrules "append(1::2::nil,3::4::nil,Z)";; 121 | 122 | prolog appendrules "append(1::2::nil,Y,1::2::3::4::nil)";; 123 | 124 | prolog appendrules "append(X,3::4::nil,1::2::3::4::nil)";; 125 | 126 | prolog appendrules "append(X,Y,1::2::3::4::nil)";; 127 | 128 | (* ------------------------------------------------------------------------- *) 129 | (* However this way round doesn't work. *) 130 | (* ------------------------------------------------------------------------- *) 131 | 132 | (*** 133 | *** prolog appendrules "append(X,3::4::nil,X)";; 134 | ***) 135 | 136 | (* ------------------------------------------------------------------------- *) 137 | (* A sorting example (from Lloyd's "Foundations of Logic Programming"). *) 138 | (* ------------------------------------------------------------------------- *) 139 | 140 | let sortrules = 141 | ["sort(X,Y) :- perm(X,Y),sorted(Y)"; 142 | "sorted(nil)"; 143 | "sorted(X::nil)"; 144 | "sorted(X::Y::Z) :- X <= Y, sorted(Y::Z)"; 145 | "perm(nil,nil)"; 146 | "perm(X::Y,U::V) :- delete(U,X::Y,Z), perm(Z,V)"; 147 | "delete(X,X::Y,Y)"; 148 | "delete(X,Y::Z,Y::W) :- delete(X,Z,W)"; 149 | "0 <= X"; 150 | "S(X) <= S(Y) :- X <= Y"];; 151 | 152 | prolog sortrules 153 | "sort(S(S(S(S(0))))::S(0)::0::S(S(0))::S(0)::nil,X)";; 154 | 155 | (* ------------------------------------------------------------------------- *) 156 | (* Yet with a simple swap of the first two predicates... *) 157 | (* ------------------------------------------------------------------------- *) 158 | 159 | let badrules = 160 | ["sort(X,Y) :- sorted(Y), perm(X,Y)"; 161 | "sorted(nil)"; 162 | "sorted(X::nil)"; 163 | "sorted(X::Y::Z) :- X <= Y, sorted(Y::Z)"; 164 | "perm(nil,nil)"; 165 | "perm(X::Y,U::V) :- delete(U,X::Y,Z), perm(Z,V)"; 166 | "delete(X,X::Y,Y)"; 167 | "delete(X,Y::Z,Y::W) :- delete(X,Z,W)"; 168 | "0 <= X"; 169 | "S(X) <= S(Y) :- X <= Y"];; 170 | 171 | (*** This no longer works 172 | 173 | prolog badrules 174 | "sort(S(S(S(S(0))))::S(0)::0::S(S(0))::S(0)::nil,X)";; 175 | 176 | ***) 177 | END_INTERACTIVE;; 178 | -------------------------------------------------------------------------------- /code/OCaml/propexamples.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Some propositional formulas to test, and functions to generate classes. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* Generate assertion equivalent to R(s,t) <= n for the Ramsey number R(s,t) *) 9 | (* ------------------------------------------------------------------------- *) 10 | 11 | let ramsey s t n = 12 | let vertices = 1 -- n in 13 | let yesgrps = map (allsets 2) (allsets s vertices) 14 | and nogrps = map (allsets 2) (allsets t vertices) in 15 | let e[m;n] = Atom(P("p_"^(string_of_int m)^"_"^(string_of_int n))) in 16 | Or(list_disj (map (list_conj ** map e) yesgrps), 17 | list_disj (map (list_conj ** map (fun p -> Not(e p))) nogrps));; 18 | 19 | (* ------------------------------------------------------------------------- *) 20 | (* Some currently tractable examples. *) 21 | (* ------------------------------------------------------------------------- *) 22 | 23 | START_INTERACTIVE;; 24 | ramsey 3 3 4;; 25 | 26 | tautology(ramsey 3 3 5);; 27 | 28 | tautology(ramsey 3 3 6);; 29 | 30 | END_INTERACTIVE;; 31 | 32 | (* ------------------------------------------------------------------------- *) 33 | (* Half adder. *) 34 | (* ------------------------------------------------------------------------- *) 35 | 36 | let halfsum x y = Iff(x,Not y);; 37 | 38 | let halfcarry x y = And(x,y);; 39 | 40 | let ha x y s c = And(Iff(s,halfsum x y),Iff(c,halfcarry x y));; 41 | 42 | (* ------------------------------------------------------------------------- *) 43 | (* Full adder. *) 44 | (* ------------------------------------------------------------------------- *) 45 | 46 | let carry x y z = Or(And(x,y),And(Or(x,y),z));; 47 | 48 | let sum x y z = halfsum (halfsum x y) z;; 49 | 50 | let fa x y z s c = And(Iff(s,sum x y z),Iff(c,carry x y z));; 51 | 52 | (* ------------------------------------------------------------------------- *) 53 | (* Useful idiom. *) 54 | (* ------------------------------------------------------------------------- *) 55 | 56 | let conjoin f l = list_conj (map f l);; 57 | 58 | (* ------------------------------------------------------------------------- *) 59 | (* n-bit ripple carry adder with carry c(0) propagated in and c(n) out. *) 60 | (* ------------------------------------------------------------------------- *) 61 | 62 | let ripplecarry x y c out n = 63 | conjoin (fun i -> fa (x i) (y i) (c i) (out i) (c(i + 1))) 64 | (0 -- (n - 1));; 65 | 66 | (* ------------------------------------------------------------------------- *) 67 | (* Example. *) 68 | (* ------------------------------------------------------------------------- *) 69 | 70 | let mk_index x i = Atom(P(x^"_"^(string_of_int i))) 71 | and mk_index2 x i j = 72 | Atom(P(x^"_"^(string_of_int i)^"_"^(string_of_int j)));; 73 | 74 | START_INTERACTIVE;; 75 | 76 | let [x; y; out; c] = map mk_index ["X"; "Y"; "OUT"; "C"];; 77 | 78 | ripplecarry x y c out 2;; 79 | 80 | END_INTERACTIVE;; 81 | 82 | (* ------------------------------------------------------------------------- *) 83 | (* Special case with 0 instead of c(0). *) 84 | (* ------------------------------------------------------------------------- *) 85 | 86 | let ripplecarry0 x y c out n = 87 | psimplify 88 | (ripplecarry x y (fun i -> if i = 0 then False else c i) out n);; 89 | 90 | (* ------------------------------------------------------------------------- *) 91 | (* Carry-select adder *) 92 | (* ------------------------------------------------------------------------- *) 93 | 94 | let ripplecarry1 x y c out n = 95 | psimplify 96 | (ripplecarry x y (fun i -> if i = 0 then True else c i) out n);; 97 | 98 | let mux sel in0 in1 = Or(And(Not sel,in0),And(sel,in1));; 99 | 100 | let offset n x i = x(n + i);; 101 | 102 | let rec carryselect x y c0 c1 s0 s1 c s n k = 103 | let k' = min n k in 104 | let fm = 105 | And(And(ripplecarry0 x y c0 s0 k',ripplecarry1 x y c1 s1 k'), 106 | And(Iff(c k',mux (c 0) (c0 k') (c1 k')), 107 | conjoin (fun i -> Iff(s i,mux (c 0) (s0 i) (s1 i))) 108 | (0 -- (k' - 1)))) in 109 | if k' < k then fm else 110 | And(fm,carryselect 111 | (offset k x) (offset k y) (offset k c0) (offset k c1) 112 | (offset k s0) (offset k s1) (offset k c) (offset k s) 113 | (n - k) k);; 114 | 115 | (* ------------------------------------------------------------------------- *) 116 | (* Equivalence problems for carry-select vs ripple carry adders. *) 117 | (* ------------------------------------------------------------------------- *) 118 | 119 | let mk_adder_test n k = 120 | let [x; y; c; s; c0; s0; c1; s1; c2; s2] = map mk_index 121 | ["x"; "y"; "c"; "s"; "c0"; "s0"; "c1"; "s1"; "c2"; "s2"] in 122 | Imp(And(And(carryselect x y c0 c1 s0 s1 c s n k,Not(c 0)), 123 | ripplecarry0 x y c2 s2 n), 124 | And(Iff(c n,c2 n), 125 | conjoin (fun i -> Iff(s i,s2 i)) (0 -- (n - 1))));; 126 | 127 | (* ------------------------------------------------------------------------- *) 128 | (* Ripple carry stage that separates off the final result. *) 129 | (* *) 130 | (* UUUUUUUUUUUUUUUUUUUU (u) *) 131 | (* + VVVVVVVVVVVVVVVVVVVV (v) *) 132 | (* *) 133 | (* = WWWWWWWWWWWWWWWWWWWW (w) *) 134 | (* + Z (z) *) 135 | (* ------------------------------------------------------------------------- *) 136 | 137 | let rippleshift u v c z w n = 138 | ripplecarry0 u v (fun i -> if i = n then w(n - 1) else c(i + 1)) 139 | (fun i -> if i = 0 then z else w(i - 1)) n;; 140 | 141 | (* ------------------------------------------------------------------------- *) 142 | (* Naive multiplier based on repeated ripple carry. *) 143 | (* ------------------------------------------------------------------------- *) 144 | 145 | let multiplier x u v out n = 146 | if n = 1 then And(Iff(out 0,x 0 0),Not(out 1)) else 147 | psimplify 148 | (And(Iff(out 0,x 0 0), 149 | And(rippleshift 150 | (fun i -> if i = n - 1 then False else x 0 (i + 1)) 151 | (x 1) (v 2) (out 1) (u 2) n, 152 | if n = 2 then And(Iff(out 2,u 2 0),Iff(out 3,u 2 1)) else 153 | conjoin (fun k -> rippleshift (u k) (x k) (v(k + 1)) (out k) 154 | (if k = n - 1 then fun i -> out(n + i) 155 | else u(k + 1)) n) (2 -- (n - 1)))));; 156 | 157 | (* ------------------------------------------------------------------------- *) 158 | (* Primality examples. *) 159 | (* For large examples, should use "num" instead of "int" in these functions. *) 160 | (* ------------------------------------------------------------------------- *) 161 | 162 | let rec bitlength x = if x = 0 then 0 else 1 + bitlength (x / 2);; 163 | 164 | let rec bit n x = if n = 0 then x mod 2 = 1 else bit (n - 1) (x / 2);; 165 | 166 | let congruent_to x m n = 167 | conjoin (fun i -> if bit i m then x i else Not(x i)) 168 | (0 -- (n - 1));; 169 | 170 | let prime p = 171 | let [x; y; out] = map mk_index ["x"; "y"; "out"] in 172 | let m i j = And(x i,y j) 173 | and [u; v] = map mk_index2 ["u"; "v"] in 174 | let n = bitlength p in 175 | Not(And(multiplier m u v out (n - 1), 176 | congruent_to out p (max n (2 * n - 2))));; 177 | 178 | (* ------------------------------------------------------------------------- *) 179 | (* Examples. *) 180 | (* ------------------------------------------------------------------------- *) 181 | 182 | START_INTERACTIVE;; 183 | 184 | tautology(prime 7);; 185 | tautology(prime 9);; 186 | tautology(prime 11);; 187 | 188 | END_INTERACTIVE;; 189 | -------------------------------------------------------------------------------- /code/OCaml/qelim.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Introduction to quantifier elimination. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* Lift procedure given literal modifier, formula normalizer, and a basic *) 9 | (* elimination procedure for existential formulas with conjunctive body. *) 10 | (* ------------------------------------------------------------------------- *) 11 | 12 | let qelim bfn x p = 13 | let cjs = conjuncts p in 14 | let ycjs,ncjs = partition (mem x ** fv) cjs in 15 | if ycjs = [] then p else 16 | let q = bfn (Exists(x,list_conj ycjs)) in 17 | itlist mk_and ncjs q;; 18 | 19 | let lift_qelim afn nfn qfn = 20 | let rec qelift vars fm = 21 | match fm with 22 | | Atom(R(_,_)) -> afn vars fm 23 | | Not(p) -> Not(qelift vars p) 24 | | And(p,q) -> And(qelift vars p,qelift vars q) 25 | | Or(p,q) -> Or(qelift vars p,qelift vars q) 26 | | Imp(p,q) -> Imp(qelift vars p,qelift vars q) 27 | | Iff(p,q) -> Iff(qelift vars p,qelift vars q) 28 | | Forall(x,p) -> Not(qelift vars (Exists(x,Not p))) 29 | | Exists(x,p) -> 30 | let djs = disjuncts(nfn(qelift (x::vars) p)) in 31 | list_disj(map (qelim (qfn vars) x) djs) 32 | | _ -> fm in 33 | fun fm -> simplify(qelift (fv fm) (miniscope fm));; 34 | 35 | (* ------------------------------------------------------------------------- *) 36 | (* Cleverer (proposisional) NNF with conditional and literal modification. *) 37 | (* ------------------------------------------------------------------------- *) 38 | 39 | let cnnf lfn = 40 | let rec cnnf fm = 41 | match fm with 42 | And(p,q) -> And(cnnf p,cnnf q) 43 | | Or(p,q) -> Or(cnnf p,cnnf q) 44 | | Imp(p,q) -> Or(cnnf(Not p),cnnf q) 45 | | Iff(p,q) -> Or(And(cnnf p,cnnf q),And(cnnf(Not p),cnnf(Not q))) 46 | | Not(Not p) -> cnnf p 47 | | Not(And(p,q)) -> Or(cnnf(Not p),cnnf(Not q)) 48 | | Not(Or(And(p,q),And(p',r))) when p' = negate p -> 49 | Or(cnnf (And(p,Not q)),cnnf (And(p',Not r))) 50 | | Not(Or(p,q)) -> And(cnnf(Not p),cnnf(Not q)) 51 | | Not(Imp(p,q)) -> And(cnnf p,cnnf(Not q)) 52 | | Not(Iff(p,q)) -> Or(And(cnnf p,cnnf(Not q)), 53 | And(cnnf(Not p),cnnf q)) 54 | | _ -> lfn fm in 55 | simplify ** cnnf ** simplify;; 56 | 57 | (* ------------------------------------------------------------------------- *) 58 | (* Initial literal simplifier and intermediate literal modifier. *) 59 | (* ------------------------------------------------------------------------- *) 60 | 61 | let lfn_dlo fm = 62 | match fm with 63 | Not(Atom(R("<",[s;t]))) -> Or(Atom(R("=",[s;t])),Atom(R("<",[t;s]))) 64 | | Not(Atom(R("=",[s;t]))) -> Or(Atom(R("<",[s;t])),Atom(R("<",[t;s]))) 65 | | _ -> fm;; 66 | 67 | (* ------------------------------------------------------------------------- *) 68 | (* Simple example of dense linear orderings; this is the base function. *) 69 | (* ------------------------------------------------------------------------- *) 70 | 71 | let dlobasic fm = 72 | match fm with 73 | Exists(x,p) -> 74 | let cjs = subtract (conjuncts p) [Atom(R("=",[Var x;Var x]))] in 75 | try let eqn = find is_eq cjs in 76 | let s,t = dest_eq eqn in 77 | let y = if s = Var x then t else s in 78 | list_conj(map (subst (x |=> y)) (subtract cjs [eqn])) 79 | with Failure _ -> 80 | if mem (Atom(R("<",[Var x;Var x]))) cjs then False else 81 | let lefts,rights = 82 | partition (fun (Atom(R("<",[s;t]))) -> t = Var x) cjs in 83 | let ls = map (fun (Atom(R("<",[l;_]))) -> l) lefts 84 | and rs = map (fun (Atom(R("<",[_;r]))) -> r) rights in 85 | list_conj(allpairs (fun l r -> Atom(R("<",[l;r]))) ls rs) 86 | | _ -> failwith "dlobasic";; 87 | 88 | (* ------------------------------------------------------------------------- *) 89 | (* Overall quelim procedure. *) 90 | (* ------------------------------------------------------------------------- *) 91 | 92 | let afn_dlo vars fm = 93 | match fm with 94 | Atom(R("<=",[s;t])) -> Not(Atom(R("<",[t;s]))) 95 | | Atom(R(">=",[s;t])) -> Not(Atom(R("<",[s;t]))) 96 | | Atom(R(">",[s;t])) -> Atom(R("<",[t;s])) 97 | | _ -> fm;; 98 | 99 | let quelim_dlo = 100 | lift_qelim afn_dlo (dnf ** cnnf lfn_dlo) (fun v -> dlobasic);; 101 | 102 | (* ------------------------------------------------------------------------- *) 103 | (* Examples. *) 104 | (* ------------------------------------------------------------------------- *) 105 | 106 | START_INTERACTIVE;; 107 | quelim_dlo <>;; 108 | 109 | quelim_dlo <>;; 110 | 111 | quelim_dlo <>;; 112 | 113 | quelim_dlo <<(forall x. x < a ==> x < b)>>;; 114 | 115 | quelim_dlo < x < b) <=> a <= b>>;; 116 | 117 | quelim_dlo < x < b) <=> a = b>>;; 118 | 119 | quelim_dlo <>;; 121 | 122 | (* ------------------------------------------------------------------------- *) 123 | (* More tests (not in the text). *) 124 | (* ------------------------------------------------------------------------- *) 125 | 126 | time quelim_dlo <>;; 127 | 128 | time quelim_dlo < x < z>>;; 129 | 130 | time quelim_dlo <>;; 131 | 132 | time quelim_dlo <>;; 133 | 134 | time quelim_dlo <>;; 135 | 136 | time quelim_dlo <>;; 137 | 138 | time quelim_dlo <>;; 139 | 140 | time quelim_dlo < exists z. x < z /\ z < y>>;; 141 | 142 | time quelim_dlo 143 | < exists u. u < x /\ (y < u \/ x < y)>>;; 144 | 145 | time quelim_dlo <>;; 146 | 147 | time quelim_dlo <>;; 148 | 149 | time quelim_dlo <>;; 150 | 151 | time quelim_dlo <>;; 152 | 153 | time quelim_dlo <>;; 154 | 155 | time quelim_dlo <>;; 156 | 157 | time quelim_dlo < w < z>>;; 158 | 159 | time quelim_dlo <>;; 160 | 161 | time quelim_dlo <>;; 162 | 163 | time quelim_dlo < x < b) <=> a <= b>>;; 164 | 165 | time quelim_dlo < x < b>>;; 166 | 167 | time quelim_dlo < x <= b>>;; 168 | 169 | time quelim_dlo <>;; 170 | 171 | time quelim_dlo < y>>;; 172 | 173 | time quelim_dlo <>;; 174 | END_INTERACTIVE;; 175 | -------------------------------------------------------------------------------- /code/OCaml/real.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Real quantifier elimination (using Cohen-Hormander algorithm). *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* Formal derivative of polynomial. *) 9 | (* ------------------------------------------------------------------------- *) 10 | 11 | let rec poly_diffn x n p = 12 | match p with 13 | Fn("+",[c; Fn("*",[y; q])]) when y = x -> 14 | Fn("+",[poly_cmul(Int n) c; Fn("*",[x; poly_diffn x (n+1) q])]) 15 | | _ -> poly_cmul(Int n) p;; 16 | 17 | let poly_diff vars p = 18 | match p with 19 | Fn("+",[c; Fn("*",[Var x; q])]) when x = hd vars -> 20 | poly_diffn (Var x) 1 q 21 | | _ -> zero;; 22 | 23 | (* ------------------------------------------------------------------------- *) 24 | (* Evaluate a quantifier-free formula given a sign matrix row for its polys. *) 25 | (* ------------------------------------------------------------------------- *) 26 | 27 | let rel_signs = 28 | ["=",[Zero]; "<=",[Zero;Negative]; ">=",[Zero;Positive]; 29 | "<",[Negative]; ">",[Positive]];; 30 | 31 | let testform pmat fm = 32 | eval fm (fun (R(a,[p;z])) -> mem (assoc p pmat) (assoc a rel_signs));; 33 | 34 | (* ------------------------------------------------------------------------- *) 35 | (* Infer sign of p(x) at points from corresponding qi(x) with pi(x) = 0 *) 36 | (* ------------------------------------------------------------------------- *) 37 | 38 | let inferpsign (pd,qd) = 39 | try let i = index Zero pd in el i qd :: pd 40 | with Failure _ -> Nonzero :: pd;; 41 | 42 | (* ------------------------------------------------------------------------- *) 43 | (* Condense subdivision by removing points with no relevant zeros. *) 44 | (* ------------------------------------------------------------------------- *) 45 | 46 | let rec condense ps = 47 | match ps with 48 | int::pt::other -> let rest = condense other in 49 | if mem Zero pt then int::pt::rest else rest 50 | | _ -> ps;; 51 | 52 | (* ------------------------------------------------------------------------- *) 53 | (* Infer sign on intervals (use with infinities at end) and split if needed *) 54 | (* ------------------------------------------------------------------------- *) 55 | 56 | let rec inferisign ps = 57 | match ps with 58 | ((l::ls) as x)::(_::ints)::((r::rs)::xs as pts) -> 59 | (match (l,r) with 60 | (Zero,Zero) -> failwith "inferisign: inconsistent" 61 | | (Nonzero,_) 62 | | (_,Nonzero) -> failwith "inferisign: indeterminate" 63 | | (Zero,_) -> x::(r::ints)::inferisign pts 64 | | (_,Zero) -> x::(l::ints)::inferisign pts 65 | | (Negative,Negative) 66 | | (Positive,Positive) -> x::(l::ints)::inferisign pts 67 | | _ -> x::(l::ints)::(Zero::ints)::(r::ints)::inferisign pts) 68 | | _ -> ps;; 69 | 70 | (* ------------------------------------------------------------------------- *) 71 | (* Deduce matrix for p,p1,...,pn from matrix for p',p1,...,pn,q0,...,qn *) 72 | (* where qi = rem(p,pi) with p0 = p' *) 73 | (* ------------------------------------------------------------------------- *) 74 | 75 | let dedmatrix cont mat = 76 | let l = length (hd mat) / 2 in 77 | let mat1 = condense(map (inferpsign ** chop_list l) mat) in 78 | let mat2 = [swap true (el 1 (hd mat1))]::mat1@[[el 1 (last mat1)]] in 79 | let mat3 = butlast(tl(inferisign mat2)) in 80 | cont(condense(map (fun l -> hd l :: tl(tl l)) mat3));; 81 | 82 | (* ------------------------------------------------------------------------- *) 83 | (* Pseudo-division making sure the remainder has the same sign. *) 84 | (* ------------------------------------------------------------------------- *) 85 | 86 | let pdivide_pos vars sgns s p = 87 | let a = head vars p and (k,r) = pdivide vars s p in 88 | let sgn = findsign sgns a in 89 | if sgn = Zero then failwith "pdivide_pos: zero head coefficient" 90 | else if sgn = Positive or k mod 2 = 0 then r 91 | else if sgn = Negative then poly_neg r else poly_mul vars a r;; 92 | 93 | (* ------------------------------------------------------------------------- *) 94 | (* Case splitting for positive/negative (assumed nonzero). *) 95 | (* ------------------------------------------------------------------------- *) 96 | 97 | let split_sign sgns pol cont = 98 | match findsign sgns pol with 99 | Nonzero -> let fm = Atom(R(">",[pol; zero])) in 100 | Or(And(fm,cont(assertsign sgns (pol,Positive))), 101 | And(Not fm,cont(assertsign sgns (pol,Negative)))) 102 | | _ -> cont sgns;; 103 | 104 | let split_trichotomy sgns pol cont_z cont_pn = 105 | split_zero sgns pol cont_z (fun s' -> split_sign s' pol cont_pn);; 106 | 107 | (* ------------------------------------------------------------------------- *) 108 | (* Main recursive evaluation of sign matrices. *) 109 | (* ------------------------------------------------------------------------- *) 110 | 111 | let rec casesplit vars dun pols cont sgns = 112 | match pols with 113 | [] -> matrix vars dun cont sgns 114 | | p::ops -> split_trichotomy sgns (head vars p) 115 | (if is_constant vars p then delconst vars dun p ops cont 116 | else casesplit vars dun (behead vars p :: ops) cont) 117 | (if is_constant vars p then delconst vars dun p ops cont 118 | else casesplit vars (dun@[p]) ops cont) 119 | 120 | and delconst vars dun p ops cont sgns = 121 | let cont' m = cont(map (insertat (length dun) (findsign sgns p)) m) in 122 | casesplit vars dun ops cont' sgns 123 | 124 | and matrix vars pols cont sgns = 125 | if pols = [] then try cont [[]] with Failure _ -> False else 126 | let p = hd(sort(decreasing (degree vars)) pols) in 127 | let p' = poly_diff vars p and i = index p pols in 128 | let qs = let p1,p2 = chop_list i pols in p'::p1 @ tl p2 in 129 | let gs = map (pdivide_pos vars sgns p) qs in 130 | let cont' m = cont(map (fun l -> insertat i (hd l) (tl l)) m) in 131 | casesplit vars [] (qs@gs) (dedmatrix cont') sgns;; 132 | 133 | (* ------------------------------------------------------------------------- *) 134 | (* Now the actual quantifier elimination code. *) 135 | (* ------------------------------------------------------------------------- *) 136 | 137 | let basic_real_qelim vars (Exists(x,p)) = 138 | let pols = atom_union 139 | (function (R(a,[t;Fn("0",[])])) -> [t] | _ -> []) p in 140 | let cont mat = if exists (fun m -> testform (zip pols m) p) mat 141 | then True else False in 142 | casesplit (x::vars) [] pols cont init_sgns;; 143 | 144 | let real_qelim = 145 | simplify ** evalc ** 146 | lift_qelim polyatom (simplify ** evalc) basic_real_qelim;; 147 | 148 | (* ------------------------------------------------------------------------- *) 149 | (* First examples. *) 150 | (* ------------------------------------------------------------------------- *) 151 | 152 | START_INTERACTIVE;; 153 | real_qelim <>;; 154 | 155 | real_qelim <>;; 156 | 157 | real_qelim <>;; 159 | 160 | #trace testform;; 161 | real_qelim <>;; 162 | #untrace testform;; 163 | 164 | real_qelim 165 | < f < a * e) ==> f <= a * k>>;; 166 | 167 | real_qelim <>;; 168 | 169 | real_qelim < 170 | b^2 >= 4 * a * c>>;; 171 | 172 | real_qelim < 173 | a = 0 /\ (b = 0 ==> c = 0) \/ 174 | ~(a = 0) /\ b^2 >= 4 * a * c>>;; 175 | 176 | (* ------------------------------------------------------------------------- *) 177 | (* Termination ordering for group theory completion. *) 178 | (* ------------------------------------------------------------------------- *) 179 | 180 | real_qelim <<1 < 2 /\ (forall x. 1 < x ==> 1 < x^2) /\ 181 | (forall x y. 1 < x /\ 1 < y ==> 1 < x * (1 + 2 * y))>>;; 182 | END_INTERACTIVE;; 183 | 184 | let rec grpterm tm = 185 | match tm with 186 | Fn("*",[s;t]) -> let t2 = Fn("*",[Fn("2",[]); grpterm t]) in 187 | Fn("*",[grpterm s; Fn("+",[Fn("1",[]); t2])]) 188 | | Fn("i",[t]) -> Fn("^",[grpterm t; Fn("2",[])]) 189 | | Fn("1",[]) -> Fn("2",[]) 190 | | Var x -> tm;; 191 | 192 | let grpform (Atom(R("=",[s;t]))) = 193 | let fm = generalize(Atom(R(">",[grpterm s; grpterm t]))) in 194 | relativize(fun x -> Atom(R(">",[Var x;Fn("1",[])]))) fm;; 195 | 196 | START_INTERACTIVE;; 197 | let eqs = complete_and_simplify ["1"; "*"; "i"] 198 | [<<1 * x = x>>; <>; <<(x * y) * z = x * y * z>>];; 199 | 200 | let fm = list_conj (map grpform eqs);; 201 | 202 | real_qelim fm;; 203 | END_INTERACTIVE;; 204 | 205 | (* ------------------------------------------------------------------------- *) 206 | (* A case where using DNF is an improvement. *) 207 | (* ------------------------------------------------------------------------- *) 208 | 209 | let real_qelim' = 210 | simplify ** evalc ** 211 | lift_qelim polyatom (dnf ** cnnf (fun x -> x) ** evalc) 212 | basic_real_qelim;; 213 | 214 | real_qelim' 215 | < a^2 = b) 218 | <=> d^4 = 1>>;; 219 | 220 | (* ------------------------------------------------------------------------- *) 221 | (* Didn't seem worth it in the book, but monicization can help a lot. *) 222 | (* Now this is just set as an exercise. *) 223 | (* ------------------------------------------------------------------------- *) 224 | 225 | START_INTERACTIVE;; 226 | let rec casesplit vars dun pols cont sgns = 227 | match pols with 228 | [] -> monicize vars dun cont sgns 229 | | p::ops -> split_trichotomy sgns (head vars p) 230 | (if is_constant vars p then delconst vars dun p ops cont 231 | else casesplit vars dun (behead vars p :: ops) cont) 232 | (if is_constant vars p then delconst vars dun p ops cont 233 | else casesplit vars (dun@[p]) ops cont) 234 | 235 | and delconst vars dun p ops cont sgns = 236 | let cont' m = cont(map (insertat (length dun) (findsign sgns p)) m) in 237 | casesplit vars dun ops cont' sgns 238 | 239 | and matrix vars pols cont sgns = 240 | if pols = [] then try cont [[]] with Failure _ -> False else 241 | let p = hd(sort(decreasing (degree vars)) pols) in 242 | let p' = poly_diff vars p and i = index p pols in 243 | let qs = let p1,p2 = chop_list i pols in p'::p1 @ tl p2 in 244 | let gs = map (pdivide_pos vars sgns p) qs in 245 | let cont' m = cont(map (fun l -> insertat i (hd l) (tl l)) m) in 246 | casesplit vars [] (qs@gs) (dedmatrix cont') sgns 247 | 248 | and monicize vars pols cont sgns = 249 | let mols,swaps = unzip(map monic pols) in 250 | let sols = setify mols in 251 | let indices = map (fun p -> index p sols) mols in 252 | let transform m = 253 | map2 (fun sw i -> swap sw (el i m)) swaps indices in 254 | let cont' mat = cont(map transform mat) in 255 | matrix vars sols cont' sgns;; 256 | 257 | let basic_real_qelim vars (Exists(x,p)) = 258 | let pols = atom_union 259 | (function (R(a,[t;Fn("0",[])])) -> [t] | _ -> []) p in 260 | let cont mat = if exists (fun m -> testform (zip pols m) p) mat 261 | then True else False in 262 | casesplit (x::vars) [] pols cont init_sgns;; 263 | 264 | let real_qelim = 265 | simplify ** evalc ** 266 | lift_qelim polyatom (simplify ** evalc) basic_real_qelim;; 267 | 268 | let real_qelim' = 269 | simplify ** evalc ** 270 | lift_qelim polyatom (dnf ** cnnf (fun x -> x) ** evalc) 271 | basic_real_qelim;; 272 | END_INTERACTIVE;; 273 | -------------------------------------------------------------------------------- /code/OCaml/rewrite.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Rewriting. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* Rewriting at the top level with first of list of equations. *) 9 | (* ------------------------------------------------------------------------- *) 10 | 11 | let rec rewrite1 eqs t = 12 | match eqs with 13 | Atom(R("=",[l;r]))::oeqs -> 14 | (try tsubst (term_match undefined [l,t]) r 15 | with Failure _ -> rewrite1 oeqs t) 16 | | _ -> failwith "rewrite1";; 17 | 18 | (* ------------------------------------------------------------------------- *) 19 | (* Rewriting repeatedly and at depth (top-down). *) 20 | (* ------------------------------------------------------------------------- *) 21 | 22 | let rec rewrite eqs tm = 23 | try rewrite eqs (rewrite1 eqs tm) with Failure _ -> 24 | match tm with 25 | Var x -> tm 26 | | Fn(f,args) -> let tm' = Fn(f,map (rewrite eqs) args) in 27 | if tm' = tm then tm else rewrite eqs tm';; 28 | 29 | (* ------------------------------------------------------------------------- *) 30 | (* Example: 3 * 2 + 4 in successor notation. *) 31 | (* ------------------------------------------------------------------------- *) 32 | 33 | START_INTERACTIVE;; 34 | rewrite [<<0 + x = x>>; <>; 35 | <<0 * x = 0>>; <>] 36 | <<|S(S(S(0))) * S(S(0)) + S(S(S(S(0))))|>>;; 37 | END_INTERACTIVE;; 38 | 39 | (* ------------------------------------------------------------------------- *) 40 | (* Note that ML doesn't accept nonlinear patterns. *) 41 | (* ------------------------------------------------------------------------- *) 42 | 43 | (*********** Point being that CAML doesn't accept nonlinear patterns 44 | 45 | function (x,x) -> 0;; 46 | 47 | *********** Actually fun x x -> 0 works, but the xs seem to be 48 | *********** considered distinct 49 | **********) 50 | -------------------------------------------------------------------------------- /code/OCaml/skolem.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Prenex and Skolem normal forms. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | (* ------------------------------------------------------------------------- *) 8 | (* Routine simplification. Like "psimplify" but with quantifier clauses. *) 9 | (* ------------------------------------------------------------------------- *) 10 | 11 | let simplify1 fm = 12 | match fm with 13 | Forall(x,p) -> if mem x (fv p) then fm else p 14 | | Exists(x,p) -> if mem x (fv p) then fm else p 15 | | _ -> psimplify1 fm;; 16 | 17 | let rec simplify fm = 18 | match fm with 19 | Not p -> simplify1 (Not(simplify p)) 20 | | And(p,q) -> simplify1 (And(simplify p,simplify q)) 21 | | Or(p,q) -> simplify1 (Or(simplify p,simplify q)) 22 | | Imp(p,q) -> simplify1 (Imp(simplify p,simplify q)) 23 | | Iff(p,q) -> simplify1 (Iff(simplify p,simplify q)) 24 | | Forall(x,p) -> simplify1(Forall(x,simplify p)) 25 | | Exists(x,p) -> simplify1(Exists(x,simplify p)) 26 | | _ -> fm;; 27 | 28 | (* ------------------------------------------------------------------------- *) 29 | (* Example. *) 30 | (* ------------------------------------------------------------------------- *) 31 | 32 | START_INTERACTIVE;; 33 | simplify <<(forall x y. P(x) \/ (P(y) /\ false)) ==> exists z. Q>>;; 34 | END_INTERACTIVE;; 35 | 36 | (* ------------------------------------------------------------------------- *) 37 | (* Negation normal form. *) 38 | (* ------------------------------------------------------------------------- *) 39 | 40 | let rec nnf fm = 41 | match fm with 42 | And(p,q) -> And(nnf p,nnf q) 43 | | Or(p,q) -> Or(nnf p,nnf q) 44 | | Imp(p,q) -> Or(nnf(Not p),nnf q) 45 | | Iff(p,q) -> Or(And(nnf p,nnf q),And(nnf(Not p),nnf(Not q))) 46 | | Not(Not p) -> nnf p 47 | | Not(And(p,q)) -> Or(nnf(Not p),nnf(Not q)) 48 | | Not(Or(p,q)) -> And(nnf(Not p),nnf(Not q)) 49 | | Not(Imp(p,q)) -> And(nnf p,nnf(Not q)) 50 | | Not(Iff(p,q)) -> Or(And(nnf p,nnf(Not q)),And(nnf(Not p),nnf q)) 51 | | Forall(x,p) -> Forall(x,nnf p) 52 | | Exists(x,p) -> Exists(x,nnf p) 53 | | Not(Forall(x,p)) -> Exists(x,nnf(Not p)) 54 | | Not(Exists(x,p)) -> Forall(x,nnf(Not p)) 55 | | _ -> fm;; 56 | 57 | (* ------------------------------------------------------------------------- *) 58 | (* Example of NNF function in action. *) 59 | (* ------------------------------------------------------------------------- *) 60 | 61 | START_INTERACTIVE;; 62 | nnf <<(forall x. P(x)) 63 | ==> ((exists y. Q(y)) <=> exists z. P(z) /\ Q(z))>>;; 64 | END_INTERACTIVE;; 65 | 66 | (* ------------------------------------------------------------------------- *) 67 | (* Prenex normal form. *) 68 | (* ------------------------------------------------------------------------- *) 69 | 70 | let rec pullquants fm = 71 | match fm with 72 | And(Forall(x,p),Forall(y,q)) -> 73 | pullq(true,true) fm mk_forall mk_and x y p q 74 | | Or(Exists(x,p),Exists(y,q)) -> 75 | pullq(true,true) fm mk_exists mk_or x y p q 76 | | And(Forall(x,p),q) -> pullq(true,false) fm mk_forall mk_and x x p q 77 | | And(p,Forall(y,q)) -> pullq(false,true) fm mk_forall mk_and y y p q 78 | | Or(Forall(x,p),q) -> pullq(true,false) fm mk_forall mk_or x x p q 79 | | Or(p,Forall(y,q)) -> pullq(false,true) fm mk_forall mk_or y y p q 80 | | And(Exists(x,p),q) -> pullq(true,false) fm mk_exists mk_and x x p q 81 | | And(p,Exists(y,q)) -> pullq(false,true) fm mk_exists mk_and y y p q 82 | | Or(Exists(x,p),q) -> pullq(true,false) fm mk_exists mk_or x x p q 83 | | Or(p,Exists(y,q)) -> pullq(false,true) fm mk_exists mk_or y y p q 84 | | _ -> fm 85 | 86 | and pullq(l,r) fm quant op x y p q = 87 | let z = variant x (fv fm) in 88 | let p' = if l then subst (x |=> Var z) p else p 89 | and q' = if r then subst (y |=> Var z) q else q in 90 | quant z (pullquants(op p' q'));; 91 | 92 | let rec prenex fm = 93 | match fm with 94 | Forall(x,p) -> Forall(x,prenex p) 95 | | Exists(x,p) -> Exists(x,prenex p) 96 | | And(p,q) -> pullquants(And(prenex p,prenex q)) 97 | | Or(p,q) -> pullquants(Or(prenex p,prenex q)) 98 | | _ -> fm;; 99 | 100 | let pnf fm = prenex(nnf(simplify fm));; 101 | 102 | (* ------------------------------------------------------------------------- *) 103 | (* Example. *) 104 | (* ------------------------------------------------------------------------- *) 105 | 106 | START_INTERACTIVE;; 107 | pnf <<(forall x. P(x) \/ R(y)) 108 | ==> exists y z. Q(y) \/ ~(exists z. P(z) /\ Q(z))>>;; 109 | END_INTERACTIVE;; 110 | 111 | (* ------------------------------------------------------------------------- *) 112 | (* Get the functions in a term and formula. *) 113 | (* ------------------------------------------------------------------------- *) 114 | 115 | let rec funcs tm = 116 | match tm with 117 | Var x -> [] 118 | | Fn(f,args) -> itlist (union ** funcs) args [f,length args];; 119 | 120 | let functions fm = 121 | atom_union (fun (R(p,a)) -> itlist (union ** funcs) a []) fm;; 122 | 123 | (* ------------------------------------------------------------------------- *) 124 | (* Core Skolemization function. *) 125 | (* ------------------------------------------------------------------------- *) 126 | 127 | let rec skolem fm fns = 128 | match fm with 129 | Exists(y,p) -> 130 | let xs = fv(fm) in 131 | let f = variant (if xs = [] then "c_"^y else "f_"^y) fns in 132 | let fx = Fn(f,map (fun x -> Var x) xs) in 133 | skolem (subst (y |=> fx) p) (f::fns) 134 | | Forall(x,p) -> let p',fns' = skolem p fns in Forall(x,p'),fns' 135 | | And(p,q) -> skolem2 (fun (p,q) -> And(p,q)) (p,q) fns 136 | | Or(p,q) -> skolem2 (fun (p,q) -> Or(p,q)) (p,q) fns 137 | | _ -> fm,fns 138 | 139 | and skolem2 cons (p,q) fns = 140 | let p',fns' = skolem p fns in 141 | let q',fns'' = skolem q fns' in 142 | cons(p',q'),fns'';; 143 | 144 | (* ------------------------------------------------------------------------- *) 145 | (* Overall Skolemization function. *) 146 | (* ------------------------------------------------------------------------- *) 147 | 148 | let askolemize fm = 149 | fst(skolem (nnf(simplify fm)) (map fst (functions fm)));; 150 | 151 | let rec specialize fm = 152 | match fm with 153 | Forall(x,p) -> specialize p 154 | | _ -> fm;; 155 | 156 | let skolemize fm = specialize(pnf(askolemize fm));; 157 | 158 | (* ------------------------------------------------------------------------- *) 159 | (* Example. *) 160 | (* ------------------------------------------------------------------------- *) 161 | 162 | START_INTERACTIVE;; 163 | skolemize < forall u. exists v. x * u < y * v>>;; 164 | 165 | skolemize 166 | < (exists y z. Q(y) \/ ~(exists z. P(z) /\ Q(z)))>>;; 168 | END_INTERACTIVE;; 169 | -------------------------------------------------------------------------------- /code/OCaml/skolems.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Illustration of Skolemizing a set of formulas *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | let rec rename_term tm = 8 | match tm with 9 | Fn(f,args) -> Fn("old_"^f,map rename_term args) 10 | | _ -> tm;; 11 | 12 | let rename_form = onformula rename_term;; 13 | 14 | let rec skolems fms corr = 15 | match fms with 16 | [] -> [],corr 17 | | (p::ofms) -> 18 | let p',corr' = skolem (rename_form p) corr in 19 | let ps',corr'' = skolems ofms corr' in 20 | p'::ps',corr'';; 21 | 22 | let skolemizes fms = fst(skolems fms []);; 23 | 24 | START_INTERACTIVE;; 25 | skolemizes [<>; 26 | <>];; 27 | END_INTERACTIVE;; 28 | -------------------------------------------------------------------------------- /code/OCaml/stal.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Simple implementation of Stalmarck's algorithm. *) 3 | (* *) 4 | (* NB! This algorithm is patented for commercial use (not that a toy version *) 5 | (* like this would actually be useful in practice). *) 6 | (* ========================================================================= *) 7 | 8 | (* ------------------------------------------------------------------------- *) 9 | (* Triplet transformation, using functions defined earlier. *) 10 | (* ------------------------------------------------------------------------- *) 11 | 12 | let triplicate fm = 13 | let fm' = nenf fm in 14 | let n = Int 1 +/ overatoms (max_varindex "p_" ** pname) fm' (Int 0) in 15 | let (p,defs,_) = maincnf (fm',undefined,n) in 16 | p,map (snd ** snd) (graph defs);; 17 | 18 | (* ------------------------------------------------------------------------- *) 19 | (* Automatically generate triggering rules to save writing them out. *) 20 | (* ------------------------------------------------------------------------- *) 21 | 22 | let atom lit = if negative lit then negate lit else lit;; 23 | 24 | let rec align (p,q) = 25 | if atom p < atom q then align (q,p) else 26 | if negative p then (negate p,negate q) else (p,q);; 27 | 28 | let equate2 (p,q) eqv = equate (negate p,negate q) (equate (p,q) eqv);; 29 | 30 | let rec irredundant rel eqs = 31 | match eqs with 32 | [] -> [] 33 | | (p,q)::oth -> 34 | if canonize rel p = canonize rel q then irredundant rel oth 35 | else insert (p,q) (irredundant (equate2 (p,q) rel) oth);; 36 | 37 | let consequences (p,q as peq) fm eqs = 38 | let follows(r,s) = tautology(Imp(And(Iff(p,q),fm),Iff(r,s))) in 39 | irredundant (equate2 peq unequal) (filter follows eqs);; 40 | 41 | let triggers fm = 42 | let poslits = insert True (map (fun p -> Atom p) (atoms fm)) in 43 | let lits = union poslits (map negate poslits) in 44 | let pairs = allpairs (fun p q -> p,q) lits lits in 45 | let npairs = filter (fun (p,q) -> atom p <> atom q) pairs in 46 | let eqs = setify(map align npairs) in 47 | let raw = map (fun p -> p,consequences p fm eqs) eqs in 48 | filter (fun (p,c) -> c <> []) raw;; 49 | 50 | (* ------------------------------------------------------------------------- *) 51 | (* An example. *) 52 | (* ------------------------------------------------------------------------- *) 53 | 54 | START_INTERACTIVE;; 55 | triggers <

(q /\ r)>>;; 56 | END_INTERACTIVE;; 57 | 58 | (* ------------------------------------------------------------------------- *) 59 | (* Precompute and instantiate triggers for standard triplets. *) 60 | (* ------------------------------------------------------------------------- *) 61 | 62 | let trigger = 63 | let [trig_and; trig_or; trig_imp; trig_iff] = map triggers 64 | [<

q /\ r>>; <

q \/ r>>; 65 | <

(q ==> r)>>; <

(q <=> r)>>] 66 | and p = <

> and q = <> and r = <> 67 | and ddnegate fm = match fm with Not(Not p) -> p | _ -> fm in 68 | let inst_fn [x;y;z] = 69 | let subfn = fpf [P"p"; P"q"; P"r"] [x; y; z] in 70 | ddnegate ** psubst subfn in 71 | let inst2_fn i (p,q) = align(inst_fn i p,inst_fn i q) in 72 | let instn_fn i (a,c) = inst2_fn i a,map (inst2_fn i) c in 73 | let inst_trigger = map ** instn_fn in 74 | function (Iff(x,And(y,z))) -> inst_trigger [x;y;z] trig_and 75 | | (Iff(x,Or(y,z))) -> inst_trigger [x;y;z] trig_or 76 | | (Iff(x,Imp(y,z))) -> inst_trigger [x;y;z] trig_imp 77 | | (Iff(x,Iff(y,z))) -> inst_trigger [x;y;z] trig_iff;; 78 | 79 | (* ------------------------------------------------------------------------- *) 80 | (* Compute a function mapping each variable/true to relevant triggers. *) 81 | (* ------------------------------------------------------------------------- *) 82 | 83 | let relevance trigs = 84 | let insert_relevant p trg f = (p |-> insert trg (tryapplyl f p)) f in 85 | let insert_relevant2 ((p,q),_ as trg) f = 86 | insert_relevant p trg (insert_relevant q trg f) in 87 | itlist insert_relevant2 trigs undefined;; 88 | 89 | (* ------------------------------------------------------------------------- *) 90 | (* Merging of equiv classes and relevancies. *) 91 | (* ------------------------------------------------------------------------- *) 92 | 93 | let equatecons (p0,q0) (eqv,rfn as erf) = 94 | let p = canonize eqv p0 and q = canonize eqv q0 in 95 | if p = q then [],erf else 96 | let p' = canonize eqv (negate p0) and q' = canonize eqv (negate q0) in 97 | let eqv' = equate2(p,q) eqv 98 | and sp_pos = tryapplyl rfn p and sp_neg = tryapplyl rfn p' 99 | and sq_pos = tryapplyl rfn q and sq_neg = tryapplyl rfn q' in 100 | let rfn' = 101 | (canonize eqv' p |-> union sp_pos sq_pos) 102 | ((canonize eqv' p' |-> union sp_neg sq_neg) rfn) in 103 | let nw = union (intersect sp_pos sq_pos) (intersect sp_neg sq_neg) in 104 | itlist (union ** snd) nw [],(eqv',rfn');; 105 | 106 | (* ------------------------------------------------------------------------- *) 107 | (* Zero-saturation given an equivalence/relevance and new assignments. *) 108 | (* ------------------------------------------------------------------------- *) 109 | 110 | let rec zero_saturate erf assigs = 111 | match assigs with 112 | [] -> erf 113 | | (p,q)::ts -> let news,erf' = equatecons (p,q) erf in 114 | zero_saturate erf' (union ts news);; 115 | 116 | (* ------------------------------------------------------------------------- *) 117 | (* Zero-saturate then check for contradictoriness. *) 118 | (* ------------------------------------------------------------------------- *) 119 | 120 | let zero_saturate_and_check erf trigs = 121 | let (eqv',rfn' as erf') = zero_saturate erf trigs in 122 | let vars = filter positive (equated eqv') in 123 | if exists (fun x -> canonize eqv' x = canonize eqv' (Not x)) vars 124 | then snd(equatecons (True,Not True) erf') else erf';; 125 | 126 | (* ------------------------------------------------------------------------- *) 127 | (* Now we can quickly test for contradiction. *) 128 | (* ------------------------------------------------------------------------- *) 129 | 130 | let truefalse pfn = canonize pfn (Not True) = canonize pfn True;; 131 | 132 | (* ------------------------------------------------------------------------- *) 133 | (* Iterated equivalening over a set. *) 134 | (* ------------------------------------------------------------------------- *) 135 | 136 | let rec equateset s0 eqfn = 137 | match s0 with 138 | a::(b::s2 as s1) -> equateset s1 (snd(equatecons (a,b) eqfn)) 139 | | _ -> eqfn;; 140 | 141 | (* ------------------------------------------------------------------------- *) 142 | (* Intersection operation on equivalence classes and relevancies. *) 143 | (* ------------------------------------------------------------------------- *) 144 | 145 | let rec inter els (eq1,_ as erf1) (eq2,_ as erf2) rev1 rev2 erf = 146 | match els with 147 | [] -> erf 148 | | x::xs -> 149 | let b1 = canonize eq1 x and b2 = canonize eq2 x in 150 | let s1 = apply rev1 b1 and s2 = apply rev2 b2 in 151 | let s = intersect s1 s2 in 152 | inter (subtract xs s) erf1 erf2 rev1 rev2 (equateset s erf);; 153 | 154 | (* ------------------------------------------------------------------------- *) 155 | (* Reverse the equivalence mappings. *) 156 | (* ------------------------------------------------------------------------- *) 157 | 158 | let reverseq domain eqv = 159 | let al = map (fun x -> x,canonize eqv x) domain in 160 | itlist (fun (y,x) f -> (x |-> insert y (tryapplyl f x)) f) 161 | al undefined;; 162 | 163 | (* ------------------------------------------------------------------------- *) 164 | (* Special intersection taking contradictoriness into account. *) 165 | (* ------------------------------------------------------------------------- *) 166 | 167 | let stal_intersect (eq1,_ as erf1) (eq2,_ as erf2) erf = 168 | if truefalse eq1 then erf2 else if truefalse eq2 then erf1 else 169 | let dom1 = equated eq1 and dom2 = equated eq2 in 170 | let comdom = intersect dom1 dom2 in 171 | let rev1 = reverseq dom1 eq1 and rev2 = reverseq dom2 eq2 in 172 | inter comdom erf1 erf2 rev1 rev2 erf;; 173 | 174 | (* ------------------------------------------------------------------------- *) 175 | (* General n-saturation for n >= 1 *) 176 | (* ------------------------------------------------------------------------- *) 177 | 178 | let rec saturate n erf assigs allvars = 179 | let (eqv',_ as erf') = zero_saturate_and_check erf assigs in 180 | if n = 0 or truefalse eqv' then erf' else 181 | let (eqv'',_ as erf'') = splits n erf' allvars allvars in 182 | if eqv'' = eqv' then erf'' else saturate n erf'' [] allvars 183 | 184 | and splits n (eqv,_ as erf) allvars vars = 185 | match vars with 186 | [] -> erf 187 | | p::ovars -> 188 | if canonize eqv p <> p then splits n erf allvars ovars else 189 | let erf0 = saturate (n - 1) erf [p,Not True] allvars 190 | and erf1 = saturate (n - 1) erf [p,True] allvars in 191 | let (eqv',_ as erf') = stal_intersect erf0 erf1 erf in 192 | if truefalse eqv' then erf' else splits n erf' allvars ovars;; 193 | 194 | (* ------------------------------------------------------------------------- *) 195 | (* Saturate up to a limit. *) 196 | (* ------------------------------------------------------------------------- *) 197 | 198 | let rec saturate_upto vars n m trigs assigs = 199 | if n > m then failwith("Not "^(string_of_int m)^"-easy") else 200 | (print_string("*** Starting "^(string_of_int n)^"-saturation"); 201 | print_newline(); 202 | let (eqv,_) = saturate n (unequal,relevance trigs) assigs vars in 203 | truefalse eqv or saturate_upto vars (n + 1) m trigs assigs);; 204 | 205 | (* ------------------------------------------------------------------------- *) 206 | (* Overall function. *) 207 | (* ------------------------------------------------------------------------- *) 208 | 209 | let stalmarck fm = 210 | let include_trig (e,cqs) f = (e |-> union cqs (tryapplyl f e)) f in 211 | let fm' = psimplify(Not fm) in 212 | if fm' = False then true else if fm' = True then false else 213 | let p,triplets = triplicate fm' in 214 | let trigfn = itlist (itlist include_trig ** trigger) 215 | triplets undefined 216 | and vars = map (fun p -> Atom p) (unions(map atoms triplets)) in 217 | saturate_upto vars 0 2 (graph trigfn) [p,True];; 218 | 219 | (* ------------------------------------------------------------------------- *) 220 | (* Examples. *) 221 | (* ------------------------------------------------------------------------- *) 222 | 223 | START_INTERACTIVE;; 224 | time stalmarck (mk_adder_test 6 3);; 225 | END_INTERACTIVE;; 226 | -------------------------------------------------------------------------------- /code/OCaml/unif.ml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Unification for first order terms. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) 5 | (* ========================================================================= *) 6 | 7 | let rec istriv env x t = 8 | match t with 9 | Var y -> y = x or defined env y & istriv env x (apply env y) 10 | | Fn(f,args) -> exists (istriv env x) args & failwith "cyclic";; 11 | 12 | (* ------------------------------------------------------------------------- *) 13 | (* Main unification procedure *) 14 | (* ------------------------------------------------------------------------- *) 15 | 16 | let rec unify env eqs = 17 | match eqs with 18 | [] -> env 19 | | (Fn(f,fargs),Fn(g,gargs))::oth -> 20 | if f = g & length fargs = length gargs 21 | then unify env (zip fargs gargs @ oth) 22 | else failwith "impossible unification" 23 | | (Var x,t)::oth | (t,Var x)::oth -> 24 | if defined env x then unify env ((apply env x,t)::oth) 25 | else unify (if istriv env x t then env else (x|->t) env) oth;; 26 | 27 | (* ------------------------------------------------------------------------- *) 28 | (* Solve to obtain a single instantiation. *) 29 | (* ------------------------------------------------------------------------- *) 30 | 31 | let rec solve env = 32 | let env' = mapf (tsubst env) env in 33 | if env' = env then env else solve env';; 34 | 35 | (* ------------------------------------------------------------------------- *) 36 | (* Unification reaching a final solved form (often this isn't needed). *) 37 | (* ------------------------------------------------------------------------- *) 38 | 39 | let fullunify eqs = solve (unify undefined eqs);; 40 | 41 | (* ------------------------------------------------------------------------- *) 42 | (* Examples. *) 43 | (* ------------------------------------------------------------------------- *) 44 | 45 | let unify_and_apply eqs = 46 | let i = fullunify eqs in 47 | let apply (t1,t2) = tsubst i t1,tsubst i t2 in 48 | map apply eqs;; 49 | 50 | START_INTERACTIVE;; 51 | unify_and_apply [<<|f(x,g(y))|>>,<<|f(f(z),w)|>>];; 52 | 53 | unify_and_apply [<<|f(x,y)|>>,<<|f(y,x)|>>];; 54 | 55 | (**** unify_and_apply [<<|f(x,g(y))|>>,<<|f(y,x)|>>];; *****) 56 | 57 | unify_and_apply [<<|x_0|>>,<<|f(x_1,x_1)|>>; 58 | <<|x_1|>>,<<|f(x_2,x_2)|>>; 59 | <<|x_2|>>,<<|f(x_3,x_3)|>>];; 60 | END_INTERACTIVE;; 61 | -------------------------------------------------------------------------------- /code/OCaml/verbose_functions.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/OCaml/verbose_functions.ml -------------------------------------------------------------------------------- /code/README.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/README.txt -------------------------------------------------------------------------------- /code/SML/Init.thy: -------------------------------------------------------------------------------- 1 | theory Init 2 | imports Main 3 | begin 4 | 5 | SML_import {* val load = (fn _ => ()) *} 6 | SML_import {* val use = (fn _ => ()) *} 7 | 8 | SML_file "init.sml" 9 | SML_file "format.sml" 10 | SML_file "initialization.sml" 11 | SML_file "lib.sml" 12 | SML_file "intro.sml" 13 | SML_file "formulas.sml" 14 | SML_file "prop.sml" 15 | SML_file "fol.sml" 16 | SML_file "skolem.sml" 17 | SML_file "unif.sml" 18 | SML_file "tableaux.sml" 19 | SML_file "resolution.sml" 20 | SML_file "equal.sml" 21 | SML_file "order.sml" 22 | SML_file "eqelim.sml" 23 | SML_file "lcf.sml" 24 | SML_file "lcfprop.sml" 25 | SML_file "folderived.sml" 26 | SML_file "lcffol.sml" 27 | SML_file "tactics.sml" 28 | 29 | SML_export {* 30 | val ex = 31 | let val p = Atom(R("p",[])) 32 | val q = Atom(R("q",[])) 33 | in 34 | concl (lcftaut (Or(Imp(p,q),Imp(q,p)))) 35 | end 36 | *} 37 | 38 | ML {* ex *} 39 | 40 | SML_file "verbose_functions.sml" 41 | SML_file "full_test.sml" 42 | 43 | end 44 | -------------------------------------------------------------------------------- /code/SML/LICENSE.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/LICENSE.txt -------------------------------------------------------------------------------- /code/SML/NOTES.txt: -------------------------------------------------------------------------------- 1 | SML version 2 | === 3 | This is a translation to SML of the code in John Harrison's "Handbook of Practical Logic and Automated Reasoning". 4 | 5 | ### Running the program ### 6 | The program has been tested and run in Isabelle, Moscow ML, Standard ML of New Jersey and Poly/ML. 7 | 8 | In Isabelle you can simply open the Init.thy file. 9 | 10 | To use Moscow ML you run 11 | mosml init.ml 12 | 13 | To use Standard ML of New Jersey, first run 14 | sml 15 | and then in the presented interactive system write 16 | use "init_nj.sml";; 17 | 18 | You can also run it using Poly/ML. First run 19 | polyml 20 | and then in the presented interactive system write 21 | use "init_nj.sml";; 22 | 23 | ### Timing ### 24 | To test how fast your version of SML can load and run the program and its examples, you can run timing.sml in Moscow ML, or you can run timing_nj.sml in Standard ML of New Jersey or Poly/ML. You can also open Init.thy in Isabelle and use Isabelle menu Plugins / Isabelle / Timing panel to measure the time used. 25 | 26 | Results from timing the program in Windows 7 on a relatively weak laptop: 27 | 28 | Isabelle: 5.9 seconds 29 | Moscow ML: 38.3 seconds 30 | Standard ML of New Jersey: 26.6 seconds 31 | Poly/ML: 5.2 seconds 32 | 33 | (The program was run a couple of times with approximately the same results.) 34 | 35 | As can be seen, the program is fully loaded and fully run considerably faster in Poly/ML and Isabelle than in Moscow ML and Standard ML of New Jersey. 36 | 37 | ### Warnings ### 38 | The translation contains many warnings. Isabelle reports them as follows: 39 | 1. "Value identifier x has not been referenced." 40 | 2. "Pattern is not exhaustive." 41 | 3. "Matches are not exhaustive." 42 | These warnings could be avoided, but this would make the code less faithful to the OCaml version which in most cases contains the equivalent warnings. The above warnings 2 and 3 correspond to this OCaml warning: 43 | "Warning P: this pattern-matching is not exhaustive" 44 | Warning 1 could be avoided by introducing _'s in some of the patterns where the OCaml version uses named variables. 45 | 46 | ### Differences from OCaml version ### 47 | * SML does not have build-in polymorpic ordering and hashing. (Do, however, note that for instance Moscow ML actually has a polymorphic hash function called Polyhash.hash.) Therefore orderings and hash functions are explicitly defined for each datatype. For instance the ordering folfm_ord for fol formulas and the hash function t_hash for terms. This also means that many functions now also take an ordering and/or a hash function as arguments. An example is the apply function. Furthermore it means that the types of certain functions have been specialized. For instance, the apply function has a version specific for (string,'a) functions, namely apply_str. 48 | * Shallow/pointer comparison (== in ocaml) is not used. Like in the F# version (https://github.com/jack-pappas/fsharp-logic-examples/) the = is used instead. 49 | * In SML one cannot use "when"-guards in case-expressions like in OCaml. Therefore if-then-else is used in these cases. The best example of this is lcftab, where the case expression has been replaced with if-then-else. Another example is modus ponens where if-then-else is placed inside the case. 50 | * The OCaml version uses a preprocessor (camlp4 or camlp5) so that one can write for instance 51 | <> 52 | For the sake of working in any SML implementation this version does not use a preprocessor. Instead the function << is defined which takes a string and the element >> as arguments. Therefore the above example will be: 53 | <<"P(x) \\/ forall y.Q(y)">> 54 | It also means that the program contains some extra parentheses when a function takes a formula as input. For instance 55 | print_fol_formula <> 56 | becomes 57 | print_fol_formula (<<"P(x) \\/ forall y.Q(y)">>) 58 | * The OCaml version uses the OCaml format library. The SML translation contains a port of that library. However, the OCaml top-level flushes just before it asks for new input. This cannot easily be done in SML. Therefore the SML versions of the printing functions do a flush themselves. There is, however, for each of them also a version that does not flush. For instance print_fol_formula flushes, while print_fol_formula_aux does not. 59 | 60 | ### TODO ### 61 | The current version contains all of the code for Chapter 6 and the functions on which it depends. The rest of the book has yet to be translated. 62 | 63 | ### Useful resources ### 64 | Code and resources for "Handbook of Practical Logic and Automated Reasoning" 65 | http://www.cl.cam.ac.uk/~jrh13/atp/ 66 | 67 | Logic Programming in F# - Code and Examples from John Harrison's "Handbook of Practical Logic and Automated Reasoning" 68 | https://github.com/jack-pappas/fsharp-logic-examples/ 69 | 70 | How to run the OCaml version 71 | http://www.math.uni-bonn.de/ag/logik/teaching/2014SS/Seminar_Praktische_Logik.shtml 72 | 73 | Fast Mergeable Integer Maps (1998) by Chris Okasaki, Andrew Gill 74 | (On Patricia trees) 75 | http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452 76 | -------------------------------------------------------------------------------- /code/SML/Proven-Init.thy: -------------------------------------------------------------------------------- 1 | theory "Proven-Init" 2 | imports Main 3 | begin 4 | 5 | SML_import {* val load = (fn _ => ()) *} 6 | SML_import {* val use = (fn _ => ()) *} 7 | 8 | SML_file "init.sml" 9 | SML_file "format.sml" 10 | SML_file "initialization.sml" 11 | SML_file "lib.sml" 12 | SML_file "intro.sml" 13 | SML_file "formulas.sml" 14 | SML_file "prop.sml" 15 | SML_file "fol.sml" 16 | SML_file "skolem.sml" 17 | SML_file "unif.sml" 18 | SML_file "tableaux.sml" 19 | SML_file "resolution.sml" 20 | SML_file "equal.sml" 21 | SML_file "order.sml" 22 | SML_file "eqelim.sml" 23 | SML_file "Proven-lcf.sml" 24 | SML_file "Proven-init.sml" 25 | SML_file "lcfprop.sml" 26 | SML_file "folderived.sml" 27 | SML_file "lcffol.sml" 28 | SML_file "tactics.sml" 29 | 30 | SML_export {* 31 | val ex = 32 | let val p = Atom(R("p",[])) 33 | val q = Atom(R("q",[])) 34 | in 35 | concl (lcftaut (Or(Imp(p,q),Imp(q,p)))) 36 | end 37 | *} 38 | 39 | ML {* ex *} 40 | 41 | SML_file "verbose_functions.sml" 42 | SML_file "full_test.sml" 43 | 44 | end 45 | -------------------------------------------------------------------------------- /code/SML/Proven-init.sml: -------------------------------------------------------------------------------- 1 | (* ========================================================================= *) 2 | (* Initialize theorem proving example code. *) 3 | (* *) 4 | (* Copyright (c) 2003-2007, John Harrison. *) 5 | (* Copyright (c) 2015-2016, Anders Schlichtkrull and Jørgen Villadsen *) 6 | (* Copyright (c) 2016, Alexander Birch Jensen *) 7 | (* All rights reserved. (See "LICENSE.txt" for details.) *) 8 | (* ========================================================================= *) 9 | 10 | datatype dummy_interactive = START_INTERACTIVE | END_INTERACTIVE; 11 | use "initialization.sml"; 12 | use "lib.sml"; 13 | use "intro.sml"; 14 | use "formulas.sml"; 15 | use "prop.sml"; 16 | use "fol.sml"; 17 | use "skolem.sml"; 18 | use "unif.sml"; 19 | use "tableaux.sml"; 20 | use "resolution.sml"; 21 | use "equal.sml"; 22 | use "order.sml"; 23 | use "eqelim.sml"; 24 | use "Proven-lcf.sml"; 25 | 26 | open Proven; 27 | 28 | fun print_thm_aux th = ( 29 | open_box 0; 30 | print_string "|-"; print_space(); 31 | open_box 0; print_formula_aux print_atom_aux (concl th); close_box(); 32 | close_box() 33 | ); 34 | 35 | fun print_thm th = (print_thm_aux th; print_flush ()); 36 | 37 | use "lcfprop.sml"; 38 | use "folderived.sml"; 39 | use "lcffol.sml"; 40 | 41 | type thm = fol_thm; 42 | 43 | use "tactics.sml"; 44 | -------------------------------------------------------------------------------- /code/SML/Proven-init_nj.sml: -------------------------------------------------------------------------------- 1 | fun load s = (); 2 | use "Proven-init.sml"; 3 | -------------------------------------------------------------------------------- /code/SML/Proven-lcf.sml: -------------------------------------------------------------------------------- 1 | structure Proven :> sig 2 | type nat 3 | type fol_thm 4 | val gen : string -> fol_thm -> fol_thm 5 | val axiom_or : fol formula -> fol formula -> fol_thm 6 | val axiom_and : fol formula -> fol formula -> fol_thm 7 | val axiom_not : fol formula -> fol_thm 8 | val axiom_true : fol_thm 9 | val concl : fol_thm -> fol formula 10 | val modusponens : fol_thm -> fol_thm -> fol_thm 11 | val axiom_addimp : fol formula -> fol formula -> fol_thm 12 | val axiom_allimp : string -> fol formula -> fol formula -> fol_thm 13 | val axiom_eqrefl : term -> fol_thm 14 | val axiom_exists : string -> fol formula -> fol_thm 15 | val axiom_impall : string -> fol formula -> fol_thm 16 | val axiom_impiff : fol formula -> fol formula -> fol_thm 17 | val axiom_funcong : string -> term list -> term list -> fol_thm 18 | val axiom_iffimp1 : fol formula -> fol formula -> fol_thm 19 | val axiom_iffimp2 : fol formula -> fol formula -> fol_thm 20 | val axiom_existseq : string -> term -> fol_thm 21 | val axiom_predcong : string -> term list -> term list -> fol_thm 22 | val axiom_doubleneg : fol formula -> fol_thm 23 | val axiom_distribimp : fol formula -> fol formula -> fol formula -> fol_thm 24 | end = struct 25 | 26 | type 'a equal = {equal : 'a -> 'a -> bool}; 27 | val equal = #equal : 'a equal -> 'a -> 'a -> bool; 28 | 29 | fun eq A_ a b = equal A_ a b; 30 | 31 | fun equal_list A_ [] (x21 :: x22) = false 32 | | equal_list A_ (x21 :: x22) [] = false 33 | | equal_list A_ (x21 :: x22) (y21 :: y22) = 34 | eq A_ x21 y21 andalso equal_list A_ x22 y22 35 | | equal_list A_ [] [] = true; 36 | 37 | fun equal_tm () = {equal = equal_tma} : term equal 38 | and equal_tma (Var x1) (Fn (x21, x22)) = false 39 | | equal_tma (Fn (x21, x22)) (Var x1) = false 40 | | equal_tma (Fn (x21, x22)) (Fn (y21, y22)) = 41 | ((x21 : string) = y21) andalso equal_list (equal_tm ()) x22 y22 42 | | equal_tma (Var x1) (Var y1) = ((x1 : string) = y1); 43 | val equal_tm = equal_tm (); 44 | 45 | fun equal_fola (R (x1, x2)) (R (y1, y2)) = 46 | ((x1 : string) = y1) andalso equal_list equal_tm x2 y2; 47 | 48 | val equal_fol = {equal = equal_fola} : fol equal; 49 | 50 | datatype nat = Zero_nat | Suc of nat; 51 | 52 | datatype nibble = Nibble0 | Nibble1 | Nibble2 | Nibble3 | Nibble4 | Nibble5 | 53 | Nibble6 | Nibble7 | Nibble8 | Nibble9 | NibbleA | NibbleB | NibbleC | NibbleD 54 | | NibbleE | NibbleF; 55 | 56 | datatype fol_thm = Thm of fol formula; 57 | 58 | fun zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys 59 | | zip xs [] = [] 60 | | zip [] ys = []; 61 | 62 | fun gen x p = let 63 | val Thm pa = p; 64 | in 65 | Thm (Forall (x, pa)) 66 | end; 67 | 68 | fun mk_eq u v = Atom (R ("=", [u, v])); 69 | 70 | fun map f [] = [] 71 | | map f (x21 :: x22) = f x21 :: map f x22; 72 | 73 | fun zip_eq l r = map (fn (a, b) => mk_eq a b) (zip l r); 74 | 75 | fun occurs_in_list uu [] = false 76 | | occurs_in_list s (h :: t) = occurs_in s h orelse occurs_in_list s t 77 | and occurs_in s (Var x) = equal_tma s (Var x) 78 | | occurs_in s (Fn (i, l)) = equal_tma s (Fn (i, l)) orelse occurs_in_list s l; 79 | 80 | fun free_in uu True = false 81 | | free_in uv False = false 82 | | free_in u (Atom a) = let 83 | val R (_, aa) = a; 84 | in 85 | occurs_in_list u aa 86 | end 87 | | free_in u (Imp (p, q)) = free_in u p orelse free_in u q 88 | | free_in u (Iff (p, q)) = free_in u p orelse free_in u q 89 | | free_in u (And (p, q)) = free_in u p orelse free_in u q 90 | | free_in u (Or (p, q)) = free_in u p orelse free_in u q 91 | | free_in u (Not p) = free_in u p 92 | | free_in u (Exists (x, p)) = not (occurs_in (Var x) u) andalso free_in u p 93 | | free_in u (Forall (x, p)) = not (occurs_in (Var x) u) andalso free_in u p; 94 | 95 | fun gen_length n (x :: xs) = gen_length (Suc n) xs 96 | | gen_length n [] = n; 97 | 98 | fun axiom_or p q = Thm (Iff ((Or (p, q)), (Not (And ((Not p), (Not q)))))); 99 | 100 | fun axiom_and p q = 101 | Thm (Iff ((And (p, q)), (Imp ((Imp (p, (Imp (q, False)))), False)))); 102 | 103 | fun axiom_not p = Thm (Iff ((Not p), (Imp (p, False)))); 104 | 105 | fun imp_chain [] p = p 106 | | imp_chain (q :: l) p = Imp (q, (imp_chain l p)); 107 | 108 | val axiom_true : fol_thm = Thm (Iff (True, (Imp (False, False)))); 109 | 110 | fun equal_fm A_ (Exists (x91, x92)) (Forall (x101, x102)) = false 111 | | equal_fm A_ (Forall (x101, x102)) (Exists (x91, x92)) = false 112 | | equal_fm A_ (Not x8) (Forall (x101, x102)) = false 113 | | equal_fm A_ (Forall (x101, x102)) (Not x8) = false 114 | | equal_fm A_ (Not x8) (Exists (x91, x92)) = false 115 | | equal_fm A_ (Exists (x91, x92)) (Not x8) = false 116 | | equal_fm A_ (Or (x71, x72)) (Forall (x101, x102)) = false 117 | | equal_fm A_ (Forall (x101, x102)) (Or (x71, x72)) = false 118 | | equal_fm A_ (Or (x71, x72)) (Exists (x91, x92)) = false 119 | | equal_fm A_ (Exists (x91, x92)) (Or (x71, x72)) = false 120 | | equal_fm A_ (Or (x71, x72)) (Not x8) = false 121 | | equal_fm A_ (Not x8) (Or (x71, x72)) = false 122 | | equal_fm A_ (And (x61, x62)) (Forall (x101, x102)) = false 123 | | equal_fm A_ (Forall (x101, x102)) (And (x61, x62)) = false 124 | | equal_fm A_ (And (x61, x62)) (Exists (x91, x92)) = false 125 | | equal_fm A_ (Exists (x91, x92)) (And (x61, x62)) = false 126 | | equal_fm A_ (And (x61, x62)) (Not x8) = false 127 | | equal_fm A_ (Not x8) (And (x61, x62)) = false 128 | | equal_fm A_ (And (x61, x62)) (Or (x71, x72)) = false 129 | | equal_fm A_ (Or (x71, x72)) (And (x61, x62)) = false 130 | | equal_fm A_ (Iff (x51, x52)) (Forall (x101, x102)) = false 131 | | equal_fm A_ (Forall (x101, x102)) (Iff (x51, x52)) = false 132 | | equal_fm A_ (Iff (x51, x52)) (Exists (x91, x92)) = false 133 | | equal_fm A_ (Exists (x91, x92)) (Iff (x51, x52)) = false 134 | | equal_fm A_ (Iff (x51, x52)) (Not x8) = false 135 | | equal_fm A_ (Not x8) (Iff (x51, x52)) = false 136 | | equal_fm A_ (Iff (x51, x52)) (Or (x71, x72)) = false 137 | | equal_fm A_ (Or (x71, x72)) (Iff (x51, x52)) = false 138 | | equal_fm A_ (Iff (x51, x52)) (And (x61, x62)) = false 139 | | equal_fm A_ (And (x61, x62)) (Iff (x51, x52)) = false 140 | | equal_fm A_ (Imp (x41, x42)) (Forall (x101, x102)) = false 141 | | equal_fm A_ (Forall (x101, x102)) (Imp (x41, x42)) = false 142 | | equal_fm A_ (Imp (x41, x42)) (Exists (x91, x92)) = false 143 | | equal_fm A_ (Exists (x91, x92)) (Imp (x41, x42)) = false 144 | | equal_fm A_ (Imp (x41, x42)) (Not x8) = false 145 | | equal_fm A_ (Not x8) (Imp (x41, x42)) = false 146 | | equal_fm A_ (Imp (x41, x42)) (Or (x71, x72)) = false 147 | | equal_fm A_ (Or (x71, x72)) (Imp (x41, x42)) = false 148 | | equal_fm A_ (Imp (x41, x42)) (And (x61, x62)) = false 149 | | equal_fm A_ (And (x61, x62)) (Imp (x41, x42)) = false 150 | | equal_fm A_ (Imp (x41, x42)) (Iff (x51, x52)) = false 151 | | equal_fm A_ (Iff (x51, x52)) (Imp (x41, x42)) = false 152 | | equal_fm A_ (Atom x3) (Forall (x101, x102)) = false 153 | | equal_fm A_ (Forall (x101, x102)) (Atom x3) = false 154 | | equal_fm A_ (Atom x3) (Exists (x91, x92)) = false 155 | | equal_fm A_ (Exists (x91, x92)) (Atom x3) = false 156 | | equal_fm A_ (Atom x3) (Not x8) = false 157 | | equal_fm A_ (Not x8) (Atom x3) = false 158 | | equal_fm A_ (Atom x3) (Or (x71, x72)) = false 159 | | equal_fm A_ (Or (x71, x72)) (Atom x3) = false 160 | | equal_fm A_ (Atom x3) (And (x61, x62)) = false 161 | | equal_fm A_ (And (x61, x62)) (Atom x3) = false 162 | | equal_fm A_ (Atom x3) (Iff (x51, x52)) = false 163 | | equal_fm A_ (Iff (x51, x52)) (Atom x3) = false 164 | | equal_fm A_ (Atom x3) (Imp (x41, x42)) = false 165 | | equal_fm A_ (Imp (x41, x42)) (Atom x3) = false 166 | | equal_fm A_ False (Forall (x101, x102)) = false 167 | | equal_fm A_ (Forall (x101, x102)) False = false 168 | | equal_fm A_ False (Exists (x91, x92)) = false 169 | | equal_fm A_ (Exists (x91, x92)) False = false 170 | | equal_fm A_ False (Not x8) = false 171 | | equal_fm A_ (Not x8) False = false 172 | | equal_fm A_ False (Or (x71, x72)) = false 173 | | equal_fm A_ (Or (x71, x72)) False = false 174 | | equal_fm A_ False (And (x61, x62)) = false 175 | | equal_fm A_ (And (x61, x62)) False = false 176 | | equal_fm A_ False (Iff (x51, x52)) = false 177 | | equal_fm A_ (Iff (x51, x52)) False = false 178 | | equal_fm A_ False (Imp (x41, x42)) = false 179 | | equal_fm A_ (Imp (x41, x42)) False = false 180 | | equal_fm A_ False (Atom x3) = false 181 | | equal_fm A_ (Atom x3) False = false 182 | | equal_fm A_ True (Forall (x101, x102)) = false 183 | | equal_fm A_ (Forall (x101, x102)) True = false 184 | | equal_fm A_ True (Exists (x91, x92)) = false 185 | | equal_fm A_ (Exists (x91, x92)) True = false 186 | | equal_fm A_ True (Not x8) = false 187 | | equal_fm A_ (Not x8) True = false 188 | | equal_fm A_ True (Or (x71, x72)) = false 189 | | equal_fm A_ (Or (x71, x72)) True = false 190 | | equal_fm A_ True (And (x61, x62)) = false 191 | | equal_fm A_ (And (x61, x62)) True = false 192 | | equal_fm A_ True (Iff (x51, x52)) = false 193 | | equal_fm A_ (Iff (x51, x52)) True = false 194 | | equal_fm A_ True (Imp (x41, x42)) = false 195 | | equal_fm A_ (Imp (x41, x42)) True = false 196 | | equal_fm A_ True (Atom x3) = false 197 | | equal_fm A_ (Atom x3) True = false 198 | | equal_fm A_ True False = false 199 | | equal_fm A_ False True = false 200 | | equal_fm A_ (Forall (x101, x102)) (Forall (y101, y102)) = 201 | ((x101 : string) = y101) andalso equal_fm A_ x102 y102 202 | | equal_fm A_ (Exists (x91, x92)) (Exists (y91, y92)) = 203 | ((x91 : string) = y91) andalso equal_fm A_ x92 y92 204 | | equal_fm A_ (Not x8) (Not y8) = equal_fm A_ x8 y8 205 | | equal_fm A_ (Or (x71, x72)) (Or (y71, y72)) = 206 | equal_fm A_ x71 y71 andalso equal_fm A_ x72 y72 207 | | equal_fm A_ (And (x61, x62)) (And (y61, y62)) = 208 | equal_fm A_ x61 y61 andalso equal_fm A_ x62 y62 209 | | equal_fm A_ (Iff (x51, x52)) (Iff (y51, y52)) = 210 | equal_fm A_ x51 y51 andalso equal_fm A_ x52 y52 211 | | equal_fm A_ (Imp (x41, x42)) (Imp (y41, y42)) = 212 | equal_fm A_ x41 y41 andalso equal_fm A_ x42 y42 213 | | equal_fm A_ (Atom x3) (Atom y3) = eq A_ x3 y3 214 | | equal_fm A_ False False = true 215 | | equal_fm A_ True True = true; 216 | 217 | fun concl (Thm x) = x; 218 | 219 | fun modusponens pq p = 220 | (case concl pq of True => Thm True | False => Thm True | Atom _ => Thm True 221 | | Imp (pa, q) => let 222 | val pb = concl p; 223 | in 224 | (if equal_fm equal_fol pb pa then Thm q else Thm True) 225 | end 226 | | Iff (_, _) => Thm True | And (_, _) => Thm True | Or (_, _) => Thm True 227 | | Not _ => Thm True | Exists (_, _) => Thm True 228 | | Forall (_, _) => Thm True); 229 | 230 | fun axiom_addimp p q = Thm (Imp (p, (Imp (q, p)))); 231 | 232 | fun axiom_allimp x p q = 233 | Thm (Imp ((Forall (x, (Imp (p, q)))), (Imp ((Forall (x, p)), (Forall (x, q)))))); 234 | 235 | fun axiom_eqrefl u = Thm (mk_eq u u); 236 | 237 | fun axiom_exists x p = Thm (Iff ((Exists (x, p)), (Not (Forall (x, (Not p)))))); 238 | 239 | fun axiom_impall x p = 240 | (if not (free_in (Var x) p) then Thm (Imp (p, (Forall (x, p)))) 241 | else Thm True); 242 | 243 | fun axiom_impiff p q = 244 | Thm (Imp ((Imp (p, q)), (Imp ((Imp (q, p)), (Iff (p, q)))))); 245 | 246 | fun size_list x = gen_length Zero_nat x; 247 | 248 | fun equal_nat Zero_nat (Suc x2) = false 249 | | equal_nat (Suc x2) Zero_nat = false 250 | | equal_nat (Suc x2) (Suc y2) = equal_nat x2 y2 251 | | equal_nat Zero_nat Zero_nat = true; 252 | 253 | fun axiom_funcong i l r = 254 | (if equal_nat (size_list l) (size_list r) 255 | then Thm (imp_chain (zip_eq l r) (mk_eq (Fn (i, l)) (Fn (i, r)))) 256 | else Thm True); 257 | 258 | fun axiom_iffimp1 p q = Thm (Imp ((Iff (p, q)), (Imp (p, q)))); 259 | 260 | fun axiom_iffimp2 p q = Thm (Imp ((Iff (p, q)), (Imp (q, p)))); 261 | 262 | fun axiom_existseq x u = 263 | (if not (occurs_in (Var x) u) then Thm (Exists (x, (mk_eq (Var x) u))) 264 | else Thm True); 265 | 266 | fun axiom_predcong i l r = 267 | (if equal_nat (size_list l) (size_list r) 268 | then Thm (imp_chain (zip_eq l r) 269 | (Imp ((Atom (R (i, l))), (Atom (R (i, r)))))) 270 | else Thm True); 271 | 272 | fun axiom_doubleneg p = Thm (Imp ((Imp ((Imp (p, False)), False)), p)); 273 | 274 | fun axiom_distribimp p q r = 275 | Thm (Imp ((Imp (p, (Imp (q, r)))), (Imp ((Imp (p, q)), (Imp (p, r)))))); 276 | 277 | end; (*struct Proven*) 278 | -------------------------------------------------------------------------------- /code/SML/Proven.sml: -------------------------------------------------------------------------------- 1 | structure Proven : sig 2 | type nat 3 | type fol_thm 4 | val gen : string -> fol_thm -> fol_thm 5 | val axiom_or : fol formula -> fol formula -> fol_thm 6 | val axiom_and : fol formula -> fol formula -> fol_thm 7 | val axiom_not : fol formula -> fol_thm 8 | val axiom_true : fol_thm 9 | val concl : fol_thm -> fol formula 10 | val modusponens : fol_thm -> fol_thm -> fol_thm 11 | val axiom_addimp : fol formula -> fol formula -> fol_thm 12 | val axiom_allimp : string -> fol formula -> fol formula -> fol_thm 13 | val axiom_eqrefl : term -> fol_thm 14 | val axiom_exists : string -> fol formula -> fol_thm 15 | val axiom_impall : string -> fol formula -> fol_thm 16 | val axiom_impiff : fol formula -> fol formula -> fol_thm 17 | val axiom_funcong : string -> term list -> term list -> fol_thm 18 | val axiom_iffimp1 : fol formula -> fol formula -> fol_thm 19 | val axiom_iffimp2 : fol formula -> fol formula -> fol_thm 20 | val axiom_existseq : string -> term -> fol_thm 21 | val axiom_predcong : string -> term list -> term list -> fol_thm 22 | val axiom_doubleneg : fol formula -> fol_thm 23 | val axiom_distribimp : fol formula -> fol formula -> fol formula -> fol_thm 24 | end = struct 25 | 26 | type 'a equal = {equal : 'a -> 'a -> bool}; 27 | val equal = #equal : 'a equal -> 'a -> 'a -> bool; 28 | 29 | fun eq A_ a b = equal A_ a b; 30 | 31 | fun equal_list A_ [] (x21 :: x22) = false 32 | | equal_list A_ (x21 :: x22) [] = false 33 | | equal_list A_ (x21 :: x22) (y21 :: y22) = 34 | eq A_ x21 y21 andalso equal_list A_ x22 y22 35 | | equal_list A_ [] [] = true; 36 | 37 | fun equal_tm () = {equal = equal_tma} : term equal 38 | and equal_tma (Var x1) (Fn (x21, x22)) = false 39 | | equal_tma (Fn (x21, x22)) (Var x1) = false 40 | | equal_tma (Fn (x21, x22)) (Fn (y21, y22)) = 41 | ((x21 : string) = y21) andalso equal_list (equal_tm ()) x22 y22 42 | | equal_tma (Var x1) (Var y1) = ((x1 : string) = y1); 43 | val equal_tm = equal_tm (); 44 | 45 | fun equal_fola (R (x1, x2)) (R (y1, y2)) = 46 | ((x1 : string) = y1) andalso equal_list equal_tm x2 y2; 47 | 48 | val equal_fol = {equal = equal_fola} : fol equal; 49 | 50 | datatype nat = Zero_nat | Suc of nat; 51 | 52 | datatype nibble = Nibble0 | Nibble1 | Nibble2 | Nibble3 | Nibble4 | Nibble5 | 53 | Nibble6 | Nibble7 | Nibble8 | Nibble9 | NibbleA | NibbleB | NibbleC | NibbleD 54 | | NibbleE | NibbleF; 55 | 56 | datatype fol_thm = Thm of fol formula; 57 | 58 | fun zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys 59 | | zip xs [] = [] 60 | | zip [] ys = []; 61 | 62 | fun gen x p = let 63 | val Thm pa = p; 64 | in 65 | Thm (Forall (x, pa)) 66 | end; 67 | 68 | fun mk_eq u v = Atom (R ("=", [u, v])); 69 | 70 | fun map f [] = [] 71 | | map f (x21 :: x22) = f x21 :: map f x22; 72 | 73 | fun zip_eq l r = map (fn (a, b) => mk_eq a b) (zip l r); 74 | 75 | fun occurs_in_list uu [] = false 76 | | occurs_in_list s (h :: t) = occurs_in s h orelse occurs_in_list s t 77 | and occurs_in s (Var x) = equal_tma s (Var x) 78 | | occurs_in s (Fn (i, l)) = equal_tma s (Fn (i, l)) orelse occurs_in_list s l; 79 | 80 | fun free_in uu True = false 81 | | free_in uv False = false 82 | | free_in u (Atom a) = let 83 | val R (_, aa) = a; 84 | in 85 | occurs_in_list u aa 86 | end 87 | | free_in u (Imp (p, q)) = free_in u p orelse free_in u q 88 | | free_in u (Iff (p, q)) = free_in u p orelse free_in u q 89 | | free_in u (And (p, q)) = free_in u p orelse free_in u q 90 | | free_in u (Or (p, q)) = free_in u p orelse free_in u q 91 | | free_in u (Not p) = free_in u p 92 | | free_in u (Exists (x, p)) = not (occurs_in (Var x) u) andalso free_in u p 93 | | free_in u (Forall (x, p)) = not (occurs_in (Var x) u) andalso free_in u p; 94 | 95 | fun gen_length n (x :: xs) = gen_length (Suc n) xs 96 | | gen_length n [] = n; 97 | 98 | fun axiom_or p q = Thm (Iff ((Or (p, q)), (Not (And ((Not p), (Not q)))))); 99 | 100 | fun axiom_and p q = 101 | Thm (Iff ((And (p, q)), (Imp ((Imp (p, (Imp (q, False)))), False)))); 102 | 103 | fun axiom_not p = Thm (Iff ((Not p), (Imp (p, False)))); 104 | 105 | fun imp_chain [] p = p 106 | | imp_chain (q :: l) p = Imp (q, (imp_chain l p)); 107 | 108 | val axiom_true : fol_thm = Thm (Iff (True, (Imp (False, False)))); 109 | 110 | fun equal_fm A_ (Exists (x91, x92)) (Forall (x101, x102)) = false 111 | | equal_fm A_ (Forall (x101, x102)) (Exists (x91, x92)) = false 112 | | equal_fm A_ (Not x8) (Forall (x101, x102)) = false 113 | | equal_fm A_ (Forall (x101, x102)) (Not x8) = false 114 | | equal_fm A_ (Not x8) (Exists (x91, x92)) = false 115 | | equal_fm A_ (Exists (x91, x92)) (Not x8) = false 116 | | equal_fm A_ (Or (x71, x72)) (Forall (x101, x102)) = false 117 | | equal_fm A_ (Forall (x101, x102)) (Or (x71, x72)) = false 118 | | equal_fm A_ (Or (x71, x72)) (Exists (x91, x92)) = false 119 | | equal_fm A_ (Exists (x91, x92)) (Or (x71, x72)) = false 120 | | equal_fm A_ (Or (x71, x72)) (Not x8) = false 121 | | equal_fm A_ (Not x8) (Or (x71, x72)) = false 122 | | equal_fm A_ (And (x61, x62)) (Forall (x101, x102)) = false 123 | | equal_fm A_ (Forall (x101, x102)) (And (x61, x62)) = false 124 | | equal_fm A_ (And (x61, x62)) (Exists (x91, x92)) = false 125 | | equal_fm A_ (Exists (x91, x92)) (And (x61, x62)) = false 126 | | equal_fm A_ (And (x61, x62)) (Not x8) = false 127 | | equal_fm A_ (Not x8) (And (x61, x62)) = false 128 | | equal_fm A_ (And (x61, x62)) (Or (x71, x72)) = false 129 | | equal_fm A_ (Or (x71, x72)) (And (x61, x62)) = false 130 | | equal_fm A_ (Iff (x51, x52)) (Forall (x101, x102)) = false 131 | | equal_fm A_ (Forall (x101, x102)) (Iff (x51, x52)) = false 132 | | equal_fm A_ (Iff (x51, x52)) (Exists (x91, x92)) = false 133 | | equal_fm A_ (Exists (x91, x92)) (Iff (x51, x52)) = false 134 | | equal_fm A_ (Iff (x51, x52)) (Not x8) = false 135 | | equal_fm A_ (Not x8) (Iff (x51, x52)) = false 136 | | equal_fm A_ (Iff (x51, x52)) (Or (x71, x72)) = false 137 | | equal_fm A_ (Or (x71, x72)) (Iff (x51, x52)) = false 138 | | equal_fm A_ (Iff (x51, x52)) (And (x61, x62)) = false 139 | | equal_fm A_ (And (x61, x62)) (Iff (x51, x52)) = false 140 | | equal_fm A_ (Imp (x41, x42)) (Forall (x101, x102)) = false 141 | | equal_fm A_ (Forall (x101, x102)) (Imp (x41, x42)) = false 142 | | equal_fm A_ (Imp (x41, x42)) (Exists (x91, x92)) = false 143 | | equal_fm A_ (Exists (x91, x92)) (Imp (x41, x42)) = false 144 | | equal_fm A_ (Imp (x41, x42)) (Not x8) = false 145 | | equal_fm A_ (Not x8) (Imp (x41, x42)) = false 146 | | equal_fm A_ (Imp (x41, x42)) (Or (x71, x72)) = false 147 | | equal_fm A_ (Or (x71, x72)) (Imp (x41, x42)) = false 148 | | equal_fm A_ (Imp (x41, x42)) (And (x61, x62)) = false 149 | | equal_fm A_ (And (x61, x62)) (Imp (x41, x42)) = false 150 | | equal_fm A_ (Imp (x41, x42)) (Iff (x51, x52)) = false 151 | | equal_fm A_ (Iff (x51, x52)) (Imp (x41, x42)) = false 152 | | equal_fm A_ (Atom x3) (Forall (x101, x102)) = false 153 | | equal_fm A_ (Forall (x101, x102)) (Atom x3) = false 154 | | equal_fm A_ (Atom x3) (Exists (x91, x92)) = false 155 | | equal_fm A_ (Exists (x91, x92)) (Atom x3) = false 156 | | equal_fm A_ (Atom x3) (Not x8) = false 157 | | equal_fm A_ (Not x8) (Atom x3) = false 158 | | equal_fm A_ (Atom x3) (Or (x71, x72)) = false 159 | | equal_fm A_ (Or (x71, x72)) (Atom x3) = false 160 | | equal_fm A_ (Atom x3) (And (x61, x62)) = false 161 | | equal_fm A_ (And (x61, x62)) (Atom x3) = false 162 | | equal_fm A_ (Atom x3) (Iff (x51, x52)) = false 163 | | equal_fm A_ (Iff (x51, x52)) (Atom x3) = false 164 | | equal_fm A_ (Atom x3) (Imp (x41, x42)) = false 165 | | equal_fm A_ (Imp (x41, x42)) (Atom x3) = false 166 | | equal_fm A_ False (Forall (x101, x102)) = false 167 | | equal_fm A_ (Forall (x101, x102)) False = false 168 | | equal_fm A_ False (Exists (x91, x92)) = false 169 | | equal_fm A_ (Exists (x91, x92)) False = false 170 | | equal_fm A_ False (Not x8) = false 171 | | equal_fm A_ (Not x8) False = false 172 | | equal_fm A_ False (Or (x71, x72)) = false 173 | | equal_fm A_ (Or (x71, x72)) False = false 174 | | equal_fm A_ False (And (x61, x62)) = false 175 | | equal_fm A_ (And (x61, x62)) False = false 176 | | equal_fm A_ False (Iff (x51, x52)) = false 177 | | equal_fm A_ (Iff (x51, x52)) False = false 178 | | equal_fm A_ False (Imp (x41, x42)) = false 179 | | equal_fm A_ (Imp (x41, x42)) False = false 180 | | equal_fm A_ False (Atom x3) = false 181 | | equal_fm A_ (Atom x3) False = false 182 | | equal_fm A_ True (Forall (x101, x102)) = false 183 | | equal_fm A_ (Forall (x101, x102)) True = false 184 | | equal_fm A_ True (Exists (x91, x92)) = false 185 | | equal_fm A_ (Exists (x91, x92)) True = false 186 | | equal_fm A_ True (Not x8) = false 187 | | equal_fm A_ (Not x8) True = false 188 | | equal_fm A_ True (Or (x71, x72)) = false 189 | | equal_fm A_ (Or (x71, x72)) True = false 190 | | equal_fm A_ True (And (x61, x62)) = false 191 | | equal_fm A_ (And (x61, x62)) True = false 192 | | equal_fm A_ True (Iff (x51, x52)) = false 193 | | equal_fm A_ (Iff (x51, x52)) True = false 194 | | equal_fm A_ True (Imp (x41, x42)) = false 195 | | equal_fm A_ (Imp (x41, x42)) True = false 196 | | equal_fm A_ True (Atom x3) = false 197 | | equal_fm A_ (Atom x3) True = false 198 | | equal_fm A_ True False = false 199 | | equal_fm A_ False True = false 200 | | equal_fm A_ (Forall (x101, x102)) (Forall (y101, y102)) = 201 | ((x101 : string) = y101) andalso equal_fm A_ x102 y102 202 | | equal_fm A_ (Exists (x91, x92)) (Exists (y91, y92)) = 203 | ((x91 : string) = y91) andalso equal_fm A_ x92 y92 204 | | equal_fm A_ (Not x8) (Not y8) = equal_fm A_ x8 y8 205 | | equal_fm A_ (Or (x71, x72)) (Or (y71, y72)) = 206 | equal_fm A_ x71 y71 andalso equal_fm A_ x72 y72 207 | | equal_fm A_ (And (x61, x62)) (And (y61, y62)) = 208 | equal_fm A_ x61 y61 andalso equal_fm A_ x62 y62 209 | | equal_fm A_ (Iff (x51, x52)) (Iff (y51, y52)) = 210 | equal_fm A_ x51 y51 andalso equal_fm A_ x52 y52 211 | | equal_fm A_ (Imp (x41, x42)) (Imp (y41, y42)) = 212 | equal_fm A_ x41 y41 andalso equal_fm A_ x42 y42 213 | | equal_fm A_ (Atom x3) (Atom y3) = eq A_ x3 y3 214 | | equal_fm A_ False False = true 215 | | equal_fm A_ True True = true; 216 | 217 | fun concl (Thm x) = x; 218 | 219 | fun modusponens pq p = 220 | (case concl pq of True => Thm True | False => Thm True | Atom _ => Thm True 221 | | Imp (pa, q) => let 222 | val pb = concl p; 223 | in 224 | (if equal_fm equal_fol pb pa then Thm q else Thm True) 225 | end 226 | | Iff (_, _) => Thm True | And (_, _) => Thm True | Or (_, _) => Thm True 227 | | Not _ => Thm True | Exists (_, _) => Thm True 228 | | Forall (_, _) => Thm True); 229 | 230 | fun axiom_addimp p q = Thm (Imp (p, (Imp (q, p)))); 231 | 232 | fun axiom_allimp x p q = 233 | Thm (Imp ((Forall (x, (Imp (p, q)))), (Imp ((Forall (x, p)), (Forall (x, q)))))); 234 | 235 | fun axiom_eqrefl u = Thm (mk_eq u u); 236 | 237 | fun axiom_exists x p = Thm (Iff ((Exists (x, p)), (Not (Forall (x, (Not p)))))); 238 | 239 | fun axiom_impall x p = 240 | (if not (free_in (Var x) p) then Thm (Imp (p, (Forall (x, p)))) 241 | else Thm True); 242 | 243 | fun axiom_impiff p q = 244 | Thm (Imp ((Imp (p, q)), (Imp ((Imp (q, p)), (Iff (p, q)))))); 245 | 246 | fun size_list x = gen_length Zero_nat x; 247 | 248 | fun equal_nat Zero_nat (Suc x2) = false 249 | | equal_nat (Suc x2) Zero_nat = false 250 | | equal_nat (Suc x2) (Suc y2) = equal_nat x2 y2 251 | | equal_nat Zero_nat Zero_nat = true; 252 | 253 | fun axiom_funcong i l r = 254 | (if equal_nat (size_list l) (size_list r) 255 | then Thm (imp_chain (zip_eq l r) (mk_eq (Fn (i, l)) (Fn (i, r)))) 256 | else Thm True); 257 | 258 | fun axiom_iffimp1 p q = Thm (Imp ((Iff (p, q)), (Imp (p, q)))); 259 | 260 | fun axiom_iffimp2 p q = Thm (Imp ((Iff (p, q)), (Imp (q, p)))); 261 | 262 | fun axiom_existseq x u = 263 | (if not (occurs_in (Var x) u) then Thm (Exists (x, (mk_eq (Var x) u))) 264 | else Thm True); 265 | 266 | fun axiom_predcong i l r = 267 | (if equal_nat (size_list l) (size_list r) 268 | then Thm (imp_chain (zip_eq l r) 269 | (Imp ((Atom (R (i, l))), (Atom (R (i, r)))))) 270 | else Thm True); 271 | 272 | fun axiom_doubleneg p = Thm (Imp ((Imp ((Imp (p, False)), False)), p)); 273 | 274 | fun axiom_distribimp p q r = 275 | Thm (Imp ((Imp (p, (Imp (q, r)))), (Imp ((Imp (p, q)), (Imp (p, r)))))); 276 | 277 | end; (*struct Proven*) 278 | -------------------------------------------------------------------------------- /code/SML/eqelim.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/eqelim.sml -------------------------------------------------------------------------------- /code/SML/equal.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/equal.sml -------------------------------------------------------------------------------- /code/SML/fol.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/fol.sml -------------------------------------------------------------------------------- /code/SML/folderived.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/folderived.sml -------------------------------------------------------------------------------- /code/SML/format.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/format.sml -------------------------------------------------------------------------------- /code/SML/format_simple.sml: -------------------------------------------------------------------------------- 1 | fun set_margin _ = (); 2 | 3 | fun print_string x = print x; 4 | 5 | fun open_box _ = (); 6 | 7 | fun close_box () = (); 8 | 9 | fun print_space () = print " "; 10 | 11 | fun print_break _ _ = (); 12 | 13 | fun open_hbox () = (); 14 | 15 | fun print_flush () = (); 16 | 17 | fun print_newline () = print "\n"; 18 | 19 | fun print_int n = print (Int.toString n); 20 | 21 | fun open_hvbox _ = (); 22 | -------------------------------------------------------------------------------- /code/SML/formulas.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/formulas.sml -------------------------------------------------------------------------------- /code/SML/full_test.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/full_test.sml -------------------------------------------------------------------------------- /code/SML/init.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/init.sml -------------------------------------------------------------------------------- /code/SML/init_nj.sml: -------------------------------------------------------------------------------- 1 | fun load s = (); 2 | use "init.sml"; 3 | -------------------------------------------------------------------------------- /code/SML/initialization.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/initialization.sml -------------------------------------------------------------------------------- /code/SML/intro.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/intro.sml -------------------------------------------------------------------------------- /code/SML/lcf.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/lcf.sml -------------------------------------------------------------------------------- /code/SML/lcffol.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/lcffol.sml -------------------------------------------------------------------------------- /code/SML/lcfprop.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/lcfprop.sml -------------------------------------------------------------------------------- /code/SML/lib.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/lib.sml -------------------------------------------------------------------------------- /code/SML/order.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/order.sml -------------------------------------------------------------------------------- /code/SML/prop.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/prop.sml -------------------------------------------------------------------------------- /code/SML/resolution.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/resolution.sml -------------------------------------------------------------------------------- /code/SML/skolem.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/skolem.sml -------------------------------------------------------------------------------- /code/SML/tableaux.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/tableaux.sml -------------------------------------------------------------------------------- /code/SML/tactics.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/tactics.sml -------------------------------------------------------------------------------- /code/SML/timing.sml: -------------------------------------------------------------------------------- 1 | load "Timer"; 2 | load "Time"; 3 | val timer = Timer.startRealTimer (); 4 | use "init.sml"; 5 | print("Total time used: " ^ (Real.toString (Time.toReal (Timer.checkRealTimer timer))) ^ " seconds\n"); 6 | -------------------------------------------------------------------------------- /code/SML/timing_nj.sml: -------------------------------------------------------------------------------- 1 | fun load s = (); 2 | use "timing.sml"; 3 | -------------------------------------------------------------------------------- /code/SML/unif.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/unif.sml -------------------------------------------------------------------------------- /code/SML/verbose_functions.sml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/logic-tools/sml-handbook/c63c226cc1ca621852f017b4088d26e3268ca160/code/SML/verbose_functions.sml -------------------------------------------------------------------------------- /code/auxi/cleaner.sml: -------------------------------------------------------------------------------- 1 | load "TextIO";; 2 | open TextIO;; 3 | 4 | fun hasNext input = 5 | case lookahead input of 6 | NONE => false 7 | | SOME _ => true;; 8 | 9 | fun substr (s,i,j) = 10 | SOME (substring (s,i,j)) 11 | handle Subscript => NONE;; 12 | 13 | val write = ref false;; 14 | 15 | fun readFile () = 16 | case inputLine stdIn of 17 | SOME line =>( 18 | if substr(line, 0, 3) = SOME ":::" then 19 | write := true 20 | else if substr(line, 0, 3) = SOME ";;;" then 21 | write := false 22 | else if !write then 23 | print line 24 | else (); 25 | readFile() 26 | ) 27 | | NONE => () 28 | ;; 29 | readFile();; 30 | --------------------------------------------------------------------------------