├── .gitignore ├── COPYRIGHT.txt ├── Makefile ├── README.md ├── _tags ├── doc └── manual.tex ├── src ├── alg.ml ├── algebra.ml ├── check_model.ml ├── common.ml ├── config.ml ├── cook.ml ├── enum.ml ├── enum_binary.ml ├── enum_predicate_relation.ml ├── enum_unary.ml ├── error.ml ├── eval.ml ├── first_order.ml ├── indecomposable.ml ├── input.ml ├── invariant.ml ├── iso.ml ├── lexer.mll ├── output.ml ├── parser.mly ├── print.ml ├── sat.ml ├── theory.ml └── util.ml └── theories ├── antisymmetric_relation.th ├── band.th ├── bijection.th ├── binary_function.th ├── bipartite_graph.th ├── boolean_algebra.th ├── bounded_distributive_lattice.th ├── bounded_lattice.th ├── commutative_group.th ├── commutative_group_inefficient.th ├── commutative_group_via_division.th ├── commutative_quantale.th ├── commutative_ring.th ├── commutative_semigroup.th ├── commuting_functions.th ├── complete_graph.th ├── cubic_graph.th ├── digraph.th ├── disjoint_cycles.th ├── division_ring.th ├── domain.th ├── equivalence_relation.th ├── equivalence_relation_euclid.th ├── field.th ├── function.th ├── function_as_relation.th ├── graph.th ├── graph_via_action.py ├── graph_with_Z3_action.th ├── group.th ├── group_inefficient.th ├── group_order3.th ├── group_via_division.th ├── idempotent_monoid.th ├── injection.th ├── integral_domain.th ├── involution.th ├── involutive_graph.th ├── involutive_unital_quantale.th ├── lattice.th ├── lattice_as_relation.th ├── linear_order.th ├── magma.th ├── monoid.th ├── normal_skew_lattice.th ├── ordered_field.th ├── partially_ordered_group.th ├── partially_ordered_semigroup.th ├── poset.th ├── quantale.th ├── quasigroup.th ├── rectangular_band.th ├── relation.th ├── ring.th ├── semigroup.th ├── semilattice.th ├── semiring.th ├── set.th ├── set2.th ├── skew_lattice.th ├── standard_abelian_group.th ├── standard_group.th ├── strict_poset.th ├── tarski.th ├── tarski_high_school_algebra.th ├── transitive_relation.th ├── triangle_free_graph.th ├── tricolored_graph.th ├── unital_commutative_ring.th ├── unital_commutative_semiring.th └── unital_ring.th /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | src/version.ml 11 | _build 12 | /alg.native 13 | /doc/manual.pdf 14 | -------------------------------------------------------------------------------- /COPYRIGHT.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, Ales Bizjak and Andrej Bauer 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in 13 | the documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_DIR ?= /usr/local/bin 2 | 3 | LATEXMK ?= latexmk 4 | LATEXMK_FLAGS ?= -pdf -cd 5 | 6 | OCAMLBUILD ?= ocamlbuild -use-menhir 7 | OCAMLBUILD_FLAGS ?= -j 4 -use-menhir -menhir "menhir --explain" 8 | 9 | default: doc/manual.pdf alg.native 10 | 11 | .PHONY: alg.native alg.bytes alg.d.bytes alg.p.native 12 | 13 | alg.native alg.bytes alg.d.bytes alg.p.native: src/version.ml 14 | $(OCAMLBUILD) $(OCAMLBUILD_FLAGS) $@ 15 | 16 | doc/manual.pdf: doc/manual.tex 17 | $(LATEXMK) $(LATEXMK_FLAGS) doc/manual.tex 18 | 19 | src/version.ml: 20 | export VERSION=`@git describe --always --long` ; \ 21 | export OS=`uname` ; \ 22 | export DATE=`date +%Y-%m-%d` ; \ 23 | echo "let version = \"$$VERSION\" ;; let os = \"$$OS\" ;; let date = \"$$DATE\"" > src/version.ml 24 | 25 | clean: 26 | $(OCAMLBUILD) -clean 27 | $(LATEXMK) -C -cd doc/manual.tex 28 | 29 | install: 30 | cd src ; make install 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Alg 2 | 3 | 4 | Alg is a program for enumeration of finite models of first-order theories. Currently, Alg has the following limitations: 5 | 6 | * the theory must be single-sorted, 7 | * only unary and binary operations are accepted, 8 | * only unary predicates and binary operations are accepted, 9 | * it is assumed that constants denote pariwise distinct elements. 10 | 11 | ## Prerequisites 12 | 13 | Alg is available at [http://www.andrej.com/alg/] (which currently just redirects to GitHub). Apart from the source code, you will need the following: 14 | 15 | * [OCaml](https://ocaml.org) compiler, which you can very likely install using a package manager. Every Linux distribution comes with one, while on MacOS you can use [Homebrew](https://brew.sh). 16 | 17 | * If you are going to use OCaml for other projects, it is a good idea to install the OCaml package manager [OPAM](https://opam.ocaml.org) and use that instead of your default package manager. (It does requite a bit of configuration, though.) 18 | 19 | * The [ocamlbuild](https://ocaml.org/learn/tutorials/ocamlbuild/) compilation tool for OCaml, available through your package manager, e.g., 20 | 21 | * Linux: `sudo apt-get install ocamlbuild` 22 | * OPAM: `opam install ocamlbuild` 23 | * Homebrew: `brew install ocamlbuild` 24 | 25 | 26 | * The [menhir](http://gallium.inria.fr/~fpottier/menhir/) parser generator, available through your package manager, e.g., 27 | 28 | * Linux: `sudo apt-get install caml-menhir` 29 | * OPAM: `opam install menhir` 30 | * Homebrew: `brew install menhir` 31 | 32 | With sufficient user base I could probably be convinced to support at least a Homebrew package for Alg. 33 | 34 | ## Compilation 35 | 36 | If all goes well you should be able to compile Alg simply by running 37 | 38 | make 39 | 40 | in the Alg source directory. This will generate the executable, which you can test by running 41 | 42 | ./alg.native theories/group.th --size 1-9 --axiom 'x * x = 1' 43 | 44 | to enumerate all groups of size at most 9 in which all elements have rank 2. 45 | 46 | The compilation procedure also generates the Alg manual `doc/manual.pdf`. It relies on LaTeX. If you do not have it (how can that be?) you may compile just the executable by running 47 | 48 | make ./alg.native 49 | 50 | ## Usage 51 | 52 | See the manual `doc/manual.pdf` and the examples in the [`./theories`](./theories) folder. 53 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: bin_annot 2 | : include 3 | -------------------------------------------------------------------------------- /src/alg.ml: -------------------------------------------------------------------------------- 1 | (* The main program. *) 2 | 3 | open Config 4 | open Output 5 | 6 | module A = Algebra 7 | module CM = Check_model 8 | 9 | module IntMap = Util.IntMap ;; 10 | 11 | (* Convert a string given via the --size command-line option to a list of sizes. *) 12 | let sizes_of_str str = 13 | let interval_of_str str = 14 | try 15 | let k = String.index str '-' in 16 | let a = int_of_string (String.sub str 0 k) in 17 | let b = int_of_string (String.sub str (k+1) (String.length str - k - 1)) in 18 | if a < 0 || b < 0 then 19 | Error.usage_error "--size does not accept negative integers" 20 | else 21 | Util.enumFromTo a b 22 | with 23 | | Not_found -> [int_of_string str] 24 | in 25 | let lst = ref [] in 26 | let k = ref 0 in 27 | try 28 | while !k < String.length str do 29 | let m = (try String.index_from str !k ',' with Not_found -> String.length str) in 30 | lst := Util.union !lst (interval_of_str (String.sub str !k (m - !k))) ; 31 | k := m + 1 32 | done ; 33 | !lst 34 | with 35 | | Failure _ -> 36 | Error.usage_error "--size accepts a comma-separated list of non-negative integers and intervals, e.g., 1,2,5-7,9" 37 | ;; 38 | 39 | 40 | let formats = [ 41 | ("text", Output.Markdown.init); 42 | ("html", Output.HTML.init); 43 | ("latex", Output.LaTeX.init); 44 | ("json", Output.JSON.init); 45 | ] ;; 46 | 47 | let formats_extension = [ 48 | ("txt", "text"); 49 | ("html", "html"); 50 | ("htm", "html"); 51 | ("tex", "latex"); 52 | ("json", "json"); 53 | ] ;; 54 | 55 | (* Main program starts here. *) 56 | try begin (*A big wrapper for error reporting. *) 57 | 58 | (* References that store the command-line options *) 59 | let config = Config.default in 60 | 61 | (* Command-line axioms. *) 62 | let cmd_axioms = ref [] in 63 | 64 | (* Command-line options and usage *) 65 | let usage = "Usage: alg --size [options] " in 66 | 67 | let options = Arg.align [ 68 | ("--size", 69 | Arg.String (fun str -> config.sizes <- List.sort compare (Util.union config.sizes (sizes_of_str str))), 70 | " Comma-separated list of sizes and size intervals from-to."); 71 | ("--count", 72 | Arg.Unit (fun () -> config.count_only <- true), 73 | " Just count the models, do not print them out."); 74 | ("--axiom", 75 | Arg.String (fun str -> cmd_axioms := ("Axiom: " ^ str ^ ".") :: !cmd_axioms), 76 | " Add an extra axiom to the theory."); 77 | ("--indecomposable", 78 | Arg.Unit (fun () -> config.indecomposable_only <- true), 79 | " Output only indecomposable models (used only for equational theories)."); 80 | ("--paranoid", 81 | Arg.Unit (fun () -> config.paranoid <- true), 82 | " Naively check all axioms and isomorphism before output. Use if you think there is a bug in alg."); 83 | ("--sat", 84 | Arg.Unit (fun () -> config.use_sat <- true), 85 | " Use the satisfiability algorithm."); 86 | ("--no-products", 87 | Arg.Unit (fun () -> config.products <- false), 88 | " Do not generate algebras as products of smaller algebras (used only for equational theories)."); 89 | ("--format", 90 | Arg.String (fun str -> config.format <- str), 91 | " Output format, one of: " ^ String.concat ", " (List.map fst formats) ^ "."); 92 | ("--output", 93 | Arg.String (fun str -> config.output_filename <- str), 94 | " Output to the specified file."); 95 | ("--no-source", 96 | Arg.Unit (fun () -> config.source <- false), 97 | " Do not include the theory source in the output."); 98 | ("--version", 99 | Arg.Unit (fun () -> 100 | Printf.printf "Copyright (c) 2011 Ales Bizjak and Andrej Bauer\n" ; 101 | Printf.printf "This is alg version %s compiled on %s for %s.\n" Version.version Version.date Version.os; 102 | if Version.version.[String.length Version.version - 1] <> '+' 103 | then Printf.printf "The source code is at http://hg.andrej.com/alg/rev/%s\n" Version.version; 104 | exit 0 105 | ), 106 | " Print version information and exit."); 107 | ] 108 | in 109 | 110 | (* First we process the command line. *) 111 | 112 | (* Parse the arguments. Treat the anonymous arguments as files to be read. *) 113 | Arg.parse options 114 | (fun str -> 115 | match config.input_filename with 116 | | "" -> config.input_filename <- str 117 | | _ -> raise (Arg.Bad " only one theory file should be given")) 118 | usage ; 119 | 120 | if !cmd_axioms <> [] then cmd_axioms := "" :: "# Extra command-line axioms" :: !cmd_axioms ; 121 | 122 | (* Read the input file. *) 123 | let lines = 124 | begin match config.input_filename with 125 | | "" -> Arg.usage options usage; exit 1 126 | | filename -> 127 | try Util.read_lines filename 128 | with Sys_error msg -> Error.runtime_error "could not read %s" msg 129 | end @ !cmd_axioms 130 | in 131 | 132 | let lex = Lexing.from_string (String.concat "\n" lines) in 133 | 134 | let {Input.th_name=theory_name; Input.th_entries=raw_theory} = 135 | begin 136 | try 137 | Parser.theory Lexer.token lex 138 | with 139 | | Parser.Error -> 140 | Error.syntax_error ~loc:(Common.position_of_lex lex) "I got confused here" 141 | | Failure _ -> 142 | Error.syntax_error ~loc:(Common.position_of_lex lex) "Unrecognized symbol." 143 | end 144 | in 145 | 146 | (* Compute the theory name from the file name, if needed. *) 147 | let theory_name = 148 | begin match theory_name with 149 | | Some n -> n 150 | | None -> 151 | begin 152 | let n = Filename.basename config.input_filename in 153 | try String.sub n 0 (String.index n '.') with Not_found -> n 154 | end 155 | end ^ (if !cmd_axioms = [] then "" else "_with_extras") 156 | in 157 | 158 | (* Parse the theory. *) 159 | let theory = Cook.cook_theory theory_name raw_theory in 160 | 161 | (* Is this an equational theory? *) 162 | let equational_theory = 163 | Array.length theory.Theory.th_predicates = 0 && 164 | Array.length theory.Theory.th_relations = 0 && 165 | theory.Theory.th_axioms = [] 166 | in 167 | 168 | (* Sanity checks *) 169 | (* If --indecomposable is given then we need products. *) 170 | if config.indecomposable_only then config.products <- true ; 171 | 172 | (* If the theory is not equational then disable --indecomposable and --products. *) 173 | if not equational_theory then (config.indecomposable_only <- false ; config.products <- false) ; 174 | 175 | (* Cache for indecomposable algebras computed so far. This is a map from size to a list of algebras. *) 176 | let indecomposable_algebras = ref IntMap.empty in 177 | 178 | let lookup_cached n = 179 | try 180 | Some (IntMap.find n !indecomposable_algebras) 181 | with Not_found -> None 182 | in 183 | 184 | (* Processing of algebras of a given size and pass them to the given continuations, 185 | together with information whether the algebra is indecomposable. *) 186 | let rec process_size n output = 187 | (* Generate a hash table of decomposable algebras if needed. *) 188 | let decomposables = 189 | if n < Array.length theory.Theory.th_const || not config.products then Iso.empty_store () 190 | else 191 | (* Generate indecomposable factors and then decomposable algebras from them. *) 192 | let factors = 193 | List.fold_left 194 | (fun m k -> 195 | let lst = 196 | begin match lookup_cached k with 197 | | Some lst -> lst 198 | | None -> 199 | let lst = ref [] in 200 | process_size k (fun (algebra, indecomposable) -> 201 | if indecomposable then lst := Util.copy_algebra algebra :: !lst) ; 202 | !lst 203 | end 204 | in 205 | IntMap.add k lst m) 206 | IntMap.empty 207 | (Util.divisors n) 208 | in 209 | begin 210 | (* make decomposables *) 211 | Indecomposable.gen_decomposable theory n factors (fun a -> output (a, false)) 212 | end 213 | in 214 | (* Generate indecomposable algebras. *) 215 | (* Are we going to cache these? *) 216 | let must_cache = config.products && List.exists (fun m -> n > 0 && m > n && m mod n = 0) config.sizes in 217 | let algebras = decomposables in 218 | let to_cache = ref [] in 219 | (if config.use_sat then Sat.generate ?start:None else Enum.enum) n theory 220 | (fun a -> 221 | (* XXX check to see if it is faster to call First_order.check_axioms first and then Iso.seen. *) 222 | let ac = A.make_cache a in 223 | let aa = A.with_cache ~cache:ac a in 224 | let (seen, i) = Iso.seen theory aa algebras in 225 | if not seen && First_order.check_axioms theory a then 226 | if config.paranoid && CM.seen theory a algebras then 227 | Error.internal_error "There is a bug in isomorphism detection in alg.\nPlease report with example." 228 | else 229 | begin 230 | let b = Util.copy_algebra a in 231 | let bc = A.with_cache ~cache:ac b in 232 | Iso.store algebras ~inv:i bc ; 233 | if must_cache then to_cache := b :: !to_cache ; 234 | output (b, true) 235 | end) ; 236 | if must_cache then indecomposable_algebras := IntMap.add n !to_cache !indecomposable_algebras 237 | in 238 | 239 | if config.format = "" then 240 | config.format <- 241 | begin 242 | try List.assoc (Util.filename_extension config.output_filename) formats_extension 243 | with Not_found -> fst (List.hd formats) 244 | end ; 245 | 246 | let outch = 247 | begin 248 | match config.output_filename with 249 | | "" -> stdout 250 | | filename -> open_out filename 251 | end 252 | in 253 | 254 | let out = 255 | begin 256 | try List.assoc config.format formats config outch lines theory 257 | with Not_found -> 258 | Error.runtime_error "unknown output format, should be one of: %s" (String.concat ", " (List.map fst formats)) 259 | end 260 | in 261 | 262 | let counts = ref [] in 263 | 264 | (* The main loop *) 265 | begin 266 | Sys.catch_break true ; 267 | out.header () ; 268 | if config.count_only then out.count_header () ; 269 | begin 270 | try 271 | List.iter 272 | (fun n -> 273 | if not config.count_only then out.size_header n ; 274 | let k = ref 0 in 275 | let output (algebra, indecomposable) = 276 | if config.paranoid && not (CM.check_model theory algebra) then 277 | Error.internal_error "There is a bug in alg. Algebra does not satisfy all axioms.\nPlease report with example." ; 278 | if not config.indecomposable_only || indecomposable then incr k ; 279 | algebra.Algebra.alg_name <- Some (theory.Theory.th_name ^ "_" ^ string_of_int n ^ "_" ^ string_of_int !k) ; 280 | if not config.count_only && (not config.indecomposable_only || indecomposable) 281 | then out.algebra algebra 282 | in 283 | process_size n output ; 284 | counts := (n, !k) :: !counts ; 285 | if config.count_only 286 | then out.count n !k 287 | else out.size_footer ()) 288 | config.sizes 289 | with Sys.Break -> out.interrupted () 290 | end ; 291 | if config.count_only 292 | then out.count_footer (List.rev !counts) 293 | else out.footer (List.rev !counts) 294 | end 295 | end 296 | with Error.Error err -> Print.error err 297 | -------------------------------------------------------------------------------- /src/algebra.ml: -------------------------------------------------------------------------------- 1 | (* Algebras are models of theories. *) 2 | 3 | module T = Theory 4 | 5 | type map_invariant = int array array 6 | 7 | type invariant = { 8 | inv_size : int; 9 | inv_unary : map_invariant array; 10 | inv_binary : map_invariant array; 11 | inv_predicates : int array; 12 | inv_relations : (int array * int array) array; 13 | } 14 | 15 | (* 16 | indegs.(r).(i) is a list of element indices with in degree i in relation r and 17 | similar for out degrees. 18 | *) 19 | type cache = { 20 | indegs : int list array array; 21 | outdegs : int list array array; 22 | } 23 | 24 | type algebra = { 25 | mutable alg_name : string option; 26 | alg_prod : string list option; 27 | alg_size : int; 28 | alg_const : int array; 29 | alg_unary : int array array; 30 | alg_binary : int array array array; 31 | alg_predicates : int array array; 32 | alg_relations : int array array array; 33 | } 34 | 35 | (* An algebra with all -1's. *) 36 | let empty n {T.th_const=c; T.th_unary=u; T.th_binary=b; T.th_predicates=p; T.th_relations=r} = 37 | if n < Array.length c 38 | then Error.internal_error "Algebra.empty: cannot create an algebra of size %d with %d constants." n (Array.length c) 39 | else { 40 | alg_name = None; 41 | alg_prod = None; 42 | alg_size = n; 43 | alg_const = Array.init (Array.length c) (fun i -> i); 44 | alg_unary = Array.make_matrix (Array.length u) n (-1); 45 | alg_binary = Array.init (Array.length b) (fun i -> Array.make_matrix n n (-1)); 46 | alg_predicates = Array.make_matrix (Array.length p) n (-1); 47 | alg_relations = Array.init (Array.length r) (fun i -> Array.make_matrix n n (-1)); 48 | } 49 | 50 | (* For faster isomorphism checking we define invariants for structures. 51 | 52 | Suppose f : {0,..,n} -> {0,..,n} is a map. For each x in {0,...,n} the sequence 53 | 54 | x_0 = x 55 | x_{k+1} = f (x_k) 56 | 57 | is eventually periodic, i.e., there are minimal i and j such that 0 <= i < j <= n 58 | and x_i = f(x_j). We call the pair (i,j) the "eventual period" of x. Given a pair 59 | (i,j), let N_f(i,j) be the number of elements x whose eventual period is (i,j). 60 | Then N_f is an invariant for f, i.e., if b : {0,...,n} -> {0,...n} is a bijection 61 | then N_f = N_{b^{-1} o f o b}. 62 | 63 | We define invariants for the operations and relations of an algebra as follows: 64 | 65 | * for each unary operation f the corresponding invariant is N_f 66 | 67 | * for each binary operation f we define the eventual period (i,j) of x as in the 68 | case of a map except that we consider the sequence 69 | 70 | x_0 = x 71 | x_{k+1} = f (x_k, x) 72 | 73 | * for a predicate or relation the corresponding invariant is the number of 74 | elements or pairs that satisfy it (a better one would be a count of how 75 | many elements of each in/out degree we have). 76 | *) 77 | 78 | exception Result of (int * int) 79 | 80 | let unary_invariant f n = 81 | let t = Array.make (n+1) 0 in 82 | let eventual_period f x = 83 | try 84 | t.(0) <- x ; 85 | for j = 1 to n do 86 | t.(j) <- f t.(j-1) ; 87 | for i = 0 to j-1 do 88 | if t.(i) = t.(j) then raise (Result (i,j)) 89 | done 90 | done ; 91 | Error.internal_error "algebra.ml -- map_invariant" 92 | with Result r -> r 93 | in 94 | let a = Array.init n (fun j -> Array.make (j+1) 0) in 95 | for x = 0 to n - 1 do 96 | let (i,j) = eventual_period f x in 97 | a.(j-1).(i) <- a.(j-1).(i) + 1 98 | done ; 99 | a 100 | 101 | let binary_invariant f n = 102 | let t = Array.make (n+1) 0 in 103 | let eventual_period f x = 104 | try 105 | t.(0) <- x ; 106 | for j = 1 to n do 107 | t.(j) <- f x t.(j-1) ; 108 | for i = 0 to j-1 do 109 | if t.(i) = t.(j) then raise (Result (i,j)) 110 | done 111 | done ; 112 | Error.internal_error "algebra.ml -- map_invariant" 113 | with Result r -> r 114 | in 115 | let a = Array.init n (fun j -> Array.make (j+1) 0) in 116 | for x = 0 to n - 1 do 117 | let (i,j) = eventual_period f x in 118 | a.(j-1).(i) <- a.(j-1).(i) + 1 119 | done ; 120 | a 121 | 122 | let predicate_invariant p = 123 | let k = ref 0 in 124 | for i = 0 to Array.length p - 1 do 125 | if p.(i) = 1 then incr k 126 | done ; 127 | !k 128 | 129 | let relation_invariant r = 130 | let outdeg = Array.make (Array.length r) 0 in 131 | let indeg = Array.make (Array.length r) 0 in 132 | for i = 0 to Array.length r - 1 do 133 | for j = 0 to Array.length r.(i) - 1 do 134 | if r.(i).(j) = 1 then 135 | begin 136 | outdeg.(i) <- outdeg.(i) + 1; 137 | indeg.(j) <- indeg.(j) + 1 138 | end 139 | done 140 | done ; 141 | Array.sort compare outdeg; Array.sort compare indeg; 142 | (indeg, outdeg) 143 | 144 | 145 | let invariant {alg_size=n; alg_unary=us; alg_binary=bs; alg_predicates=ps; alg_relations=rs} = 146 | { inv_size = n ; 147 | inv_unary = Array.map (fun u -> unary_invariant (fun k -> u.(k)) n) us; 148 | inv_binary = Array.map (fun b -> binary_invariant (fun k l -> b.(k).(l)) n) bs; 149 | inv_predicates = Array.map predicate_invariant ps; 150 | inv_relations = Array.map relation_invariant rs; 151 | } 152 | 153 | let relation_cache r = 154 | let outdeg = Array.make (Array.length r) 0 in 155 | let indeg = Array.make (Array.length r) 0 in 156 | for i = 0 to Array.length r - 1 do 157 | for j = 0 to Array.length r.(i) - 1 do 158 | if r.(i).(j) = 1 then 159 | begin 160 | outdeg.(i) <- outdeg.(i) + 1; 161 | indeg.(j) <- indeg.(j) + 1 162 | end 163 | done 164 | done ; 165 | (* One vertex can be connected to at most n-1 other + itself *) 166 | let outdegs = Array.make (Array.length r + 1) [] in 167 | let indegs = Array.make (Array.length r + 1) [] in 168 | Array.iteri (fun i a -> outdegs.(a) <- i :: outdegs.(a)) outdeg ; 169 | Array.iteri (fun i a -> indegs.(a) <- i :: indegs.(a)) indeg ; 170 | 171 | indegs, outdegs 172 | 173 | let make_cache {alg_relations=rs} = 174 | let rc = Array.map relation_cache rs in 175 | {indegs = Array.map fst rc; outdegs = Array.map snd rc} 176 | 177 | (* if cache is given it must correspond to algebra a.*) 178 | let with_cache ?cache a = let ac = match cache with Some c -> c | None -> make_cache a in 179 | (a, ac) 180 | 181 | let wo_cache a = fst a 182 | -------------------------------------------------------------------------------- /src/check_model.ml: -------------------------------------------------------------------------------- 1 | open Theory 2 | open Algebra 3 | open Util 4 | 5 | module FO = First_order 6 | 7 | (* Evaluate equation in the context of vars. 8 | operation arrays are assumed to be fully filled. 9 | *) 10 | let eval_eq alg vars (left,right) = 11 | (Eval.eval_term alg vars left, Eval.eval_term alg vars right) 12 | 13 | (* Naive check if model satisfies all axioms. *) 14 | let check_model {th_equations=equations; th_axioms=axioms} alg = 15 | let n = alg.alg_size in 16 | let check_eq (num_vars, eq) = 17 | array_for_all 18 | (fun vars -> let (rl, rr) = eval_eq alg vars eq in rl = rr) 19 | (ntuples n num_vars) in 20 | List.for_all check_eq equations && List.for_all (FO.check_formula alg) axioms 21 | 22 | 23 | (* Naive checking of isomorphisms. *) 24 | 25 | (* generate array of all permutations of elements 0..n-1. *) 26 | let perms n = 27 | let len = fac n in 28 | let arr = Array.make_matrix len n 0 in 29 | let place = ref 0 in 30 | let used = Array.make n false in 31 | let cur = Array.make n 0 in 32 | let rec loop = function 33 | | k when k = n -> 34 | begin 35 | for i=0 to n-1 do 36 | arr.(!place).(i) <- cur.(i); 37 | done ; 38 | place := !place + 1 39 | end 40 | | k -> 41 | for i=0 to n-1 do 42 | if not used.(i) then 43 | begin 44 | used.(i) <- true; 45 | cur.(k) <- i; 46 | loop (k+1) ; 47 | used.(i) <- false 48 | end 49 | done in 50 | loop 0; arr 51 | 52 | (* 53 | Checks if permutation preserves constants. 54 | *) 55 | let check_const iso c1 c2 = iso.(c1) = c2 56 | 57 | (* 58 | Checks if a function commutes with permutation. 59 | f(i(a)) = i(f(a)). 60 | *) 61 | let check_unary iso u1 u2 = 62 | let l = Array.length iso in 63 | for_all (fun i -> iso.(u1.(i)) = u2.(iso.(i))) 0 (l-1) 64 | 65 | (* 66 | Checks if binary operation is multiplicative. 67 | *) 68 | let check_binary iso b1 b2 = 69 | let l = Array.length iso in 70 | for_all2 (fun i j -> iso.(b1.(i).(j)) = b2.(iso.(i)).(iso.(j))) 0 (l-1) 0 (l-1) 71 | 72 | (* 73 | Check if predicates are isomorphic for iso. 74 | *) 75 | let check_predicate iso p1 p2 = 76 | let l = Array.length iso in 77 | Util.for_all (fun i -> p1.(i) = p2.(iso.(i))) 0 (l-1) 78 | 79 | (* 80 | Check if relations are isomorphic for iso. 81 | *) 82 | let check_relation iso r1 r2 = 83 | let l = Array.length iso in 84 | Util.for_all2 (fun i j -> r1.(i).(j) = r2.(iso.(i)).(iso.(j))) 0 (l-1) 0 (l-1) 85 | 86 | (* 87 | Check if two algebras are isomorphic. 88 | Basic version. Generates all permutations and then eliminates 89 | all that are not isomorphisms. 90 | *) 91 | let are_iso th 92 | {alg_size=n1; alg_const=c1; alg_unary=u1; 93 | alg_binary=b1; alg_predicates=p1; alg_relations=r1} 94 | {alg_size=n2; alg_const=c2; alg_unary=u2; 95 | alg_binary=b2; alg_predicates=p2; alg_relations=r2} = 96 | if n1 <> n2 then 97 | false 98 | else 99 | let is_isomorphism x = 100 | let p = ref true in 101 | let i = ref 0 in 102 | while !i < Array.length th.th_const && !p do 103 | p := check_const x c1.(!i) c2.(!i) ; 104 | incr i 105 | done ; 106 | i := 0 ; 107 | while !i < Array.length th.th_unary && !p do 108 | p := check_unary x u1.(!i) u2.(!i) ; 109 | incr i 110 | done ; 111 | i := 0 ; 112 | while !i < Array.length th.th_binary && !p do 113 | p := check_binary x b1.(!i) b2.(!i) ; 114 | incr i 115 | done ; 116 | i := 0 ; 117 | while !i < Array.length th.th_predicates && !p do 118 | p := check_predicate x p1.(!i) p2.(!i) ; 119 | incr i 120 | done ; 121 | i := 0 ; 122 | while !i < Array.length th.th_relations && !p do 123 | p := check_relation x r1.(!i) r2.(!i) ; 124 | incr i 125 | done ; !p in 126 | let perms = perms n1 in 127 | array_exists is_isomorphism perms 128 | 129 | (* 130 | Have we already seen an algebra of this isomorphism type? 131 | *) 132 | exception AlreadySeen 133 | 134 | let seen theory alg store = 135 | try 136 | Hashtbl.iter (fun _ lst -> if List.exists (fun alg' -> are_iso theory alg (wo_cache alg')) lst then raise AlreadySeen) store ; 137 | false 138 | with AlreadySeen -> true 139 | -------------------------------------------------------------------------------- /src/common.ml: -------------------------------------------------------------------------------- 1 | (* Definitions common to many files. *) 2 | 3 | (** Position in source code. For each type in the abstract syntax we define two versions 4 | [t] and [t']. The former is the latter with a position tag. For example, [expr = expr' 5 | * position] and [expr'] is the type of expressions (without positions). 6 | *) 7 | type position = 8 | | Position of Lexing.position * Lexing.position (** delimited position *) 9 | | Nowhere (** unknown position *) 10 | 11 | (** [nowhere e] is the expression [e] without a source position. It is used when 12 | an expression is generated and there is not reasonable position that could be 13 | assigned to it. *) 14 | let nowhere x = (x, Nowhere) 15 | 16 | (** Convert a position as presented by [Lexing] to [position]. *) 17 | let position_of_lex lex = 18 | Position (Lexing.lexeme_start_p lex, Lexing.lexeme_end_p lex) 19 | 20 | -------------------------------------------------------------------------------- /src/config.ml: -------------------------------------------------------------------------------- 1 | (* Options for command-line arguments. *) 2 | 3 | type config = { 4 | mutable sizes : int list; 5 | mutable indecomposable_only : bool; 6 | mutable count_only : bool; 7 | mutable products : bool; 8 | mutable source : bool; 9 | mutable input_filename : string; 10 | mutable output_filename : string; 11 | mutable format : string; 12 | mutable paranoid : bool; 13 | mutable use_sat : bool; 14 | } 15 | 16 | let default = { 17 | sizes = []; 18 | indecomposable_only = false; 19 | count_only = false; 20 | products = true; 21 | source = true; 22 | input_filename = ""; 23 | output_filename = ""; 24 | format = ""; 25 | paranoid = false; 26 | use_sat = false; 27 | } 28 | -------------------------------------------------------------------------------- /src/cook.ml: -------------------------------------------------------------------------------- 1 | (* A simple compiler from abstract syntax to the internal representation. *) 2 | 3 | type env = { 4 | const : (Theory.operation_name * Theory.operation) list ; 5 | unary : (Theory.operation_name * Theory.operation) list ; 6 | binary : (Theory.operation_name * Theory.operation) list ; 7 | predicates : (Theory.relation_name * Theory.relation) list ; 8 | relations : (Theory.relation_name * Theory.relation) list ; 9 | } 10 | 11 | let empty_env = { const = []; unary = []; binary = []; predicates = []; relations = []} 12 | 13 | let fresh lst = 1 + List.fold_left (fun m (_,k) -> max m k) (-1) lst 14 | 15 | let extend_const env c = 16 | { env with const = (c, fresh env.const) :: env.const } 17 | 18 | let extend_unary env u = 19 | { env with unary = (u, fresh env.unary) :: env.unary } 20 | 21 | let extend_binary env b = 22 | { env with binary = (b, fresh env.binary) :: env.binary } 23 | 24 | let extend_predicate env p = 25 | { env with predicates = (p, fresh env.predicates) :: env.predicates } 26 | 27 | let extend_relation env r = 28 | { env with relations = (r, fresh env.relations) :: env.relations } 29 | 30 | let extend_var x vars = 31 | let k = fresh vars in 32 | (x,k) :: vars, k 33 | 34 | let lookup_const {const=ec} x = Util.lookup x ec 35 | 36 | let lookup_unary {unary=eu} x = Util.lookup x eu 37 | 38 | let lookup_binary {binary=eb} x = Util.lookup x eb 39 | 40 | let lookup_predicate {predicates=ep} x = Util.lookup x ep 41 | 42 | let lookup_relation {relations=er} x = Util.lookup x er 43 | 44 | let lookup_var vars x = Util.lookup x vars 45 | 46 | let is_op {const=ec; unary=eu; binary=eb} x = 47 | List.mem_assoc x ec || List.mem_assoc x eu || List.mem_assoc x eb 48 | 49 | (* The free variables of a term, without repetitions. *) 50 | let rec fv_term env (t, loc) = 51 | match t with 52 | | Input.Var x -> 53 | if is_op env x then [] else [x] 54 | | Input.UnaryOp (_, t) -> fv_term env t 55 | | Input.BinaryOp (_, t1, t2) -> Util.union (fv_term env t1) (fv_term env t2) 56 | 57 | 58 | (* The free variables of a formula, without repetitions. *) 59 | let rec fv_formula env (f, loc) = 60 | match f with 61 | | Input.False -> [] 62 | | Input.True -> [] 63 | | Input.Equal (t1, t2) 64 | | Input.NotEqual (t1, t2) -> 65 | Util.union (fv_term env t1) (fv_term env t2) 66 | | Input.UnaryPr (_, t) -> fv_term env t 67 | | Input.BinaryPr (_, t1, t2) -> Util.union (fv_term env t1) (fv_term env t2) 68 | | Input.Not f -> fv_formula env f 69 | | Input.And (f1, f2) 70 | | Input.Or (f1, f2) 71 | | Input.Imply (f1, f2) 72 | | Input.Iff (f1, f2) -> 73 | Util.union (fv_formula env f1) (fv_formula env f2) 74 | | Input.Forall (xs, f) | Input.Exists (xs, f) -> 75 | Util.remove_many xs (fv_formula env f) 76 | 77 | (* The depth of the formula is the maximum level of nesting of quantifiers. *) 78 | let rec depth (f, _) = 79 | match f with 80 | | Input.False 81 | | Input.True 82 | | Input.UnaryPr _ 83 | | Input.BinaryPr _ 84 | | Input.Equal _ 85 | | Input.NotEqual _ -> 0 86 | | Input.Not f -> depth f 87 | | Input.And (f1, f2) 88 | | Input.Or (f1, f2) 89 | | Input.Imply (f1, f2) 90 | | Input.Iff (f1, f2) -> max (depth f1) (depth f2) 91 | | Input.Forall (xs, f) | Input.Exists (xs, f) -> List.length xs + depth f 92 | 93 | let rec cook_term env vars (t,loc) = 94 | match t with 95 | | Input.Var x -> 96 | begin match lookup_var vars x with 97 | | Some k -> Theory.Var k 98 | | None -> 99 | begin match lookup_const env x with 100 | | Some k -> Theory.Const k 101 | | None -> Error.typing_error ~loc "unknown variable or constant %s" x 102 | end 103 | end 104 | | Input.UnaryOp (op, t) -> 105 | begin match lookup_unary env op with 106 | | Some u -> Theory.Unary (u, cook_term env vars t) 107 | | None -> Error.typing_error ~loc "%s is used as a unary operation but it is not" op 108 | end 109 | | Input.BinaryOp (op, t1, t2) -> 110 | begin match lookup_binary env op with 111 | | Some b -> Theory.Binary (b, cook_term env vars t1, cook_term env vars t2) 112 | | None -> Error.typing_error ~loc "%s is used as a unary operation but it is not" op 113 | end 114 | 115 | let cook_equation env (t1, t2) = 116 | let k, vars = Util.enum (Util.union (fv_term env t1) (fv_term env t2)) in 117 | (k, (cook_term env vars t1, cook_term env vars t2)) 118 | 119 | let cook_formula env f = 120 | let rec cook vars (f,loc) = 121 | match f with 122 | | Input.True -> Theory.True 123 | | Input.False -> Theory.False 124 | | Input.UnaryPr (op, t) -> 125 | begin match lookup_predicate env op with 126 | | Some u -> Theory.Predicate (u, cook_term env vars t) 127 | | None -> Error.typing_error ~loc "%s is not a unary predicate" op 128 | end 129 | | Input.BinaryPr (op, t1, t2) -> 130 | begin match lookup_relation env op with 131 | | Some b -> Theory.Relation (b, cook_term env vars t1, cook_term env vars t2) 132 | | None -> Error.typing_error ~loc "%s is not a binary relation" op 133 | end 134 | | Input.Equal (t1, t2) -> Theory.Equal (cook_term env vars t1, cook_term env vars t2) 135 | | Input.NotEqual (t1, t2) -> 136 | Theory.Not (Theory.Equal (cook_term env vars t1, cook_term env vars t2)) 137 | | Input.And (f1,f2) -> Theory.And (cook vars f1, cook vars f2) 138 | | Input.Or (f1,f2) -> Theory.Or (cook vars f1, cook vars f2) 139 | | Input.Imply (f1,f2) -> Theory.Imply (cook vars f1, cook vars f2) 140 | | Input.Iff (f1,f2) -> Theory.Iff (cook vars f1, cook vars f2) 141 | | Input.Not f -> Theory.Not (cook vars f) 142 | | Input.Forall (xs, f) -> 143 | begin match xs with 144 | | [] -> cook vars f 145 | | x :: xs -> 146 | let vars, k = extend_var x vars in 147 | Theory.Forall (k, cook vars (Input.Forall (xs, f), loc)) 148 | end 149 | | Input.Exists (xs, f) -> 150 | begin match xs with 151 | | [] -> cook vars f 152 | | x :: xs -> 153 | let vars, k = extend_var x vars in 154 | Theory.Exists (k, cook vars (Input.Exists (xs, f), loc)) 155 | end 156 | in 157 | let loc = snd f in 158 | let xs = fv_formula env f in 159 | let f = Input.Forall (xs, f), loc in 160 | Array.make (depth f) (-1), cook [] f 161 | 162 | let split_entries lst = 163 | List.fold_left 164 | (fun (env,eqs,axs) -> 165 | fun (e, loc) -> match e with 166 | | Input.Constant cs -> (List.fold_left extend_const env cs, eqs, axs) 167 | | Input.Unary us -> (List.fold_left extend_unary env us, eqs, axs) 168 | | Input.Binary bs -> (List.fold_left extend_binary env bs, eqs, axs) 169 | | Input.Predicate ps -> (List.fold_left extend_predicate env ps, eqs, axs) 170 | | Input.Relation rs -> (List.fold_left extend_relation env rs, eqs, axs) 171 | | Input.Axiom (_,a) -> 172 | begin match Input.as_equation a with 173 | | None -> (env, eqs, a :: axs) 174 | | Some (t1,t2) -> (env, (t1,t2) :: eqs, axs) 175 | end) 176 | (empty_env, [], []) 177 | lst 178 | 179 | let env_to_array lst = 180 | let a = Array.make (List.length lst) "?" in 181 | List.iter (fun (op,k) -> a.(k) <- op) lst ; 182 | a 183 | 184 | let cook_theory th_name lst = 185 | let (env, eqs, axs) = split_entries lst in 186 | match Util.find_duplicate (List.map fst (env.const @ env.unary @ env.binary)) with 187 | | Some op -> Error.typing_error ~loc:Common.Nowhere "operation %s is declared more than once" op 188 | | None -> 189 | { 190 | Theory.th_name = th_name; 191 | Theory.th_const = env_to_array env.const; 192 | Theory.th_unary = env_to_array env.unary; 193 | Theory.th_binary = env_to_array env.binary; 194 | Theory.th_predicates = env_to_array env.predicates; 195 | Theory.th_relations = env_to_array env.relations; 196 | Theory.th_equations = List.map (cook_equation env) eqs; 197 | Theory.th_axioms = List.map (cook_formula env) axs; 198 | } 199 | -------------------------------------------------------------------------------- /src/enum.ml: -------------------------------------------------------------------------------- 1 | open Theory 2 | open Algebra 3 | open Util 4 | 5 | module EPR=Enum_predicate_relation 6 | 7 | (* General helper functions for partitioning axioms. *) 8 | 9 | (* Select axioms that refer only to unary operations and constants. *) 10 | let part_axioms axioms = 11 | let rec no_binary = function 12 | | Binary _ -> false 13 | | Unary (_, t) -> no_binary t 14 | | Var _ | Const _ | Elem _ -> true in 15 | let no_binary_axiom (eq1, eq2) = no_binary eq1 && no_binary eq2 in 16 | List.partition (apply_to_snd no_binary_axiom) axioms 17 | 18 | (* 19 | Partition unary axioms. In the first part are the axioms of the form 20 | f(a) = b, where a and b are constants, and the rest in the second one. 21 | *) 22 | let part_unary_axioms axioms = 23 | let is_simple = function 24 | | (Unary (_,Const _), Const _) 25 | | (Const _, Unary (_,Const _)) -> true 26 | | _ -> false 27 | in List.partition (apply_to_snd is_simple) axioms 28 | 29 | (* 30 | Partition binary axioms into two parts. In the first are axioms of the form 31 | a + b = c, where a b and c are constants or unary applications, these are termed simple, 32 | and the rest are in the second part, these I call complicated. 33 | *) 34 | let part_binary_axioms axioms = 35 | let rec const_and_unary = function 36 | | (Unary (_,t)) -> const_and_unary t 37 | | (Const _ ) -> true 38 | | _ -> false in 39 | let is_simple = function 40 | | (Binary (_,t1,t2), Const _) 41 | | (Const _, Binary (_,t1,t2)) -> const_and_unary t1 && const_and_unary t2 42 | | _ -> false 43 | in List.partition (apply_to_snd is_simple) axioms 44 | 45 | (* 46 | Partition binary axioms into two parts. 47 | The first: 48 | axioms f(a) * g(a) = h(a) or some of the expressions contain a constant 49 | The second: 50 | all the rest. :) 51 | We can immediately apply the first kind. 52 | *) 53 | 54 | let part_one_var_binary axioms = 55 | let rec const_var_unary = function 56 | | (Unary (_,t)) -> const_var_unary t 57 | | (Const c ) -> Some (Const c) 58 | | (Var v) -> Some (Var v) 59 | | _ -> None in 60 | let is_simple = function 61 | | (num_vars, (Binary (_,t1,t2), t3)) 62 | | (num_vars, (t3, Binary (_,t1,t2))) -> 63 | let v1 = const_var_unary t1 in 64 | let v2 = const_var_unary t2 in 65 | let v3 = const_var_unary t3 in 66 | begin 67 | match (v1,v2,v3) with 68 | | (None,_,_) | (_,None,_) | (_,_,None) -> false 69 | | _ -> num_vars <= 1 70 | end 71 | | _ -> false 72 | in List.partition is_simple axioms 73 | 74 | (* Select associativity axioms. *) 75 | let partition_assoc axioms = 76 | let is_assoc = function 77 | | (Binary (op1, Binary (op2, Var a1, Var b1), Var c1), Binary (op3, Var a2, Binary (op4, Var b2, Var c2))) 78 | | (Binary (op3, Var a2, Binary (op4, Var b2, Var c2)), Binary (op1, Binary (op2, Var a1, Var b1), Var c1)) 79 | when op1 = op2 && op2 = op3 && op3 = op4 && 80 | a1 = a2 && b1 = b2 && c1 = c2 && 81 | a1 <> b1 && a1 <> c1 && b1 <> c1 -> true 82 | | _ -> false 83 | in List.partition (apply_to_snd is_assoc) axioms 84 | 85 | let make_3d_array x y z initial = 86 | Array.init x (fun _ -> Array.make_matrix y z initial) 87 | 88 | (* 89 | List of distinct variables of a term. 90 | *) 91 | let rec eq_vars acc = function 92 | | Const _ | Elem _ -> acc 93 | | Var v -> if List.mem v acc then acc else (v :: acc) 94 | | Binary (_,t1,t2) -> let lv = eq_vars acc t1 in 95 | eq_vars lv t2 96 | | Unary (_,t) -> eq_vars acc t 97 | 98 | (* 99 | List of distinct variables of an axiom. 100 | *) 101 | let dist_vars (_,(left, right)) = 102 | let lv = eq_vars [] left in eq_vars lv right 103 | 104 | (* 105 | Number of distinct variables in an axiom. 106 | Could also look for maximum variable index. 107 | *) 108 | let num_dist_vars (num_vars,_) = num_vars 109 | 110 | (* Amenable axioms are the ones where left and right terms have binary op 111 | as outermost operation and have exactly the same variables on left and right sides or 112 | one outermost operation is binary and variables of the other side are a subset of 113 | variables in binary operation. This restriction of variables is necessary as otherwise 114 | we never get any information out of evaluation of the other side. *) 115 | let partition_amenable axioms = 116 | let is_amenable ((left, right) as axiom) = 117 | match axiom with 118 | | (Binary _, Binary _)-> 119 | List.sort compare (eq_vars [] left) = List.sort compare (eq_vars [] right) 120 | | ((Binary _), _) -> Util.is_sublist (eq_vars [] right) (eq_vars [] left) 121 | | (_, (Binary _)) -> Util.is_sublist (eq_vars [] left) (eq_vars [] right) 122 | | _ -> false in 123 | List.partition (apply_to_snd is_amenable) axioms 124 | 125 | 126 | (* 127 | Enumerate all algebras of a given size for the given theory 128 | and pass them to the given continuation. 129 | *) 130 | let enum n ({th_const=const; 131 | th_unary=unary; 132 | th_binary=binary; 133 | th_relations=relations; 134 | th_predicates=predicates; 135 | th_equations=axioms} as th) k = 136 | if n >= Array.length const then 137 | try begin 138 | let lc = Array.length const in 139 | let lu = Array.length unary in 140 | let lb = Array.length binary in 141 | let lp = Array.length predicates in 142 | let lr = Array.length relations in 143 | 144 | (* empty algebra *) 145 | 146 | (* Main operation tables for unary operations. *) 147 | let unary_arr = Array.make_matrix lu n (-1) in 148 | (* 149 | Main operation tables for binary operations. 150 | *) 151 | let binary_arr = make_3d_array lb n n (-1) in 152 | 153 | (* Main operation tables for predicates. *) 154 | let pred_arr = Array.make_matrix lp n (-1) in 155 | (* 156 | Main operation tables for relations. 157 | *) 158 | let rel_arr = make_3d_array lr n n (-1) in 159 | 160 | let alg = {alg_size = n; 161 | alg_name = None; 162 | alg_prod = None; 163 | alg_const = Array.init lc (fun k -> k); 164 | alg_unary = unary_arr; 165 | alg_binary = binary_arr; 166 | alg_predicates = pred_arr; 167 | alg_relations = rel_arr 168 | } in 169 | 170 | (* Auxiliary variables for generation of unary operations. *) 171 | (* ******************************************************* *) 172 | let (unary_axioms, binary_axioms) = part_axioms axioms in 173 | (* 174 | Simple and complicated unary axioms. Simple are the 175 | ones of the form f(c) = d or f(d) = c for c and d constants. These 176 | can be easily applied. 177 | TODO: Axioms of the form f(x) = c for x variable and c constant 178 | are also easily dispatched with. 179 | 180 | Complicated are the complement of simple and cannot be so easily applied. 181 | *) 182 | let (simple', complicated') = part_unary_axioms unary_axioms in 183 | let simple = List.map snd simple' in 184 | let complicated = List.map snd complicated' in 185 | 186 | let normal_axioms = Enum_unary.get_normal_axioms complicated in 187 | 188 | let (unary_dos, unary_undos) = Enum_unary.get_unary_actions normal_axioms alg in 189 | 190 | Enum_unary.apply_simple simple alg ; 191 | 192 | for o=0 to lu - 1 do 193 | for i=0 to n-1 do 194 | if unary_arr.(o).(i) <> -1 && not (unary_dos (o,i)) then 195 | Error.runtime_error "All of the axioms cannot be met." (* TODO: raise exception and catch it in main loop. *) 196 | done 197 | done ; 198 | 199 | (* Auxiliary variables for generation of binary operations. *) 200 | (* ******************************************************* *) 201 | let (simple_binary, complicated_binary) = part_binary_axioms binary_axioms in 202 | 203 | (* 204 | left are the axioms which cannot be immediately applied 205 | These include axioms of depth > 1 and those with more variables. 206 | *) 207 | let (one_var_shallow, left) = part_one_var_binary complicated_binary in 208 | 209 | (* 210 | Partition axioms. Assoc and amenable are naturally associativity and amenable axioms. 211 | zippep_axioms are the rest that have to be checked differently than amenable. 212 | Zipped means in the form (number of distinct variables, axioms) 213 | *) 214 | let (assoc, amenable, stubborn) = 215 | let (assoc, rest) = partition_assoc left in 216 | let (amenable, rest) = partition_amenable rest in 217 | (assoc, 218 | amenable, 219 | (* Check axioms with fewer free variables first. *) 220 | List.sort (fun (n,_) (m,_) -> compare n m) rest 221 | ) 222 | in 223 | 224 | (* 225 | Maximum distinct variables in any of the axioms left. This is needed so we can cache 226 | all the ntuples. 227 | *) 228 | let max_vars = List.fold_left max 0 (List.map (fun (v,_) -> v) stubborn) in 229 | 230 | (* This could potentially gobble up memory. TODO *) 231 | let all_tuples = Array.init (max_vars + 1) (fun i -> ntuples n i) in 232 | 233 | 234 | let check = Enum_binary.get_checks all_tuples alg stubborn in 235 | 236 | let (binary_dos, binary_undos, reset_stack) = Enum_binary.get_binary_actions alg assoc amenable in 237 | 238 | let reset_binary_arr () = 239 | for o=0 to lb-1 do 240 | for i=0 to n-1 do 241 | for j=0 to n-1 do 242 | binary_arr.(o).(i).(j) <- -1 243 | done 244 | done 245 | done in 246 | 247 | let check_after_add () = 248 | for o=0 to lb-1 do 249 | for i=0 to n-1 do 250 | for j=0 to n-1 do 251 | if binary_arr.(o).(i).(j) <> -1 && not (binary_dos (o,i,j) o i j) then 252 | raise Enum_binary.Contradiction 253 | done 254 | done 255 | done in 256 | let reset_predicates () = 257 | for o=0 to lp-1 do 258 | for i=0 to n-1 do 259 | pred_arr.(o).(i) <- -1 260 | done 261 | done in 262 | let reset_relations () = 263 | for o=0 to lr-1 do 264 | for i=0 to n-1 do 265 | for j=0 to n-1 do 266 | rel_arr.(o).(i).(j) <- -1 267 | done 268 | done 269 | done in 270 | let cont_rel_pred () = 271 | reset_predicates () ; 272 | reset_relations () ; 273 | EPR.gen_predicate th alg 274 | (fun () -> EPR.gen_relation th alg (fun () -> k alg)) in 275 | let cont_binary () = 276 | try 277 | reset_binary_arr () ; 278 | reset_stack () ; 279 | Enum_binary.apply_simple_binary simple_binary alg ; 280 | Enum_binary.apply_one_var_shallow one_var_shallow alg ; 281 | check_after_add () ; (* TODO: Move this into the above functions. *) 282 | if not (check ()) then raise Enum_binary.Contradiction ; (* We might be lucky and fill everything already. *) 283 | Enum_binary.gen_binary th alg binary_dos binary_undos check cont_rel_pred 284 | with Enum_binary.Contradiction -> () in 285 | 286 | Enum_unary.gen_unary th unary_dos unary_undos alg cont_binary 287 | end 288 | with InconsistentAxioms -> () 289 | -------------------------------------------------------------------------------- /src/enum_binary.ml: -------------------------------------------------------------------------------- 1 | open Theory 2 | open Algebra 3 | 4 | exception Contradiction 5 | 6 | exception Break 7 | 8 | exception Undefined 9 | 10 | (* ************************************************************** *) 11 | (* Auxiliary functions for binary axioms. *) 12 | 13 | (* Apply simple axioms to the binary operation tables. *) 14 | let apply_simple_binary simple {alg_unary=unary_arr; alg_binary=binary_arr} = 15 | (* 16 | Applies simple axioms to the main operation tables. 17 | If axioms aren't simple it fails miserably. 18 | *) 19 | let apply_simple (_,axiom) = 20 | let rec get_value = function 21 | | (Const c) -> c 22 | | (Unary (op,v)) -> unary_arr.(op).(get_value v) 23 | | _ -> invalid_arg "Ooops, binary operation or variable in apply_simple.get_value. 24 | This shouldn't happen!" 25 | in match axiom with 26 | | (Binary (op, t1, t2), Const c) 27 | | (Const c, Binary (op, t1, t2)) -> 28 | let v1 = get_value t1 in 29 | let v2 = get_value t2 in 30 | if binary_arr.(op).(v1).(v2) <> -1 && binary_arr.(op).(v1).(v2) <> c then 31 | raise Contradiction 32 | else 33 | binary_arr.(op).(v1).(v2) <- c 34 | | _ -> invalid_arg "Not a simple binary axiom." 35 | in List.iter apply_simple simple 36 | 37 | (* Apply one variable shallow axioms to the binary_arr operation tables. *) 38 | let apply_one_var_shallow one_var_shallow {alg_size=n; 39 | alg_unary=unary_arr; 40 | alg_binary=binary_arr} = 41 | (* 42 | Apply one variable shallow axioms. Typical example is axioms for 43 | a unit element in a monoid (forall a: a * e = e) 44 | *) 45 | let apply_one_var (_,axiom) elem = 46 | let rec get_value = function 47 | | (Const c) -> c 48 | | (Var _) -> elem 49 | | (Unary (op,v)) -> unary_arr.(op).(get_value v) 50 | | _ -> invalid_arg "Ooops, binary operation in apply_one_var.get_value. This shouldn't happen!" 51 | in match axiom with 52 | | (Binary (op, t1, t2), t3) 53 | | (t3, Binary (op, t1, t2)) -> 54 | let v1 = get_value t1 in 55 | let v2 = get_value t2 in 56 | let v3 = get_value t3 in 57 | if binary_arr.(op).(v1).(v2) <> -1 && binary_arr.(op).(v1).(v2) <> v3 then 58 | raise Contradiction 59 | else 60 | binary_arr.(op).(v1).(v2) <- v3 61 | | _ -> invalid_arg "not a legal axiom in apply_one_var" 62 | in 63 | for i=0 to n-1 do 64 | List.iter (fun x -> apply_one_var x i) one_var_shallow 65 | done 66 | 67 | (* 68 | evaluate term in the context of vars. Raises Undefined if there is 69 | insufficient information to fully evaluate. 70 | *) 71 | let eval_eq {alg_unary=unary_arr; alg_binary=binary_arr} vars = 72 | let rec eval_eq' = function 73 | | Const c -> c (* XXX This is fishy, shouldn't we lookup c? *) 74 | | Elem e -> e 75 | | Var v -> vars.(v) 76 | | Unary (op, t) -> 77 | begin match eval_eq' t with 78 | | -1 -> raise Undefined 79 | | v -> unary_arr.(op).(v) 80 | end 81 | | Binary (op, lt, rt) -> 82 | begin match eval_eq' lt with 83 | | -1 -> raise Undefined 84 | | lv -> 85 | begin match eval_eq' rt with 86 | | -1 -> raise Undefined 87 | | rv -> binary_arr.(op).(lv).(rv) 88 | end 89 | end in eval_eq' 90 | 91 | let get_checks all_tuples ({alg_unary=unary_arr; 92 | alg_binary=binary_arr} as alg) 93 | zipped_axioms = 94 | (* 95 | Returns false if there is a conflict. 96 | *) 97 | let axiom_ok (num_vars, (left, right)) = 98 | let tuples = all_tuples.(num_vars) in 99 | let apply_to vars = 100 | try 101 | let a = eval_eq alg vars left in (* b is not evaluated if a is -1 *) 102 | a = -1 || 103 | let b = eval_eq alg vars right in 104 | (b = -1 || a = b) 105 | with Undefined -> true 106 | in 107 | Util.array_for_all apply_to tuples in 108 | (* 109 | Checks if all axioms are still valid. This is for axioms that are not amenable. 110 | Amenable are checked immediately after adding each element. 111 | *) 112 | let check () = List.for_all axiom_ok zipped_axioms in check 113 | 114 | 115 | (* ********************************************************************* *) 116 | (* 117 | Auxiliary functions for computing actions from binary axioms and 118 | checking axiom validity after adding one element. 119 | *) 120 | let get_binary_actions ({alg_size=n; 121 | alg_unary=unary_arr; 122 | alg_binary=binary_arr} as alg) 123 | assoc amenable = 124 | (* Compute actions from amenable axioms *) 125 | let actions_from_axiom (num_vars, axiom) = 126 | let stack = Stack.create () in 127 | let vars = Array.make num_vars (-1) in 128 | let nfill = ref 0 in 129 | let undo id = 130 | if id <> (-1,-1,-1) then 131 | while not (Stack.is_empty stack) && let (id', _, _,_) = Stack.top stack in id' = id do 132 | let (_, op, left, right) = Stack.pop stack in 133 | binary_arr.(op).(left).(right) <- -1 134 | done 135 | else Stack.clear stack in 136 | 137 | (* free fills the rest of the variables with all possible values *) 138 | let rec free cont term = 139 | if !nfill < num_vars then 140 | begin 141 | match term with 142 | | Var v when vars.(v) = -1 -> 143 | for k=0 to n-1 do 144 | vars.(v) <- k ; 145 | incr nfill ; 146 | cont () ; 147 | decr nfill ; 148 | vars.(v) <- -1 ; 149 | done 150 | | (Binary (_, l, r)) -> 151 | free (fun () -> free cont r) l 152 | | _ -> cont () 153 | end 154 | else cont () in 155 | 156 | let rec 157 | (* generate all possible subexpressions so that the term evaluates to k *) 158 | gen_all k cont term = 159 | if !nfill < num_vars then 160 | begin 161 | match term with 162 | | (Binary (op, l, r)) -> 163 | for u=0 to n-1 do 164 | for v=0 to n-1 do 165 | if binary_arr.(op).(u).(v) = k then 166 | gen_all u (fun () -> gen_all v cont r) l 167 | done 168 | done 169 | | (Unary (op, t)) -> 170 | for u=0 to n-1 do 171 | if unary_arr.(op).(u) = k then 172 | gen_all u cont t 173 | done 174 | | Var v when vars.(v) = -1 -> 175 | vars.(v) <- k ; 176 | incr nfill ; 177 | cont () ; 178 | decr nfill ; 179 | vars.(v) <- -1 180 | | Var v when vars.(v) = k -> cont () 181 | | Const c when c = k -> cont () 182 | | _ -> () 183 | end 184 | else cont () in 185 | 186 | (* We just set (i,j) to some value in o. 187 | See where we might use this to violate an axiom or set a new value. *) 188 | let rec 189 | fill (o,i,j) cont = function 190 | | (Binary (op, l, r)) when op = o -> 191 | (* both are in the left subtree *) 192 | fill (o,i,j) (fun () -> free cont r) l ; 193 | (* case l = i, r = j *) 194 | gen_all i (fun () -> gen_all j cont r) l ; 195 | (* both are in the right subtree *) 196 | fill (o,i,j) (fun () -> free cont l) r 197 | | (Binary (_, l, r)) -> 198 | (* both are in the left subtree *) 199 | fill (o,i,j) (fun () -> free cont r) l ; 200 | (* both are in the right subtree *) 201 | fill (o,i,j) (fun () -> free cont l) r 202 | | Unary (_, t) -> fill (o,i,j) cont t 203 | | _ -> () in 204 | 205 | (* 206 | check_other: Check if an axiom is violated or we can set a new value. 207 | This is the end of continuations. It is called when all 208 | of the variables have been set. 209 | *) 210 | match axiom with 211 | | (Binary (op1, l1, r1), Binary (op2, l2, r2)) -> 212 | let f cont id o i j = 213 | for k = 0 to num_vars - 1 do 214 | vars.(k) <- -1 215 | done ; 216 | nfill := 0 ; 217 | let check_other () = 218 | try 219 | let el1 = eval_eq alg vars l1 in 220 | let er1 = eval_eq alg vars r1 in 221 | let el2 = eval_eq alg vars l2 in 222 | let er2 = eval_eq alg vars r2 in 223 | if el1 <> -1 && el2 <> -1 && er1 <> -1 && er2 <> -1 then 224 | begin 225 | let left = binary_arr.(op1).(el1).(er1) in 226 | let right = binary_arr.(op2).(el2).(er2) in 227 | if left <> -1 && right = -1 then 228 | begin 229 | binary_arr.(op2).(el2).(er2) <- left ; 230 | 231 | Stack.push (id, op2, el2, er2) stack ; 232 | 233 | (* Try to fill some more or fail trying *) 234 | if not (cont id op2 el2 er2) then 235 | raise Break 236 | end 237 | else if left = -1 && right <> -1 then 238 | begin 239 | binary_arr.(op1).(el1).(er1) <- right ; 240 | 241 | Stack.push (id, op1, el1, er1) stack ; 242 | 243 | (* Try to fill some more or fail trying *) 244 | if not (cont id op1 el1 er1) then 245 | raise Break 246 | end 247 | else if (* left <> -1 && right <> -1 && *)left <> right then 248 | raise Break 249 | end 250 | with Undefined -> () in 251 | try 252 | fill (o,i,j) check_other (Binary (op2, l2, r2)) ; 253 | fill (o,i,j) check_other (Binary (op1, l1, r1)) ; true 254 | with Break -> false in (f, undo) 255 | | (term, Binary (op2, l2, r2)) 256 | | (Binary (op2, l2, r2), term) -> 257 | let f cont id o i j = 258 | for k = 0 to num_vars - 1 do 259 | vars.(k) <- -1 260 | done ; 261 | nfill := 0 ; 262 | let check_other () = 263 | try 264 | let el2 = eval_eq alg vars l2 in 265 | let er2 = eval_eq alg vars r2 in 266 | let elt = eval_eq alg vars term in 267 | if elt <> -1 && el2 <> -1 && er2 <> -1 then 268 | begin 269 | let left = elt in 270 | let right = binary_arr.(op2).(el2).(er2) in 271 | if right = -1 then 272 | begin 273 | binary_arr.(op2).(el2).(er2) <- left ; 274 | 275 | Stack.push (id, op2, el2, er2) stack ; 276 | 277 | (* Try to fill some more or fail trying *) 278 | if not (cont id op2 el2 er2) then 279 | raise Break 280 | end 281 | else if left <> right then 282 | raise Break 283 | end 284 | with Undefined -> () in 285 | try 286 | fill (o,i,j) check_other (Binary (op2, l2, r2)) ; true 287 | with Break -> false in (f, undo) 288 | | _ -> invalid_arg "Invalid axiom in actions_from_axiom. At least one term has to be binary." in 289 | 290 | (* Special case of actions_from_axiom for associativity axioms. 291 | It is ugly, but much faster. 292 | *) 293 | let actions_from_assoc = function 294 | | (_,(Binary (op1, Binary (op2, Var a1, Var b1), Var c1), Binary (op3, Var a2, Binary (op4, Var b2, Var c2)))) 295 | | (_,(Binary (op3, Var a2, Binary (op4, Var b2, Var c2)), Binary (op1, Binary (op2, Var a1, Var b1), Var c1))) 296 | when op1 = op2 && op2 = op3 && op3 = op4 && 297 | a1 = a2 && b1 = b2 && c1 = c2 && 298 | a1 <> b1 && a1 <> c1 && b1 <> c1 -> 299 | let stack = Stack.create () in 300 | let f cont id o i j = 301 | if o <> op1 then true 302 | else begin 303 | try 304 | (* cases a = i, b = j, c arbitrary and b = i, c = j, a arbitrary *) 305 | for k = 0 to n-1 do 306 | (* case a=i, b=j *) 307 | let ab = binary_arr.(o).(i).(j) in 308 | let bc = binary_arr.(o).(j).(k) in 309 | if bc <> -1 then 310 | begin 311 | let ab_c = binary_arr.(o).(ab).(k) in 312 | let a_bc = binary_arr.(o).(i).(bc) in 313 | if ab_c <> -1 && a_bc = -1 then 314 | begin 315 | binary_arr.(o).(i).(bc) <- ab_c ; 316 | 317 | Stack.push (id,o,i,bc) stack ; 318 | 319 | if not (cont id o i bc) then 320 | raise Break 321 | end 322 | else if ab_c = -1 && a_bc <> -1 then 323 | begin 324 | binary_arr.(o).(ab).(k) <- a_bc ; 325 | 326 | Stack.push (id, o,ab,k) stack ; 327 | 328 | if not (cont id o ab k) then 329 | raise Break 330 | end 331 | else if ab_c <> -1 && a_bc <> -1 && ab_c <> a_bc then 332 | raise Break 333 | end ; 334 | (* case b = i, c = j *) 335 | let ab = binary_arr.(o).(k).(i) in 336 | let bc = binary_arr.(o).(i).(j) in 337 | if ab <> -1 then 338 | begin 339 | let ab_c = binary_arr.(o).(ab).(j) in 340 | let a_bc = binary_arr.(o).(k).(bc) in 341 | if ab_c <> -1 && a_bc = -1 then 342 | begin 343 | binary_arr.(o).(k).(bc) <- ab_c ; 344 | 345 | Stack.push (id,o,k,bc) stack ; 346 | 347 | if not (cont id o k bc) then 348 | raise Break 349 | end 350 | else if ab_c = -1 && a_bc <> -1 then 351 | begin 352 | binary_arr.(o).(ab).(j) <- a_bc ; 353 | 354 | Stack.push (id, o,ab,j) stack ; 355 | 356 | if not (cont id o ab j) then 357 | raise Break 358 | end 359 | else if ab_c <> -1 && a_bc <> -1 && ab_c <> a_bc then 360 | raise Break 361 | end ; 362 | done ; 363 | (* Cases ab = i, c = j and a = i, bc = j *) 364 | for a=0 to n-1 do 365 | for b=0 to n-1 do 366 | (* case ab = i *) 367 | if binary_arr.(o).(a).(b) = i then 368 | begin 369 | let bc = binary_arr.(o).(b).(j) in 370 | if bc <> -1 then 371 | begin 372 | let a_bc = binary_arr.(o).(a).(bc) in 373 | if a_bc = -1 then 374 | begin 375 | binary_arr.(o).(a).(bc) <- binary_arr.(o).(i).(j) ; 376 | 377 | Stack.push (id,o,a,bc) stack ; 378 | 379 | if not (cont id o a bc) then 380 | raise Break 381 | end 382 | else if a_bc <> binary_arr.(o).(i).(j) then 383 | raise Break 384 | end 385 | end ; 386 | (* case bc = j *) 387 | let (b,c) = (a,b) in 388 | if binary_arr.(o).(b).(c) = j then 389 | begin 390 | let ab = binary_arr.(o).(i).(b) in 391 | if ab <> -1 then 392 | begin 393 | let ab_c = binary_arr.(o).(ab).(c) in 394 | if ab_c = -1 then 395 | begin 396 | binary_arr.(o).(ab).(c) <- binary_arr.(o).(i).(j) ; 397 | 398 | Stack.push (id, o, ab, c) stack ; 399 | 400 | if not (cont id o ab c) then 401 | raise Break 402 | end 403 | else if ab_c <> binary_arr.(o).(i).(j) then 404 | raise Break 405 | end 406 | end 407 | done 408 | done ; true 409 | with Break -> false 410 | end in 411 | let undo id = 412 | if (-1,-1,-1) <> id then 413 | while not (Stack.is_empty stack) && let (id', _, _,_) = Stack.top stack in id' = id do 414 | let (_, op, left, right) = Stack.pop stack in 415 | binary_arr.(op).(left).(right) <- -1 416 | done 417 | else Stack.clear stack 418 | in (f, undo) 419 | | _ -> invalid_arg "actions_from_assoc axiom given is not associativity" in 420 | 421 | let (dos, undos) = List.split (List.map actions_from_assoc assoc @ 422 | List.map actions_from_axiom amenable) in 423 | 424 | (* 425 | Use all the functions from dos. Continuation passed is dodos itself. 426 | The idea is that once we set a new element in f we immediately call 427 | dodos again to check validity of other axioms and maybe add some more 428 | elements. This sequence of calls to dodos will eventually end. If not 429 | sooner than at least when all operation tables are full. 430 | *) 431 | let rec 432 | dodos id o i j = List.for_all (fun f -> f dodos id o i j) dos in 433 | 434 | let doundos id = List.iter (fun f -> f id) undos in 435 | (dodos, doundos, fun () -> doundos (-1,-1,-1)) 436 | 437 | (* ******************************************************************************* *) 438 | (* End of auxiliary functions for binary axioms *) 439 | 440 | (* Main search function. *) 441 | (* 442 | Generate binary operation tables. lc, lu and lb are numbers of constants, 443 | unary and binary operations. unary_arr is supposed to be a matrix 444 | of unary operations where each line is an operation, binary_arr is assumed to 445 | be a 3d array of binary operations, dodos and doundos are actions for 446 | amenable axioms, check checks if non-amenable axioms are still valid. 447 | k is the continuation. 448 | *) 449 | let gen_binary th {alg_size=n; alg_binary=binary_arr; alg_unary=unary_arr} 450 | dodos doundos check k = 451 | let lb = Array.length th.th_binary in 452 | (* Main loop. *) 453 | (* o is index of operation, (i,j) current element *) 454 | let rec gen_operation o = function 455 | | _ when o = lb -> k () 456 | | (i,_) when i = n -> gen_operation (o+1) (0,0) 457 | | (i,j) when j = n -> gen_operation o (i+1,0) 458 | | (i,j) when binary_arr.(o).(i).(j) = -1 -> 459 | for k=0 to n-1 do 460 | binary_arr.(o).(i).(j) <- k ; 461 | (* check_after_add isn't needed here because fs report back instead *) 462 | if dodos (o,i,j) o i j && check () then gen_operation o (i,j+1) ; 463 | doundos (o,i,j) ; 464 | binary_arr.(o).(i).(j) <- -1 465 | done 466 | | (i,j) -> gen_operation o (i,j+1) in 467 | gen_operation 0 (0,0) 468 | -------------------------------------------------------------------------------- /src/enum_predicate_relation.ml: -------------------------------------------------------------------------------- 1 | open Theory 2 | open Algebra 3 | 4 | let select_usable axioms = 5 | let rec usable = function 6 | | True | False -> true 7 | | Equal _ | Exists _ | Or _ | Imply _ | Iff _ -> false 8 | | Forall (v,t) -> usable t 9 | | And (t1,t2) -> usable t1 && usable t2 10 | | Not t -> usable t 11 | | Relation _ | Predicate _ -> true (* assuming binary and unary ops are filled *) in 12 | List.partition (fun (_,a) -> usable a) axioms 13 | 14 | (* Check if all of the axioms are still valid and fill 15 | predicates or relations where possible. 16 | Returns pair (b, undos) where b is true if no contradiction 17 | was encountered (this does not mean there is no contradiction) 18 | and false otherwise. undos is a list of actions needed 19 | to return predicates and relations to previous state. 20 | *) 21 | let check_and_fill axioms ({alg_const=c; 22 | alg_unary=u; 23 | alg_binary=b; 24 | alg_predicates=p; 25 | alg_relations=r; 26 | alg_size=n} as alg) = 27 | let rec eval_fill vars undos target = function 28 | | True -> (target, undos) 29 | | False -> (not target, undos) 30 | | Equal (t1,t2) -> (true, undos) 31 | | Forall (v, f) when target -> 32 | let rec eval_forall undos = function 33 | | i when i = n -> (true, undos) 34 | | i -> begin 35 | vars.(v) <- i; 36 | let (t,unds) = eval_fill vars undos true f in 37 | if not t then (false, unds) else eval_forall unds (i+1) 38 | end in 39 | eval_forall undos 0 (* TODO: should probably set vars.(v) back to -1 *) 40 | | Forall (v,f) -> eval_fill vars undos true (Exists (v,Not f)) 41 | | Exists (v,f) when target -> 42 | let rec eval_exists = function 43 | | i when i = n -> (false, undos) 44 | | i -> begin 45 | vars.(v) <- i; 46 | match Eval.eval_formula alg vars f with 47 | | None | Some true -> (true, undos) 48 | | Some false -> eval_exists (i+1) 49 | end in eval_exists 0 50 | | Exists (v,f) -> eval_fill vars undos true (Forall (v,Not f)) 51 | | And (f1,f2) when target -> 52 | let (t,unds) = eval_fill vars undos true f1 in 53 | if not t then (false, unds) else eval_fill vars unds true f2 54 | | And (f1,f2) -> 55 | let t1 = Eval.eval_formula alg vars f1 in 56 | let t2 = Eval.eval_formula alg vars f2 in 57 | begin 58 | match t1,t2 with 59 | | (Some true, Some true) -> (false, undos) 60 | | (Some true, None) -> eval_fill vars undos false f2 61 | | (None, Some true) -> eval_fill vars undos false f1 62 | | _ -> (true, undos) 63 | end 64 | | Or (f1,f2) when target -> 65 | let t1 = Eval.eval_formula alg vars f1 in 66 | let t2 = Eval.eval_formula alg vars f2 in 67 | begin 68 | match t1,t2 with 69 | | (Some false, Some false) -> (false, undos) 70 | | (Some false, None) -> eval_fill vars undos true f2 71 | | (None, Some false) -> eval_fill vars undos true f1 72 | | _ -> (true, undos) 73 | end 74 | | Or (f1,f2) -> eval_fill vars undos true (And (Not f1,Not f2)) 75 | | Imply (f1,f2) when target -> 76 | let t1 = Eval.eval_formula alg vars f1 in 77 | let t2 = Eval.eval_formula alg vars f2 in 78 | begin 79 | match t1,t2 with 80 | | (Some true, Some false) -> (false, undos) 81 | | (Some true, None) -> eval_fill vars undos true f2 82 | | (None, Some false) -> eval_fill vars undos false f1 83 | | _ -> (true, undos) 84 | end 85 | | Imply (f1,f2) -> 86 | let (t,unds) = eval_fill vars undos true f1 in 87 | if not t then (false, unds) else eval_fill vars unds false f2 88 | | Iff (f1,f2) when target -> 89 | let t1 = Eval.eval_formula alg vars f1 in 90 | let t2 = Eval.eval_formula alg vars f2 in 91 | begin 92 | match t1,t2 with 93 | | (Some true, Some false) 94 | | (Some false, Some true) -> (false, undos) 95 | | (Some t, None) -> eval_fill vars undos t f2 96 | | (None, Some t) -> eval_fill vars undos t f1 97 | | _ -> (true, undos) 98 | end 99 | | Iff (f1,f2) -> 100 | let t1 = Eval.eval_formula alg vars f1 in 101 | let t2 = Eval.eval_formula alg vars f2 in 102 | begin 103 | match t1,t2 with 104 | | (Some true, Some true) 105 | | (Some false, Some false) -> (false, undos) 106 | | (Some t, None) -> eval_fill vars undos (not t) f2 107 | | (None, Some t) -> eval_fill vars undos (not t) f1 108 | | _ -> (true, undos) 109 | end 110 | | Not f -> eval_fill vars undos (not target) f 111 | | Predicate (i, t) -> begin 112 | match Eval.eval_term_partial alg vars t with 113 | | None -> (true,undos) 114 | | Some r -> 115 | if p.(i).(r) = -1 then 116 | begin 117 | p.(i).(r) <- if target then 1 else 0; 118 | (true, (0, (i,r,-1))::undos) 119 | end 120 | else (p.(i).(r) = (if target then 1 else 0), undos) 121 | end 122 | | Relation (i, t1,t2) -> 123 | let r1 = Eval.eval_term_partial alg vars t1 in 124 | let r2 = Eval.eval_term_partial alg vars t2 in 125 | match r1,r2 with 126 | | Some r1, Some r2 -> 127 | if r.(i).(r1).(r2) = -1 then 128 | begin 129 | r.(i).(r1).(r2) <- if target then 1 else 0; 130 | (true, (1, (i,r1,r2))::undos) 131 | end 132 | else (r.(i).(r1).(r2) = (if target then 1 else 0), undos) 133 | | _ -> (true, undos) 134 | in (* end of eval_fill *) 135 | let rec for_all_axioms (b, undos) = function 136 | | [] -> (b,undos) 137 | | ((vars,f)::fs) -> begin 138 | match eval_fill vars [] true f with 139 | | (true, unds) -> for_all_axioms (true, unds @ undos) fs 140 | | (false, unds) -> (false, unds @ undos) 141 | end in 142 | for_all_axioms (true, []) axioms 143 | 144 | let undo {alg_predicates=ps; alg_relations=rs} undos = 145 | let rec undo = function 146 | | [] -> () 147 | | ((0,(p,e,_))::us) -> ps.(p).(e) <- -1 ; undo us 148 | | ((1,(r,e1,e2))::us) -> rs.(r).(e1).(e2) <- -1 ; undo us 149 | | _ -> invalid_arg "invalid element in undos" 150 | in undo undos 151 | 152 | 153 | 154 | (* Silly predicate enumeration. *) 155 | 156 | let gen_predicate th ({alg_size=n; 157 | alg_predicates=predicate_arr} as alg) cont = 158 | let lp = Array.length th.th_predicates in 159 | let rec gen_predicate i = function 160 | | j when j = n && i < lp - 1 -> gen_predicate (i+1) 0 161 | | j when j = n || i = lp -> cont () 162 | | j when predicate_arr.(i).(j) = -1 -> 163 | for b = 0 to 1 do 164 | predicate_arr.(i).(j) <- b ; 165 | let (p, undos) = check_and_fill th.th_axioms alg in 166 | if p then gen_predicate i (j+1) ; 167 | undo alg undos ; 168 | predicate_arr.(i).(j) <- -1 ; 169 | done 170 | | j -> gen_predicate i (j+1) 171 | in gen_predicate 0 0 172 | 173 | (* Silly predicate enumeration. *) 174 | 175 | let gen_predicate th ({alg_size=n; 176 | alg_predicates=predicate_arr} as alg) cont = 177 | let lp = Array.length th.th_predicates in 178 | let rec gen_predicate i = function 179 | | j when j = n && i < lp - 1 -> gen_predicate (i+1) 0 180 | | j when j = n || i = lp -> cont () 181 | | j when predicate_arr.(i).(j) = -1 -> 182 | for b = 0 to 1 do 183 | predicate_arr.(i).(j) <- b ; 184 | let (p, undos) = check_and_fill th.th_axioms alg in 185 | if p then gen_predicate i (j+1) ; 186 | undo alg undos ; 187 | predicate_arr.(i).(j) <- -1 ; 188 | done 189 | | j -> gen_predicate i (j+1) 190 | in gen_predicate 0 0 191 | 192 | let gen_relation th ({alg_size=n; 193 | alg_relations=relation_arr} as alg) cont = 194 | let (usable, rest) = select_usable th.th_axioms in 195 | (* We use usable axioms only once. Should improve speed. *) 196 | let (r,_) = check_and_fill usable alg in 197 | if r then begin 198 | let lr = Array.length th.th_relations in 199 | let rec gen_relation r = function 200 | | _ when r = lr -> let b, undos = check_and_fill th.th_axioms alg in 201 | if b && undos = [] then cont () 202 | | (i,_) when i = n -> gen_relation (r+1) (0,0) 203 | | (i,j) when j = n -> gen_relation r (i+1,0) 204 | | (i,j) when relation_arr.(r).(i).(j) = -1 -> 205 | for b=0 to 1 do 206 | relation_arr.(r).(i).(j) <- b ; 207 | let (p, undos) = check_and_fill rest alg in 208 | if p then gen_relation r (i,j+1) ; 209 | undo alg undos ; 210 | relation_arr.(r).(i).(j) <- -1 211 | done 212 | | (i,j) -> gen_relation r (i,j+1) in 213 | gen_relation 0 (0,0) 214 | end 215 | -------------------------------------------------------------------------------- /src/enum_unary.ml: -------------------------------------------------------------------------------- 1 | open Theory 2 | open Algebra 3 | 4 | (* ******************************************************************************* *) 5 | (* Auxiliary functions for unary axioms. *) 6 | 7 | (* Apply simple axioms to operation tables unary_arr *) 8 | let apply_simple simple {alg_unary=unary_arr} = 9 | (* Apply simple axioms *) 10 | List.iter 11 | (function 12 | | (Unary (op, Const c1), Const c2) 13 | | (Const c2, Unary (op, Const c1)) -> 14 | if unary_arr.(op).(c1) <> -1 && unary_arr.(op).(c1) <> c2 15 | then raise InconsistentAxioms 16 | else unary_arr.(op).(c1) <- c2 17 | | _ -> invalid_arg "Not a simple axiom in apply_simple.") 18 | simple 19 | 20 | (* Get do and undo actions from axioms in normal form for use in main loop of gen_unary. *) 21 | let get_unary_actions normal_axioms {alg_size=n; alg_unary=unary_arr} = 22 | (* 23 | Traces function applications in equation eq starting with start. If an unknown 24 | element comes up, it returns None. 25 | *) 26 | let trace start eq = 27 | let rec result acc = function 28 | | [] -> Some acc 29 | | (x::xs) -> let r = unary_arr.(x).(acc) in 30 | if r = -1 then None else result r xs in 31 | result start eq in 32 | 33 | (* 34 | TODO: There are situations where we could deduce from axioms 35 | that an operation is bijection. E.g. f(f(x)) = x. It may be 36 | worth the trouble to implement. 37 | *) 38 | let actions_from_axiom axiom = 39 | let stack = Stack.create () in 40 | 41 | let undo id = 42 | while not (Stack.is_empty stack) && (let (id', _, _) = Stack.top stack in id' = id) do 43 | let (_, o, i) = Stack.pop stack in 44 | unary_arr.(o).(i) <- -1 45 | done in 46 | 47 | let trace_with cont id left i right j l1 l2 = 48 | match (trace i left, trace j right) with 49 | | (Some r1, Some r2) -> 50 | begin 51 | match (l1,l2) with 52 | | (None, None) -> r1 = r2 53 | | (None, Some op) -> 54 | if unary_arr.(op).(r2) = -1 then 55 | begin 56 | unary_arr.(op).(r2) <- r1 ; 57 | Stack.push (id, op, r2) stack ; 58 | cont id 59 | end 60 | else 61 | unary_arr.(op).(r2) = r1 62 | | (Some op, None) -> 63 | if unary_arr.(op).(r1) = -1 then 64 | begin 65 | unary_arr.(op).(r1) <- r2 ; 66 | Stack.push (id, op, r1) stack ; 67 | cont id 68 | end 69 | else 70 | unary_arr.(op).(r1) = r2 71 | | (Some op1, Some op2) -> 72 | let left = unary_arr.(op1).(r1) in 73 | let right = unary_arr.(op2).(r2) in 74 | if left = -1 && right <> -1 then 75 | begin 76 | unary_arr.(op1).(r1) <- right ; 77 | Stack.push (id, op1, r1) stack ; 78 | cont id 79 | end 80 | else if left <> -1 && right = -1 then 81 | begin 82 | unary_arr.(op2).(r2) <- left ; 83 | Stack.push (id, op2, r2) stack ; 84 | cont id 85 | end 86 | else 87 | left = right 88 | end 89 | | _ -> true in 90 | 91 | match axiom with 92 | | ((true, id1, l1, left), (true, id2, l2, right)) when id1 = id2 -> 93 | let check_axiom cont id = 94 | let p = ref true in 95 | for i=0 to n-1 do 96 | p := !p && trace_with cont id left i right i l1 l2 97 | done ; !p in (check_axiom, undo) 98 | | ((true, id1, l1, left), (true, id2, l2, right)) -> 99 | let check_axiom cont id = 100 | let p = ref true in 101 | for i=0 to n-1 do 102 | for j=0 to n-1 do 103 | p := !p && trace_with cont id left i right j l1 l2 104 | done 105 | done ; !p in (check_axiom, undo) 106 | | ((true, id1, l1, left), (false, id2, l2, right)) 107 | | ((false, id2, l2, right), (true, id1, l1, left)) -> 108 | let check_axiom cont id = 109 | let p = ref true in 110 | for i=0 to n-1 do 111 | p := !p && trace_with cont id left i right id2 l1 l2 112 | done ; !p in (check_axiom, undo) 113 | | ((_, id1, l1, left), (_, id2, l2, right)) -> 114 | let check_axiom cont id = 115 | trace_with cont id left id1 right id2 l1 l2 in (check_axiom, undo) in 116 | 117 | (* 118 | Check if any of the equations are violated by starting with 119 | every element and tracing function applications. 120 | *) 121 | let (dos, undos) = List.split (List.map actions_from_axiom normal_axioms) in 122 | 123 | let rec 124 | dodos id = List.for_all (fun f -> f dodos id) dos in 125 | let doundos id = List.iter (fun f -> f id) undos in 126 | (dodos, doundos) 127 | 128 | 129 | (* Get axioms in normal form from "complicated" axioms. *) 130 | let get_normal_axioms complicated = 131 | (* 132 | Equation must not contain any binary operations. 133 | path_from_equation returns a 4-tuple (indicator, index, index of last operation, 134 | list of indices of unary operations). indicator is true if term starts with a variable 135 | and false if it starts with a constant. Index is index of variable or constant. 136 | *) 137 | let path_from_equation e = 138 | (* TODO this function must be a kludge, get rid of it. *) 139 | let rec init = function 140 | | [] -> [] 141 | | [_] -> [] 142 | | x :: xs -> x :: init xs 143 | in 144 | let rec loop acc = function 145 | | (Unary (op,t)) -> loop (op::acc) t 146 | | (Var v) -> (true, v, acc) 147 | | (Const c) -> (false, c, acc) 148 | | _ -> invalid_arg "path_from_equation: Binary operation." in 149 | match loop [] e with 150 | | (var, start, []) -> (var, start, None, []) 151 | | (var, start, os) -> (var, start, Some (List.nth os (List.length os - 1)), init os) in 152 | 153 | (* 154 | Unary axioms in "normal form". Each side of the equation is a 4-tuple 155 | (is_variable, variable or const index, last operation or None, list of unary operations) 156 | *) 157 | List.map (fun (eq1, eq2) -> (path_from_equation eq1, path_from_equation eq2)) complicated 158 | 159 | (* ************************************************************************** *) 160 | (* End of auxiliary functions for unary axioms. *) 161 | 162 | 163 | (* ************************************************************************** *) 164 | (* Main search functions. *) 165 | 166 | (* 167 | Generate unary operation tables. lc, lu and lb are numbers of constants, 168 | unary and binary operations. 169 | *) 170 | let gen_unary th dodos doundos {alg_size=n; alg_unary=unary_arr} k = 171 | let lu = Array.length th.th_unary in 172 | (* Main loop. *) 173 | let rec 174 | gen_operation i = function 175 | | j when j = n && i < lu - 1 -> gen_operation (i+1) 0 176 | | j when j = n || i = lu -> k () 177 | (* || i = lu is necessary for when there aren't any unary operations *) 178 | | j when unary_arr.(i).(j) = -1 -> 179 | for k = 0 to n-1 do 180 | unary_arr.(i).(j) <- k ; 181 | if dodos (i,j) then gen_operation i (j+1) ; 182 | doundos (i,j) ; 183 | unary_arr.(i).(j) <- -1 ; 184 | done 185 | | j -> gen_operation i (j+1) 186 | in gen_operation 0 0 187 | 188 | -------------------------------------------------------------------------------- /src/error.ml: -------------------------------------------------------------------------------- 1 | (** Error reporting. *) 2 | 3 | (** Exception [Error (loc, err, msg)] indicates an error of type [err] with 4 | error message [msg], occurring at position [loc]. *) 5 | exception Error of (Common.position * string * string) 6 | 7 | (** [error loc err_type] raises an error of type [err_type]. The [kfprintf] magic allows 8 | one to write [msg] using a format string. *) 9 | let error ~loc err_type = 10 | let k _ = 11 | let msg = Format.flush_str_formatter () in 12 | raise (Error (loc, err_type, msg)) 13 | in 14 | Format.kfprintf k Format.str_formatter 15 | 16 | (** Common error kinds. *) 17 | let unknown_error msg = error ~loc:Common.Nowhere "Error" msg 18 | let internal_error msg = error ~loc:Common.Nowhere "Internal error" msg 19 | let runtime_error msg = error ~loc:Common.Nowhere "Fatal error" msg 20 | let usage_error msg = error ~loc:Common.Nowhere "Usage error" msg 21 | let syntax_error ~loc msg = error ~loc "Syntax error" msg 22 | let typing_error ~loc msg = error ~loc "Typing error" msg 23 | let warning_error ~loc msg = error ~loc "Warning" msg 24 | -------------------------------------------------------------------------------- /src/eval.ml: -------------------------------------------------------------------------------- 1 | open Algebra 2 | open Theory 3 | 4 | exception Undefined 5 | 6 | (* Various evaluation functions. *) 7 | 8 | (* 9 | Evaluate term in the context of vars, unary_arr and binary_arr. 10 | unary and binary operation arrays are assumed to be full so there 11 | should be no -1's anywhere. 12 | *) 13 | let eval_term {alg_const=c; alg_unary=u; alg_binary=b} vars t = 14 | let rec eval = function 15 | | Const v -> c.(v) 16 | | Elem e -> e 17 | | Var v -> vars.(v) 18 | | Unary (op, t) -> u.(op).(eval t) 19 | | Binary (op, t1, t2) -> b.(op).(eval t1).(eval t2) 20 | in 21 | eval t 22 | 23 | let eval_term_partial {alg_const=const_arr; alg_unary=unary_arr; alg_binary=binary_arr} vars term = 24 | let rec eval_t_p = function 25 | | Const c -> 26 | begin match const_arr.(c) with 27 | | -1 -> raise Undefined 28 | | v -> v 29 | end 30 | | Elem e -> e 31 | | Var v -> vars.(v) 32 | | Unary (op, t) -> 33 | begin match eval_t_p t with 34 | | -1 -> raise Undefined 35 | | v -> unary_arr.(op).(v) 36 | end 37 | | Binary (op, lt, rt) -> 38 | begin match eval_t_p lt with 39 | | -1 -> raise Undefined 40 | | lv -> 41 | begin match eval_t_p rt with 42 | | -1 -> raise Undefined 43 | | rv -> binary_arr.(op).(lv).(rv) 44 | end 45 | end in 46 | try match eval_t_p term with | -1 -> None | s -> Some s with Undefined -> None 47 | 48 | 49 | (* Evaluate a formula. Returns None if undefined otherwise Some bool. *) 50 | let eval_formula ({alg_predicates=ps; alg_relations=rs; alg_size=n} as alg) vars f = 51 | let rec eval_formula' = function 52 | | True -> Some true 53 | | False -> Some false 54 | | Equal (t1,t2) -> let r1 = eval_term_partial alg vars t1 in 55 | let r2 = eval_term_partial alg vars t2 in 56 | begin 57 | match r1, r2 with 58 | | (Some r1, Some r2) -> Some (r1 = r2) 59 | | _ -> None 60 | end 61 | | Forall (i,f) -> let b = ref true in 62 | let k = ref 0 in 63 | begin 64 | try 65 | while !k < n && !b do 66 | vars.(i) <- !k; 67 | (match eval_formula' f with 68 | | None -> raise Undefined 69 | | Some p -> b := p) ; 70 | incr k 71 | done ; Some !b 72 | with Undefined -> None 73 | end 74 | | Exists (i,f) -> let b = ref false in 75 | let k = ref 0 in 76 | begin 77 | try 78 | while !k < n && not !b do 79 | vars.(i) <- !k; 80 | (match eval_formula' f with 81 | | None -> raise Undefined 82 | | Some p -> b := p) ; 83 | incr k 84 | done ; Some !b 85 | with Undefined -> None 86 | end 87 | | And (f1,f2) -> begin 88 | match eval_formula' f1 with 89 | | None -> begin 90 | match eval_formula' f2 with 91 | | Some false -> Some false 92 | | _ -> None 93 | end 94 | | Some false -> Some false 95 | | Some true -> eval_formula' f2 96 | end 97 | | Or (f1,f2) -> begin 98 | match eval_formula' f1 with 99 | | None -> begin 100 | match eval_formula' f2 with 101 | | Some true -> Some true 102 | | _ -> None 103 | end 104 | | Some true -> Some true 105 | | Some false -> eval_formula' f2 106 | end 107 | | Imply (f1,f2) -> begin 108 | match eval_formula' f1 with 109 | | None -> begin 110 | match eval_formula' f2 with 111 | | Some true -> Some true 112 | | _ -> None 113 | end 114 | | Some false -> Some true 115 | | Some true -> eval_formula' f2 116 | end 117 | | Iff (f1,f2) -> begin 118 | match eval_formula' f1 with 119 | | None -> None 120 | | a -> Some (a = eval_formula' f2) 121 | end 122 | | Not f -> begin 123 | match eval_formula' f with 124 | | None -> None 125 | | Some p -> Some (not p) 126 | end 127 | | Predicate (p,t) -> begin 128 | match eval_term_partial alg vars t with 129 | | None -> None 130 | | Some v -> let r = ps.(p).(v) in 131 | if r = -1 then None 132 | else Some (if r = 1 then true else false) 133 | end 134 | | Relation (r,t1,t2) -> begin 135 | match eval_term_partial alg vars t1 with 136 | | None -> None 137 | | Some v1 -> begin 138 | match eval_term_partial alg vars t2 with 139 | | None -> None 140 | | Some v2 -> let rr = rs.(r).(v1).(v2) in 141 | if rr = -1 then None 142 | else Some (if rr = 1 then true else false) 143 | end 144 | end in 145 | eval_formula' f 146 | 147 | -------------------------------------------------------------------------------- /src/first_order.ml: -------------------------------------------------------------------------------- 1 | open Theory 2 | open Algebra 3 | 4 | (* 5 | Evaluate term in the context of vars, unary_arr and binary_arr. 6 | unary and binary operation arrays are assumed to be full so there 7 | should be no -1's anywhere. 8 | *) 9 | let eval_term {alg_const=c; alg_unary=u; alg_binary=b} vars t = 10 | let rec eval = function 11 | | Const v -> c.(v) 12 | | Var v -> vars.(v) 13 | | Elem e -> e 14 | | Unary (op, t) -> u.(op).(eval t) 15 | | Binary (op, t1, t2) -> b.(op).(eval t1).(eval t2) 16 | in 17 | eval t 18 | 19 | (* Check if formula f is valid for algebra alg. *) 20 | let check_formula alg (vars,f) = 21 | let n = alg.alg_size in 22 | let rec eval = function 23 | | False -> false 24 | | True -> true 25 | | Equal (t1, t2) -> eval_term alg vars t1 = eval_term alg vars t2 26 | | Predicate (k, t) -> alg.alg_predicates.(k).(eval_term alg vars t) = 1 27 | | Relation (k, t1, t2) -> 28 | alg.alg_relations.(k).(eval_term alg vars t1).(eval_term alg vars t2) = 1 29 | | Not f -> not (eval f) 30 | | And (f1,f2) -> eval f1 && eval f2 31 | | Or (f1,f2) -> eval f1 || eval f2 32 | | Imply (f1,f2) -> eval f1 <= eval f2 33 | | Iff (f1, f2) -> eval f1 = eval f2 34 | | Forall (i,f) -> 35 | let b = ref true in 36 | let v = ref 0 in 37 | while !b && !v < n do 38 | vars.(i) <- !v ; 39 | b := eval f ; 40 | incr v 41 | done ; 42 | !b 43 | | Exists (i,f) -> 44 | let b = ref false in 45 | let v = ref 0 in 46 | while not !b && !v < n do 47 | vars.(i) <- !v ; 48 | b := eval f ; 49 | incr v 50 | done ; 51 | !b 52 | in 53 | eval f 54 | 55 | let check_axioms theory alg = 56 | List.for_all (check_formula alg) theory.th_axioms 57 | -------------------------------------------------------------------------------- /src/indecomposable.ml: -------------------------------------------------------------------------------- 1 | open Algebra 2 | open Theory 3 | open Util 4 | 5 | (* It is assumed that the two algebras correspond to the same signature. Furthermore, an error 6 | occurs if there are predicates or relations. *) 7 | let product {alg_size=n1; alg_name=a1; alg_prod=p1; alg_const=c1; alg_unary=u1; alg_binary=b1; alg_predicates=pr1; alg_relations=r1} 8 | {alg_size=n2; alg_name=a2; alg_prod=p2; alg_const=c2; alg_unary=u2; alg_binary=b2; alg_predicates=pr2; alg_relations=r2} = 9 | if Array.length pr1 <> 0 || Array.length r1 <> 0 || Array.length pr2 <> 0 || Array.length r2 <> 0 10 | then Error.runtime_error "cannot form products of structures with predicates and relations" 11 | else begin 12 | let size = n1 * n2 in 13 | let mapping i j = n2 * i + j in 14 | (* IMPORTANT: combine_unary and combine_binary assume that algebras are "synced". *) 15 | let combine_unary arr1 arr2 = 16 | let arr = Array.make size 0 in 17 | for k = 0 to n1 - 1 do 18 | for l = 0 to n2 - 1 do 19 | arr.(mapping k l) <- mapping arr1.(k) arr2.(l) 20 | done 21 | done ; 22 | arr 23 | in 24 | let combine_binary arr1 arr2 = 25 | let arr = Array.make_matrix size size 0 in 26 | for k = 0 to n1 - 1 do 27 | for l = 0 to n2 - 1 do 28 | for i = 0 to n1 - 1 do 29 | for j = 0 to n2 - 1 do 30 | arr.(mapping k l).(mapping i j) <- mapping arr1.(k).(i) arr2.(l).(j) 31 | done 32 | done 33 | done 34 | done ; 35 | arr 36 | in 37 | let const = Util.array_map2 mapping c1 c2 in 38 | let unary = Util.array_map2 combine_unary u1 u2 in 39 | let binary = Util.array_map2 combine_binary b1 b2 in 40 | { alg_size = size; 41 | alg_name = None; 42 | alg_prod = Util.alg_prod a1 a2 p1 p2; 43 | alg_const=const; 44 | alg_unary=unary; 45 | alg_binary=binary; 46 | alg_predicates=pr1; 47 | alg_relations=r1; 48 | } 49 | end 50 | 51 | (* factors is a map of possible factors *) 52 | let gen_decomposable theory n factors output = 53 | let algebras = Iso.empty_store () in 54 | (* Generate all products of algebras which partition into algebras of sizes in partition. 55 | partition is assumed to be in some order (descending or ascending). *) 56 | let gen_product partition = 57 | (* last is size of last algebra added to product, start is where to start 58 | with current algebras (this is only used if we have to multiply two consecutive 59 | algebras of the same size), part is the tail of partition *) 60 | let rec gen_p last start acc = function 61 | | [] -> 62 | (* XXX check to see if it is faster to call First_order.check_axioms first and then Iso.seen. *) 63 | let ac = with_cache acc in 64 | let (seen, i) = Iso.seen theory ac algebras in 65 | if not seen && First_order.check_axioms theory acc 66 | then begin 67 | Iso.store algebras ~inv:i (Util.copy_algebra_with_cache ac) ; 68 | output acc 69 | end 70 | | (p::ps) -> 71 | let start = if last = p then start else 0 in 72 | let last = p in 73 | Util.iter_enum 74 | (fun i a -> if i >= start then gen_p last i (product acc a) ps) 75 | (IntMap.find last factors) 76 | in 77 | match partition with 78 | | [] -> () 79 | | p::ps -> List.iter (fun a -> gen_p p 0 a ps) (IntMap.find p factors) 80 | in (* end of gen_product *) 81 | List.iter gen_product (Util.partitions n) ; 82 | algebras 83 | -------------------------------------------------------------------------------- /src/input.ml: -------------------------------------------------------------------------------- 1 | (* Abstract syntax as produced by the parser. *) 2 | 3 | type variable = string 4 | type operation = string 5 | 6 | type term = term' * Common.position 7 | and term' = 8 | | Var of variable 9 | | UnaryOp of operation * term 10 | | BinaryOp of operation * term * term 11 | 12 | type formula = formula' * Common.position 13 | and formula' = 14 | | True 15 | | False 16 | | Equal of term * term 17 | | NotEqual of term * term 18 | | UnaryPr of operation * term 19 | | BinaryPr of operation * term * term 20 | | Forall of variable list * formula 21 | | Exists of variable list * formula 22 | | And of formula * formula 23 | | Or of formula * formula 24 | | Imply of formula * formula 25 | | Iff of formula * formula 26 | | Not of formula 27 | 28 | type theory_entry = theory_entry' * Common.position 29 | and theory_entry' = 30 | | Constant of operation list 31 | | Unary of operation list 32 | | Binary of operation list 33 | | Predicate of operation list 34 | | Relation of operation list 35 | | Axiom of string option * formula 36 | 37 | type theory_name = string 38 | 39 | type theory = { th_name : theory_name option ; th_entries : theory_entry list } 40 | 41 | (* [as_equation f] tries to convert an axiom to an equation. *) 42 | let rec as_equation (f, _) = 43 | match f with 44 | | Equal (t1, t2) -> Some (t1, t2) 45 | | Forall (_, f) -> as_equation f 46 | | False | True | NotEqual _ | UnaryPr _ | BinaryPr _ | 47 | Exists _ | And _ | Or _ | Imply _ | Iff _ | Not _ -> None 48 | 49 | -------------------------------------------------------------------------------- /src/invariant.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrejbauer/alg/95715bb1bf93fcc534a8d6c7c96c8913dc03de0c/src/invariant.ml -------------------------------------------------------------------------------- /src/iso.ml: -------------------------------------------------------------------------------- 1 | open Theory 2 | open Algebra 3 | 4 | exception Break 5 | exception Found 6 | 7 | (* 8 | Checks if a function commutes with permutation. 9 | f(i(a)) = i(f(a)). 10 | *) 11 | let check_unary iso u1 u2 = 12 | let l = Array.length iso in 13 | Util.for_all (fun i -> iso.(u1.(i)) = u2.(iso.(i))) 0 (l-1) 14 | 15 | (* 16 | Checks if binary operation is multiplicative. 17 | *) 18 | let check_binary iso b1 b2 = 19 | let l = Array.length iso in 20 | Util.for_all2 (fun i j -> iso.(b1.(i).(j)) = b2.(iso.(i)).(iso.(j))) 0 (l-1) 0 (l-1) 21 | 22 | let check_predicate iso p1 p2 = 23 | let l = Array.length iso in 24 | Util.for_all (fun i -> p1.(i) = p2.(iso.(i))) 0 (l-1) 25 | 26 | let check_relation iso r1 r2 = 27 | let l = Array.length iso in 28 | Util.for_all2 (fun i j -> r1.(i).(j) = r2.(iso.(i)).(iso.(j))) 0 (l-1) 0 (l-1) 29 | 30 | let are_iso {th_const=const_op; th_unary=unary_op; th_binary=binary_op; 31 | th_predicates=predicates_op; th_relations=relations_op} 32 | ({alg_size=n1; alg_const=c1; alg_unary=u1; 33 | alg_binary=b1; alg_relations=r1; alg_predicates=p1}, 34 | {indegs=indegs1; outdegs=outdegs1}) 35 | ({alg_size=n2; alg_const=c2; alg_unary=u2; 36 | alg_binary=b2; alg_relations=r2; alg_predicates=p2}, 37 | {indegs=indegs2; outdegs=outdegs2}) = 38 | if n1 <> n2 39 | then false 40 | else 41 | let n = n1 in 42 | let lp = Array.length predicates_op in 43 | let lr = Array.length relations_op in 44 | let used = Array.make n false in 45 | let iso = Array.make n (-1) in 46 | (* Handle constants *) 47 | Util.array_iter2 (fun i j -> used.(j) <- true ; iso.(i) <- j) c1 c2 ; 48 | 49 | (* 50 | Generate actions from unary and binary operations analogous to generation 51 | of actions from axioms. Axioms here are implicit from the definition of isomorphism 52 | IMPORTANT: actions_from_unary and actions_from_binary assume that algebras 53 | are "synced". 54 | *) 55 | let actions_from_unary arr1 arr2 = 56 | let stack = Stack.create () in 57 | let f_unary i = 58 | if iso.(arr1.(i)) = -1 then 59 | begin 60 | if used.(arr2.(iso.(i))) then 61 | false 62 | else 63 | begin 64 | iso.(arr1.(i)) <- arr2.(iso.(i)) ; 65 | used.(arr2.(iso.(i))) <- true ; 66 | Stack.push i stack ; true 67 | end 68 | end 69 | else not (iso.(arr1.(i)) <> arr2.(iso.(i))) in 70 | let undo i = 71 | while not (Stack.is_empty stack) && Stack.top stack = i do 72 | iso.(arr1.(Stack.pop stack)) <- -1 ; 73 | used.(arr2.(iso.(i))) <- false 74 | done in (f_unary, undo) in 75 | 76 | let actions_from_binary arr1 arr2 = 77 | let stack = Stack.create () in 78 | let f_binary i = 79 | try 80 | for k=0 to n-1 do 81 | if iso.(k) <> -1 then 82 | begin 83 | if iso.(arr1.(i).(k)) = -1 then 84 | begin 85 | if used.(arr2.(iso.(i)).(iso.(k))) then 86 | raise Break ; 87 | 88 | iso.(arr1.(i).(k)) <- arr2.(iso.(i)).(iso.(k)) ; 89 | used.(arr2.(iso.(i)).(iso.(k))) <- true ; 90 | Stack.push (i, (arr1.(i).(k), arr2.(iso.(i)).(iso.(k)))) stack 91 | end 92 | else if iso.(arr1.(i).(k)) <> arr2.(iso.(i)).(iso.(k)) then 93 | raise Break ; 94 | 95 | if iso.(arr1.(k).(i)) = -1 then 96 | begin 97 | if used.(arr2.(iso.(k)).(iso.(i))) then 98 | raise Break ; 99 | 100 | iso.(arr1.(k).(i)) <- arr2.(iso.(k)).(iso.(i)) ; 101 | used.(arr2.(iso.(k)).(iso.(i))) <- true ; 102 | Stack.push (i, (arr1.(k).(i), arr2.(iso.(k)).(iso.(i)))) stack 103 | end 104 | else if iso.(arr1.(k).(i)) <> arr2.(iso.(k)).(iso.(i)) then 105 | raise Break 106 | end 107 | done ; true 108 | with Break -> false in 109 | let undo i = 110 | while not (Stack.is_empty stack) && i = fst (Stack.top stack) do 111 | let (_, (a,b)) = Stack.pop stack in 112 | iso.(a) <- -1 ; 113 | used.(b) <- false 114 | done in (f_binary, undo) in 115 | 116 | let (dos, undos) = List.split (Util.array_map2_list actions_from_unary u1 u2 117 | @ Util.array_map2_list actions_from_binary b1 b2) in 118 | 119 | let check_predicates ps1 ps2 i = 120 | Util.for_all (fun j -> ps1.(j).(i) = ps2.(j).(iso.(i))) 0 (lp-1) in 121 | 122 | let check_relations rs1 rs2 i = 123 | Util.for_all2 (fun x y -> iso.(y) = -1 || 124 | rs1.(x).(i).(y) = rs2.(x).(iso.(i)).(iso.(y)) && 125 | rs1.(x).(y).(i) = rs2.(x).(iso.(y)).(iso.(i))) 0 (lr-1) 0 (n-1) in 126 | 127 | let dos = check_predicates p1 p2 :: check_relations r1 r2 :: dos in 128 | 129 | let allowin = Array.make_matrix lr n [] in 130 | Array.iteri (fun r -> 131 | Array.iteri (fun i -> 132 | List.iter (fun x -> 133 | allowin.(r).(x) <- indegs2.(r).(i)))) indegs1 ; 134 | 135 | let allowout = Array.make_matrix lr n [] in 136 | Array.iteri (fun r -> 137 | Array.iteri (fun i -> 138 | List.iter (fun x -> 139 | allowout.(r).(x) <- Util.intersect allowin.(r).(x) outdegs2.(r).(i)))) outdegs1 ; 140 | 141 | let all = Util.enumFromTo 0 (n-1) in 142 | 143 | (* we must set allow to all for the case when there are no relations *) 144 | let allow = Array.make n all in 145 | Array.iter ( 146 | Array.iteri (fun i x -> 147 | allow.(i) <- Util.intersect x allow.(i))) allowout ; 148 | 149 | (* 150 | End check when iso is full. Check that it really is an isomorphism. 151 | Constants need not be checked because they are set independently. 152 | *) 153 | let check () = 154 | let check_op f a1 a2 = Util.for_all_pairs (fun i j -> f iso i j) a1 a2 in 155 | let us = check_op check_unary u1 u2 in 156 | let bs = check_op check_binary b1 b2 in 157 | let ps = check_op check_predicate p1 p2 in 158 | let rs = check_op check_relation r1 r2 in 159 | if us && bs && ps && rs 160 | then raise Found 161 | in 162 | let rec gen_iso = function 163 | | i when i = n -> check () 164 | | i when iso.(i) <> -1 -> gen_iso (i+1) 165 | | i -> 166 | List.iter 167 | begin 168 | fun k -> 169 | if not used.(k) then 170 | begin 171 | used.(k) <- true ; 172 | iso.(i) <- k ; 173 | if List.for_all (fun f -> f i) dos then 174 | gen_iso (i+1) ; 175 | List.iter (fun f -> f i) undos ; 176 | iso.(i) <- -1 ; 177 | used.(k) <- false 178 | end 179 | end 180 | allow.(i) in 181 | try 182 | gen_iso 0 ; false 183 | with Found -> true 184 | 185 | (* Utility functions for checking whether we have already seen a given algebra. *) 186 | 187 | let empty_store () = Hashtbl.create 1000 188 | 189 | (* Return true if store contains an isomorphic copy of algebra a. Also return 190 | the invariant for a. *) 191 | let seen th a store = 192 | let i = invariant (wo_cache a) in 193 | let lst = (try Hashtbl.find store i with Not_found -> []) in 194 | List.exists (are_iso th a) lst, i 195 | 196 | (* Store the given algebra. Warning: if you pass the optional 197 | invariant [i] then it _must_ be the same as [invariant a]. This is 198 | used so that we do not have to recompute invariants. *) 199 | let store s ?inv a = 200 | let i = (match inv with Some i -> i | None -> invariant (wo_cache a)) in 201 | let lst = (try Hashtbl.find s i with Not_found -> []) in 202 | Hashtbl.replace s i (a::lst) 203 | 204 | -------------------------------------------------------------------------------- /src/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Parser 4 | } 5 | 6 | let ident = ['_' 'a'-'z' 'A'-'Z' '0'-'9']+ 7 | 8 | let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '/' '\\' ':' '<' '=' '>' '?' '@' '^' '|' '~'] 9 | let prefixop = ['?' '!' '~'] symbolchar* 10 | let infixop0 = ['=' '<' '>' '|' '&' '$'] symbolchar* 11 | let infixop1 = ['@' '^'] symbolchar* 12 | let infixop2 = ['+' '-' '\\'] symbolchar* 13 | let infixop4 = "**" symbolchar* 14 | let infixop3 = ['*' '/' '%'] symbolchar* 15 | 16 | rule token = parse 17 | | '#' [^'\n']* ('\n' | eof) { new_line lexbuf; token lexbuf } 18 | | '\n' { new_line lexbuf; token lexbuf } 19 | | [' ' '\t'] { token lexbuf } 20 | | "Theory" { THEORY } 21 | | "Constants" { CONSTANT } 22 | | "Constant" { CONSTANT } 23 | | "Unary" { UNARY } 24 | | "Binary" { BINARY } 25 | | "Predicate" { PREDICATE } 26 | | "Predicates" { PREDICATE } 27 | | "Relation" { RELATION } 28 | | "Relations" { RELATION } 29 | | "Axiom" { AXIOM } 30 | | "Theorem" { THEOREM } 31 | | "forall" { FORALL } 32 | | "exists" { EXISTS } 33 | | "True" { TRUE } 34 | | "False" { FALSE } 35 | | "/\\" { AND } 36 | | "and" { AND } 37 | | "\\/" { OR } 38 | | "or" { OR } 39 | | "->" { IMPLY } 40 | | "<->" { IFF } 41 | | "=>" { IMPLY } 42 | | "<=>" { IFF } 43 | | '=' { EQUAL } 44 | | "<>" { NOTEQUAL } 45 | | "!=" { NOTEQUAL } 46 | | "not" { NOT } 47 | | "." { DOT } 48 | 49 | | ident { IDENT (lexeme lexbuf) } 50 | | prefixop { PREFIXOP (Lexing.lexeme lexbuf) } 51 | | infixop0 { INFIXOP0 (Lexing.lexeme lexbuf) } 52 | | infixop1 { INFIXOP1 (Lexing.lexeme lexbuf) } 53 | | infixop2 { INFIXOP2 (Lexing.lexeme lexbuf) } 54 | | infixop4 (* Comes before infixop3 because ** matches the infixop3 pattern too *) 55 | { INFIXOP4 (Lexing.lexeme lexbuf) } 56 | | infixop3 { INFIXOP3 (Lexing.lexeme lexbuf) } 57 | | '(' { LPAREN } 58 | | ')' { RPAREN } 59 | | ':' { COLON } 60 | | ',' { COMMA } 61 | | eof { EOF } 62 | 63 | { 64 | } 65 | -------------------------------------------------------------------------------- /src/output.ml: -------------------------------------------------------------------------------- 1 | (* Output in various formats. *) 2 | 3 | module T = Theory 4 | module A = Algebra 5 | module C = Config 6 | 7 | (* A formatter for output *) 8 | type formatter = { 9 | header: unit -> unit; 10 | size_header: int -> unit; 11 | algebra: A.algebra -> unit; 12 | size_footer: unit -> unit; 13 | footer: (int * int) list -> unit; 14 | count_header: unit -> unit; 15 | count: int -> int -> unit; 16 | count_footer: (int * int) list -> unit; 17 | interrupted: unit -> unit 18 | } 19 | 20 | module type Formatter = 21 | sig 22 | val init : Config.config -> out_channel -> string list -> T.theory -> formatter 23 | end 24 | 25 | (* Several output styles (Markdown, LaTeX, and HTML) are sufficiently similar 26 | that it is worth implementing them all the same way via the following structure. *) 27 | module type TextStyle = 28 | sig 29 | val ttfont : string -> string 30 | val names : T.theory -> A.algebra -> string array 31 | val link : string -> string -> string 32 | val title : out_channel -> string -> unit 33 | val section : out_channel -> string -> unit 34 | val footer : out_channel -> unit 35 | val code : out_channel -> string list -> unit 36 | val warning : out_channel -> string -> unit 37 | val algebra_header : out_channel -> string -> string option -> unit 38 | val algebra_unary : out_channel -> string array -> string -> int array -> unit 39 | val algebra_binary : out_channel -> string array -> string -> int array array -> unit 40 | val algebra_predicate : out_channel -> string array -> string -> int array -> unit 41 | val algebra_relation : out_channel -> string array -> string -> int array array -> unit 42 | val algebra_footer : out_channel -> unit 43 | val count_header : out_channel -> unit 44 | val count_row : out_channel -> int -> int -> unit 45 | val count_footer : out_channel -> string option -> unit 46 | end 47 | 48 | (* A functor taking an implementation of [TextStyle] to [Formatter]. *) 49 | module Make(S : TextStyle) : Formatter = 50 | struct 51 | 52 | (* Create a URL which queries the http://oeis.org/. *) 53 | let oeis lst = 54 | let m = List.fold_left (fun m (n,_) -> max m n) 0 lst in 55 | let nums = String.concat "," 56 | (List.map (fun n -> match Util.lookup n lst with None -> "_" | Some k -> string_of_int k) (Util.enumFromTo 2 m)) 57 | in 58 | let nums' = String.concat ", " 59 | (List.map (fun n -> match Util.lookup n lst with None -> "_" | Some k -> string_of_int k) (Util.enumFromTo 2 m)) 60 | in 61 | nums', "http://oeis.org/search?q=" ^ nums 62 | 63 | let init 64 | {C.sizes=sizes; C.source=source} 65 | ch 66 | src_lines 67 | ({T.th_name=th_name; T.th_const=th_const; T.th_unary=th_unary; T.th_binary=th_binary; 68 | T.th_predicates=th_pred; T.th_relations=th_rel} as th) = 69 | 70 | let count_footer lst = 71 | let lst = List.filter (fun (n,_) -> n >= 2) lst in 72 | S.count_footer ch 73 | (if List.length lst <= 2 74 | then None 75 | else 76 | let nums, url = oeis lst in 77 | Some (Printf.sprintf "Check the numbers %s on-line at oeis.org\n" (S.link nums url))) 78 | in 79 | 80 | { header = 81 | begin fun () -> 82 | S.title ch th_name ; 83 | if source then S.code ch src_lines 84 | end; 85 | 86 | size_header = 87 | begin fun n -> 88 | S.section ch ("Size " ^ string_of_int n) 89 | end; 90 | 91 | algebra = 92 | begin fun ({A.alg_name=name; A.alg_prod=prod; A.alg_const=const; A.alg_unary=unary; A.alg_binary=binary; 93 | A.alg_predicates=pred; A.alg_relations=rel} as a) -> 94 | let name = (match name with | None -> "Model of " ^ th_name | Some n -> n) in 95 | let info = 96 | begin match prod with 97 | | None -> None 98 | | Some lst -> Some ("Decomposition: " ^ String.concat ", " (List.map S.ttfont lst)) 99 | end 100 | in 101 | let ns = S.names th a in 102 | S.algebra_header ch name info ; 103 | Array.iteri (fun op t -> S.algebra_unary ch ns th_unary.(op) t) unary ; 104 | Array.iteri (fun op t -> S.algebra_binary ch ns th_binary.(op) t) binary ; 105 | Array.iteri (fun p t -> S.algebra_predicate ch ns th_pred.(p) t) pred ; 106 | Array.iteri (fun r t -> S.algebra_relation ch ns th_rel.(r) t) rel ; 107 | S.algebra_footer ch 108 | end; 109 | 110 | size_footer = begin fun () -> () end; 111 | 112 | count_header = begin fun () -> S.count_header ch end; 113 | 114 | count = S.count_row ch; 115 | 116 | count_footer = count_footer; 117 | 118 | footer = 119 | begin fun lst -> 120 | S.section ch "Statistics" ; 121 | S.count_header ch ; 122 | List.iter (fun (n,k) -> S.count_row ch n k) lst ; 123 | count_footer lst ; 124 | S.footer ch 125 | end; 126 | 127 | interrupted = begin fun () -> S.warning ch "the computation was interrupted by the user" end 128 | } 129 | end (* Make *) 130 | 131 | module MarkdownStyle : TextStyle = 132 | struct 133 | let ttfont str = str 134 | 135 | let names {T.th_const=th_const; T.th_unary=th_unary; T.th_binary=th_binary} {A.alg_size=n; A.alg_const=const} = 136 | let forbidden_names = Array.to_list th_const @ Array.to_list th_unary @ Array.to_list th_binary in 137 | let default_names = 138 | ref (List.filter (fun x -> not (List.mem x forbidden_names)) 139 | ["a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; 140 | "n"; "o"; "p"; "q"; "e"; "r"; "s"; "t"; "u"; "v"; "x"; "y"; "z"; 141 | "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; 142 | "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"]) 143 | in 144 | let m = List.length !default_names in 145 | let ns = Array.make n "?" in 146 | (* Constants *) 147 | for k = 0 to Array.length th_const - 1 do ns.(const.(k)) <- th_const.(k) done ; 148 | for k = 0 to n-1 do 149 | if ns.(k) = "?" then 150 | ns.(k) <- 151 | match !default_names with 152 | | [] -> "x" ^ string_of_int (k - m) 153 | | d::ds -> default_names := ds ; d 154 | done ; 155 | ns 156 | 157 | let link txt url = Printf.sprintf "[%s](%s)" txt url 158 | 159 | let title ch str = Printf.fprintf ch "# Theory %s\n\n" str 160 | 161 | let section ch str = Printf.fprintf ch "# %s\n\n" str 162 | 163 | let footer ch = () 164 | 165 | let code ch lines = 166 | List.iter (fun line -> Printf.fprintf ch " %s\n" line) lines ; 167 | Printf.fprintf ch "\n" 168 | 169 | let warning ch msg = Printf.fprintf ch "\n\n**Warning: %s**\n\n" msg 170 | 171 | let algebra_header ch name info = 172 | Printf.fprintf ch "### %s\n\n" name ; 173 | match info with 174 | | None -> () 175 | | Some msg -> Printf.fprintf ch "%s\n\n" msg 176 | 177 | let algebra_unary ch names op t = 178 | let n = Array.length t in 179 | let w = Array.fold_left (fun w s -> max w (String.length s)) 0 names in 180 | let v = String.length op in 181 | let ds = String.make w '-' in 182 | Printf.fprintf ch "\n %*s |" (max w v) op ; 183 | for i = 0 to n-1 do Printf.fprintf ch " %*s" w names.(i) done ; 184 | Printf.fprintf ch "\n %s-+" (String.make (max w v) '-'); 185 | for i = 0 to n-1 do Printf.fprintf ch "--%s" ds done; 186 | Printf.fprintf ch "\n %*s |" (max w v) " "; 187 | for i = 0 to n-1 do Printf.fprintf ch " %*s" w names.(t.(i)) done ; 188 | Printf.fprintf ch "\n\n" 189 | 190 | let algebra_binary ch names op t = 191 | let n = Array.length t in 192 | let w = Array.fold_left (fun w s -> max w (String.length s)) 0 names in 193 | let v = String.length op in 194 | let ds = String.make w '-' in 195 | Printf.fprintf ch "\n %*s |" (max w v) op; 196 | for i = 0 to n-1 do Printf.fprintf ch " %*s" w names.(i) done ; 197 | Printf.fprintf ch "\n %s-+" (String.make (max w v) '-') ; 198 | for j = 0 to n-1 do Printf.fprintf ch "--%s" ds done ; 199 | for i = 0 to n-1 do 200 | Printf.fprintf ch "\n %*s |" (max w v) names.(i) ; 201 | for j = 0 to n-1 do 202 | Printf.fprintf ch " %*s" w names.(t.(i).(j)) 203 | done 204 | done ; 205 | Printf.fprintf ch "\n\n" 206 | 207 | let algebra_predicate ch names p t = 208 | let n = Array.length t in 209 | let w = Array.fold_left (fun w s -> max w (String.length s)) 0 names in 210 | let v = String.length p in 211 | let ds = String.make w '-' in 212 | Printf.fprintf ch "\n %*s |" (max w v) p ; 213 | for i = 0 to n-1 do Printf.fprintf ch " %*s" w names.(i) done ; 214 | Printf.fprintf ch "\n %s-+" (String.make (max w v) '-'); 215 | for i = 0 to n-1 do Printf.fprintf ch "--%s" ds done; 216 | Printf.fprintf ch "\n %*s |" (max w v) " "; 217 | for i = 0 to n-1 do Printf.fprintf ch " %*d" w t.(i) done ; 218 | Printf.fprintf ch "\n\n" 219 | 220 | let algebra_relation ch names r t = 221 | let n = Array.length t in 222 | let w = Array.fold_left (fun w s -> max w (String.length s)) 0 names in 223 | let v = String.length r in 224 | let ds = String.make w '-' in 225 | Printf.fprintf ch "\n %*s |" (max w v) r; 226 | for i = 0 to n-1 do Printf.fprintf ch " %*s" w names.(i) done ; 227 | Printf.fprintf ch "\n %s-+" (String.make (max w v) '-') ; 228 | for j = 0 to n-1 do Printf.fprintf ch "--%s" ds done ; 229 | for i = 0 to n-1 do 230 | Printf.fprintf ch "\n %*s |" (max w v) names.(i) ; 231 | for j = 0 to n-1 do 232 | Printf.fprintf ch " %*d" w t.(i).(j) 233 | done 234 | done ; 235 | Printf.fprintf ch "\n\n" 236 | 237 | let algebra_footer ch = 238 | Printf.fprintf ch "\n- - - - - - - - - - - - - - - - - - - - - - - - - - - -\n\n%!" (* flush *) 239 | 240 | let count_header ch = 241 | Printf.fprintf ch " size | count\n" ; 242 | Printf.fprintf ch " -----|------\n" 243 | 244 | let count_row ch n k = 245 | Printf.fprintf ch " %4d | %d\n%!" n k 246 | 247 | let count_footer ch = function 248 | | None -> Printf.fprintf ch "\n" 249 | | Some msg -> Printf.fprintf ch "\n%s\n" msg 250 | 251 | end (* MarkdownStyle *) 252 | 253 | module HTMLStyle : TextStyle = 254 | struct 255 | let escape str = str (* TODO should escape < > & and so on. *) 256 | 257 | let ttfont str = "" ^ escape str ^ "" 258 | 259 | let names {T.th_const=th_const; T.th_unary=th_unary; T.th_binary=th_binary} {A.alg_size=n; A.alg_const=const} = 260 | let forbidden_names = Array.to_list th_const @ Array.to_list th_unary @ Array.to_list th_binary in 261 | let default_names = 262 | ref (List.filter (fun x -> not (List.mem x forbidden_names)) 263 | ["a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; 264 | "n"; "o"; "p"; "q"; "e"; "r"; "s"; "t"; "u"; "v"; "x"; "y"; "z"; 265 | "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; 266 | "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"]) 267 | in 268 | let m = List.length !default_names in 269 | let ns = Array.make n "?" in 270 | (* Constants *) 271 | for k = 0 to Array.length th_const - 1 do ns.(const.(k)) <- th_const.(k) done ; 272 | for k = 0 to n-1 do 273 | if ns.(k) = "?" then 274 | ns.(k) <- 275 | match !default_names with 276 | | [] -> "x" ^ string_of_int (k - m) 277 | | d::ds -> default_names := ds ; d 278 | done ; 279 | ns 280 | 281 | let link txt url = Printf.sprintf "%s" url txt 282 | 283 | let title ch str = Printf.fprintf ch "\n\nTheory %s\n\n\n

Theory %s

\n\n" str str 284 | 285 | let section ch str = Printf.fprintf ch "

%s

\n\n" str 286 | 287 | let footer ch = Printf.fprintf ch "\n\n\n" 288 | 289 | let code ch lines = 290 | Printf.fprintf ch "\n
\n" ;
291 |     List.iter (fun line -> Printf.fprintf ch "%s\n" line) lines ;
292 |     Printf.fprintf ch "
\n" 293 | 294 | let warning ch msg = Printf.fprintf ch "\n\n
Warning: %s
\n\n" msg 295 | 296 | let algebra_header ch name info = 297 | Printf.fprintf ch "

%s

\n\n" name ; 298 | match info with 299 | | None -> () 300 | | Some msg -> Printf.fprintf ch "

%s

\n\n" msg 301 | 302 | let algebra_unary ch names op t = 303 | let n = Array.length t in 304 | Printf.fprintf ch "\n

\n" op ; 305 | for i = 0 to n-1 do Printf.fprintf ch "" names.(i) done ; 306 | Printf.fprintf ch "\n" ; 307 | for i = 0 to n-1 do Printf.fprintf ch "" names.(t.(i)) done ; 308 | Printf.fprintf ch "\n
%s%s
 %s

\n\n" 309 | 310 | let algebra_binary ch names op t = 311 | let n = Array.length t in 312 | Printf.fprintf ch "\n

\n" op; 313 | for i = 0 to n-1 do Printf.fprintf ch "" names.(i) done ; 314 | Printf.fprintf ch "\n" ; 315 | for i = 0 to n-1 do 316 | Printf.fprintf ch "" names.(i) ; 317 | for j = 0 to n-1 do 318 | Printf.fprintf ch "" names.(t.(i).(j)) 319 | done ; 320 | Printf.fprintf ch "\n" 321 | done ; 322 | Printf.fprintf ch "
%s%s
%s%s

\n\n" 323 | 324 | let algebra_predicate ch names p t = 325 | let n = Array.length t in 326 | Printf.fprintf ch "\n

\n" p ; 327 | for i = 0 to n-1 do Printf.fprintf ch "" names.(i) done ; 328 | Printf.fprintf ch "\n" ; 329 | for i = 0 to n-1 do Printf.fprintf ch "" t.(i) done ; 330 | Printf.fprintf ch "\n
%s%s
 %d

\n\n" 331 | 332 | let algebra_relation ch names r t = 333 | let n = Array.length t in 334 | Printf.fprintf ch "\n

\n" r; 335 | for i = 0 to n-1 do Printf.fprintf ch "" names.(i) done ; 336 | Printf.fprintf ch "\n" ; 337 | for i = 0 to n-1 do 338 | Printf.fprintf ch "" names.(i) ; 339 | for j = 0 to n-1 do 340 | Printf.fprintf ch "" t.(i).(j) 341 | done ; 342 | Printf.fprintf ch "\n" 343 | done ; 344 | Printf.fprintf ch "
%s%s
%s%d

\n\n" 345 | 346 | let algebra_footer ch = Printf.fprintf ch "\n\n%!" 347 | 348 | let count_header ch = 349 | Printf.fprintf ch "\n\n" 350 | 351 | let count_row ch n k = 352 | Printf.fprintf ch "\n" n k 353 | 354 | let count_footer ch = function 355 | | None -> Printf.fprintf ch "
SizeCount
%d%d
" 356 | | Some msg -> Printf.fprintf ch "\n

%s

\n" msg 357 | 358 | end (* HTMLStyle *) 359 | 360 | module LaTeXStyle : TextStyle = 361 | struct 362 | 363 | (* Escape LaTeX special characters. This is horribly inefficient, but it does not matter, 364 | as it is only done once. *) 365 | let escape str = 366 | let trans = [ 367 | ('_', "{\\_}"); 368 | ('$', "{\\$}"); 369 | ('%', "{\\%}"); 370 | ('&', "{\\&}"); 371 | ('*', "{*}"); 372 | ('+', "{+}"); 373 | ('-', "{-}"); 374 | ('/', "{/}"); 375 | ('\\',"{\\backslash}"); 376 | (':', "{:}"); 377 | ('<', "{<}"); 378 | ('=', "{=}"); 379 | ('>', "{>}"); 380 | ('?', "{?}"); 381 | ('@', "{@}"); 382 | ('^', "{\\^}"); 383 | ('|', "{:}"); 384 | ('~', "{\\char126}"); 385 | ] 386 | in 387 | let s = ref "" in 388 | String.iter 389 | (fun c -> s := !s ^ (try List.assoc c trans with Not_found -> String.make 1 c)) 390 | str ; 391 | !s 392 | 393 | let ttfont str = "\\texttt{" ^ escape str ^ "}" 394 | let math str = "$" ^ str ^ "$" 395 | 396 | let names {T.th_const=th_const; T.th_unary=th_unary; T.th_binary=th_binary} {A.alg_size=n; A.alg_const=const} = 397 | let forbidden_names = Array.to_list th_const @ Array.to_list th_unary @ Array.to_list th_binary in 398 | let default_names = 399 | ref (List.filter (fun x -> not (List.mem x forbidden_names)) 400 | ["a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; 401 | "n"; "o"; "p"; "q"; "e"; "r"; "s"; "t"; "u"; "v"; "x"; "y"; "z"; 402 | "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; 403 | "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"]) 404 | in 405 | let m = List.length !default_names in 406 | let ns = Array.make n "?" in 407 | (* Constants *) 408 | for k = 0 to Array.length th_const - 1 do ns.(const.(k)) <- math th_const.(k) done ; 409 | for k = 0 to n-1 do 410 | if ns.(k) = "?" then 411 | ns.(k) <- 412 | match !default_names with 413 | | [] -> math ("x_" ^ string_of_int (k - m)) 414 | | d::ds -> default_names := ds ; math d 415 | done ; 416 | ns 417 | 418 | let link txt url = txt 419 | 420 | let title ch str = 421 | Printf.fprintf ch 422 | "\\documentclass{article}\n\\begin{document}\n\\title{Theory \\texttt{%s}}\n\\author{Computed by alg}\n\\maketitle\n\\parindent=0pt\\parskip=\\baselineskip\n" (escape str) 423 | 424 | let section ch str = Printf.fprintf ch "\\section*{%s}\n" str 425 | 426 | let footer ch = Printf.fprintf ch "\n\\end{document}\n" 427 | 428 | let code ch lines = 429 | Printf.fprintf ch "\n\\begin{verbatim}\n" ; 430 | List.iter (fun line -> Printf.fprintf ch "%s\n" line) lines ; 431 | Printf.fprintf ch "\\end{verbatim}\n" 432 | 433 | let warning ch msg = Printf.fprintf ch "\\begin{center}\\textbf{Warning: %s}\\end{center}\n" msg 434 | 435 | let algebra_header ch name info = 436 | Printf.fprintf ch "\\subsection*{%s}\n\n" (escape name) ; 437 | match info with 438 | | None -> () 439 | | Some msg -> Printf.fprintf ch "\n\n\\noindent\n%s\n\n" msg 440 | 441 | let algebra_unary ch names op t = 442 | let n = Array.length t in 443 | Printf.fprintf ch "\\begin{tabular}[t]{|" ; 444 | for i = 0 to n do Printf.fprintf ch "c|" done ; 445 | Printf.fprintf ch "}\n\\hline\n" ; 446 | Printf.fprintf ch "%s " (ttfont op); 447 | for i = 0 to n-1 do Printf.fprintf ch "& %s " names.(i) done ; 448 | Printf.fprintf ch "\\\\ \\hline\n" ; 449 | for i = 0 to n-1 do Printf.fprintf ch "& %s " names.(t.(i)) done ; 450 | Printf.fprintf ch "\\\\ \\hline\n\\end{tabular}\n\n" 451 | 452 | let algebra_binary ch names op t = 453 | let n = Array.length t in 454 | Printf.fprintf ch "\\begin{tabular}[t]{|" ; 455 | for i = 0 to n do Printf.fprintf ch "c|" done ; 456 | Printf.fprintf ch "}\n\\hline\n" ; 457 | Printf.fprintf ch "%s " (ttfont op); 458 | for i = 0 to n-1 do Printf.fprintf ch "& %s " names.(i) done ; 459 | Printf.fprintf ch "\\\\ \\hline\n" ; 460 | for i = 0 to n-1 do 461 | Printf.fprintf ch "%s " names.(i) ; 462 | for j = 0 to n-1 do 463 | Printf.fprintf ch "& %s " names.(t.(i).(j)) 464 | done ; 465 | Printf.fprintf ch "\\\\ \\hline\n" 466 | done ; 467 | Printf.fprintf ch "\\end{tabular}\n\n" 468 | 469 | let algebra_predicate ch names p t = 470 | let n = Array.length t in 471 | Printf.fprintf ch "\\begin{tabular}[t]{|" ; 472 | for i = 0 to n do Printf.fprintf ch "c|" done ; 473 | Printf.fprintf ch "}\n\\hline\n" ; 474 | Printf.fprintf ch "%s " (ttfont p); 475 | for i = 0 to n-1 do Printf.fprintf ch "& %s " names.(i) done ; 476 | Printf.fprintf ch "\\\\ \\hline\n" ; 477 | for i = 0 to n-1 do Printf.fprintf ch "& %d " t.(i) done ; 478 | Printf.fprintf ch "\\\\ \\hline\n\\end{tabular}\n\n" 479 | 480 | let algebra_relation ch names r t = 481 | let n = Array.length t in 482 | Printf.fprintf ch "\\begin{tabular}[t]{|" ; 483 | for i = 0 to n do Printf.fprintf ch "c|" done ; 484 | Printf.fprintf ch "}\n\\hline\n" ; 485 | Printf.fprintf ch "%s " (ttfont r); 486 | for i = 0 to n-1 do Printf.fprintf ch "& %s " names.(i) done ; 487 | Printf.fprintf ch "\\\\ \\hline\n" ; 488 | for i = 0 to n-1 do 489 | Printf.fprintf ch "%s " names.(i) ; 490 | for j = 0 to n-1 do 491 | Printf.fprintf ch "& %d " t.(i).(j) 492 | done ; 493 | Printf.fprintf ch "\\\\ \\hline\n" 494 | done ; 495 | Printf.fprintf ch "\\end{tabular}\n\n" 496 | 497 | let algebra_footer ch = Printf.fprintf ch "\n\n%!" 498 | 499 | let count_header ch = 500 | Printf.fprintf ch "\\begin{tabular}{|c|c|}\n\\hline\nSize & Count \\\\ \\hline\n" 501 | 502 | let count_row ch n k = 503 | Printf.fprintf ch "%d & %d \\\\ \\hline" n k 504 | 505 | let count_footer ch _ = 506 | Printf.fprintf ch "\\end{tabular}\n\n" 507 | 508 | end (* LaTeXStyle *) 509 | 510 | (* The actual formatters for Markdown, HTML and LaTeX. *) 511 | module Markdown = Make(MarkdownStyle) 512 | module HTML = Make(HTMLStyle) 513 | module LaTeX = Make(LaTeXStyle) 514 | 515 | (* The json formatter is different from the others, so we implement it directly. *) 516 | module JSON : Formatter = 517 | struct 518 | let sep i n = if i < n then ", " else "" 519 | 520 | let init config ch _ 521 | {T.th_name=th_name; T.th_const=th_const; T.th_unary=th_unary; T.th_binary=th_binary; 522 | T.th_predicates=th_pred; T.th_relations=th_rel} = 523 | 524 | { 525 | header = begin fun () -> Printf.fprintf ch "[ \"%s\"" th_name end; 526 | 527 | size_header = begin fun _ -> () end; 528 | 529 | algebra = 530 | begin 531 | fun {A.alg_const=const; A.alg_unary=unary; A.alg_binary=binary; A.alg_predicates=pred; A.alg_relations=rel} -> 532 | Printf.fprintf ch ",\n {\n"; 533 | Array.iteri (fun i c -> Printf.fprintf ch " \"%s\" : %d,\n" c const.(i)) th_const; 534 | let ulen = Array.length unary in 535 | Array.iteri 536 | (fun op t -> 537 | let n = Array.length t in 538 | Printf.fprintf ch " \"%s\" : [" th_unary.(op) ; 539 | for i = 0 to n-1 do Printf.fprintf ch "%d%s" t.(i) (sep i (n-1)) done; 540 | Printf.fprintf ch "]%s\n" (sep op ulen) 541 | ) 542 | unary; 543 | let blen = Array.length binary in 544 | Array.iteri 545 | (fun op t -> 546 | let n = Array.length t in 547 | Printf.fprintf ch " \"%s\" :\n [\n" th_binary.(op) ; 548 | for i = 0 to n-1 do 549 | Printf.fprintf ch " [" ; 550 | for j = 0 to n-1 do Printf.fprintf ch "%d%s" t.(i).(j) (sep j (n-1)) done ; 551 | Printf.fprintf ch "]%s\n" (sep i (n-1)) 552 | done ; 553 | Printf.fprintf ch " ]%s\n" (sep op (blen-1)) 554 | ) 555 | binary; 556 | let plen = Array.length pred in 557 | Array.iteri 558 | (fun p t -> 559 | let n = Array.length t in 560 | Printf.fprintf ch " \"%s\" : [" th_pred.(p) ; 561 | for i = 0 to n-1 do 562 | Printf.fprintf ch "%s%s" (if t.(i) = 1 then "true" else "false") (sep i (n-1)) 563 | done; 564 | Printf.fprintf ch "]%s\n" (sep p plen)) 565 | pred; 566 | let rlen = Array.length rel in 567 | Array.iteri 568 | (fun r t -> 569 | let n = Array.length t in 570 | Printf.fprintf ch " \"%s\" :\n [\n" th_rel.(r) ; 571 | for i = 0 to n-1 do 572 | Printf.fprintf ch " [" ; 573 | for j = 0 to n-1 do 574 | Printf.fprintf ch "%s%s" (if t.(i).(j) = 1 then "true" else "false") (sep j (n-1)) 575 | done ; 576 | Printf.fprintf ch "]%s\n" (sep i (n-1)) 577 | done ; 578 | Printf.fprintf ch " ]%s\n" (sep r (rlen-1))) 579 | rel; 580 | Printf.fprintf ch " }" 581 | end; 582 | 583 | size_footer = begin fun () -> () end; 584 | 585 | footer = begin fun _ -> Printf.fprintf ch "]\n" end; 586 | 587 | count_header = begin fun () -> () end; 588 | 589 | count = begin fun n k -> () end; 590 | 591 | count_footer = begin fun lst -> 592 | Printf.fprintf ch 593 | ",\n [%s]\n]\n" 594 | (String.concat ", " (List.map (fun (n,k) -> "[" ^ string_of_int n ^ "," ^ string_of_int k ^ "]") lst)) 595 | end; 596 | 597 | interrupted = begin fun () -> Error.runtime_error "interrupted by the user while producing JSON output" end; 598 | } 599 | end 600 | -------------------------------------------------------------------------------- /src/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | %} 3 | 4 | %token THEORY 5 | %token CONSTANT UNARY BINARY PREDICATE RELATION 6 | %token AXIOM THEOREM 7 | %token IDENT 8 | %token PREFIXOP INFIXOP0 INFIXOP1 INFIXOP2 INFIXOP3 INFIXOP4 9 | %token LPAREN RPAREN 10 | %token COLON COMMA DOT 11 | %token FALSE TRUE 12 | %token AND OR IMPLY IFF NOT EQUAL NOTEQUAL EXISTS FORALL 13 | %token EOF 14 | 15 | %left INFIXOP0 16 | %right INFIXOP1 17 | %left INFIXOP2 18 | %left INFIXOP3 19 | %right INFIXOP4 20 | 21 | %start theory 22 | %type theory 23 | 24 | %% 25 | 26 | theory: n = option(theory_name) lst = list(terminated(theory_entry, DOT)) EOF 27 | { {Input.th_name = n; Input.th_entries = lst} } 28 | 29 | theory_name: 30 | | THEORY n = IDENT DOT 31 | { n } 32 | 33 | theory_entry: mark_position(_theory_entry) { $1 } 34 | _theory_entry: 35 | | CONSTANT lst = nonempty_list(name) 36 | { Input.Constant lst } 37 | | UNARY lst = nonempty_list(name_or_prefix) 38 | { Input.Unary lst } 39 | | BINARY lst = nonempty_list(name_or_op) 40 | { Input.Binary lst } 41 | | PREDICATE lst = nonempty_list(name_or_prefix) 42 | { Input.Predicate lst } 43 | | RELATION lst = nonempty_list(name_or_op) 44 | { Input.Relation lst } 45 | | AXIOM n = option(IDENT) COLON a = formula 46 | { Input.Axiom (n, a) } 47 | | THEOREM n = option(IDENT) COLON a = formula 48 | { Input.Axiom (n, a) } 49 | 50 | name: 51 | | x = IDENT { x } 52 | 53 | name_or_prefix: 54 | | n = name 55 | { n } 56 | | op = PREFIXOP 57 | { op } 58 | 59 | name_or_op: 60 | | n = name 61 | { n } 62 | | op = binop 63 | { op } 64 | 65 | %inline binop: 66 | | op = INFIXOP0 67 | { op } 68 | | op = INFIXOP1 69 | { op } 70 | | op = INFIXOP2 71 | { op } 72 | | op = INFIXOP3 73 | { op } 74 | | op = INFIXOP4 75 | { op } 76 | 77 | formula: mark_position(_formula) { $1 } 78 | _formula: 79 | | f = _quantified_formula 80 | { f } 81 | | f = _iff_formula 82 | { f } 83 | | f = _imply_formula 84 | { f } 85 | 86 | formula_noquant: mark_position(_formula_noquant) { $1 } 87 | _formula_noquant: 88 | | f = _quantified_formula 89 | { f } 90 | | f = _imply_formula 91 | { f } 92 | | f = _iff_formula_noquant 93 | { f } 94 | 95 | quantified_formula: mark_position(_quantified_formula) { $1 } 96 | _quantified_formula: 97 | | FORALL xs = vars COMMA f = formula_noquant 98 | { Input.Forall (xs, f) } 99 | | EXISTS xs = vars COMMA f = formula_noquant 100 | { Input.Exists (xs, f) } 101 | 102 | (* iff_formula_noquant: mark_position(_iff_formula_noquant) { $1 } *) 103 | _iff_formula_noquant: 104 | | f1 = or_formula_noquant IFF f2 = or_formula_noquant 105 | { Input.Iff (f1, f2) } 106 | 107 | (* iff_formula: mark_position(_iff_formula) { $1 } *) 108 | _iff_formula: 109 | | f1 = or_formula_noquant IFF f2 = or_formula 110 | { Input.Iff (f1, f2) } 111 | 112 | (* imply_formula: mark_position(_imply_formula) { $1 } *) 113 | _imply_formula: 114 | | f1 = or_formula_noquant IMPLY f2 = formula 115 | { Input.Imply (f1, f2) } 116 | | f = _or_formula 117 | { f } 118 | 119 | or_formula: mark_position(_or_formula) { $1 } 120 | _or_formula: 121 | | f1 = or_formula_noquant OR f2 = and_formula 122 | { Input.Or (f1, f2) } 123 | | f1 = or_formula_noquant OR f2 = quantified_formula 124 | { Input.Or (f1, f2) } 125 | | f = _and_formula 126 | { f } 127 | 128 | or_formula_noquant: mark_position(_or_formula_noquant) { $1 } 129 | _or_formula_noquant: 130 | | f1 = or_formula_noquant OR f2 = and_formula_noquant 131 | { Input.Or (f1, f2) } 132 | | f = _and_formula_noquant 133 | { f } 134 | 135 | and_formula: mark_position(_and_formula) { $1 } 136 | _and_formula: 137 | | f1 = and_formula_noquant AND f2 = negation_formula 138 | { Input.And (f1, f2) } 139 | | f1 = and_formula_noquant AND f2 = quantified_formula 140 | { Input.And (f1, f2) } 141 | | f = _negation_formula 142 | { f } 143 | 144 | and_formula_noquant: mark_position(_and_formula_noquant) { $1 } 145 | _and_formula_noquant: 146 | | f1 = and_formula_noquant AND f2 = negation_formula_noquant 147 | { Input.And (f1, f2) } 148 | | f = _negation_formula_noquant 149 | { f } 150 | 151 | negation_formula: mark_position(_negation_formula) { $1 } 152 | _negation_formula: 153 | | NOT f = negation_formula 154 | { Input.Not f } 155 | | NOT f = quantified_formula 156 | { Input.Not f } 157 | | f = _atomic_formula 158 | { f } 159 | 160 | negation_formula_noquant: mark_position(_negation_formula_noquant) { $1 } 161 | _negation_formula_noquant: 162 | | NOT f = negation_formula_noquant 163 | { Input.Not f } 164 | | f = _atomic_formula 165 | { f } 166 | 167 | (* atomic_formula: mark_position(_atomic_formula) { $1 } *) 168 | _atomic_formula: 169 | | TRUE 170 | { Input.True } 171 | | FALSE 172 | { Input.False } 173 | | t1 = term EQUAL t2 = term 174 | { Input.Equal (t1, t2) } 175 | | t1 = term NOTEQUAL t2 = term 176 | { Input.NotEqual (t1, t2) } 177 | | f = _predicate 178 | { f } 179 | | f = _relation 180 | { f } 181 | 182 | (* predicate: mark_position(_predicate) { $1 } *) 183 | _predicate: 184 | | op = PREFIXOP t = simple_term 185 | { Input.UnaryPr (op, t) } 186 | | op = name t = simple_term 187 | { Input.UnaryPr (op, t) } 188 | 189 | (* relation: mark_position(_relation) { $1 } *) 190 | _relation: 191 | | t1 = term op = binop t2 = term 192 | { Input.BinaryPr (op, t1, t2) } 193 | | op = name LPAREN t1 = term COMMA t2 = term RPAREN 194 | { Input.BinaryPr (op, t1, t2) } 195 | 196 | term: mark_position(_term) { $1 } 197 | _term: 198 | | t1 = term op = binop t2 = term 199 | { Input.BinaryOp (op, t1, t2) } 200 | | op = PREFIXOP t = app_term 201 | { Input.UnaryOp (op, t) } 202 | | t = _app_term 203 | { t } 204 | 205 | app_term: mark_position(_app_term) { $1 } 206 | _app_term: 207 | | op = name t = simple_term 208 | { Input.UnaryOp (op, t) } 209 | | op = name LPAREN t1 = term COMMA t2 = term RPAREN 210 | { Input.BinaryOp (op, t1, t2) } 211 | | t = _simple_term 212 | { t } 213 | 214 | simple_term: mark_position(_simple_term) { $1 } 215 | _simple_term: 216 | | x = name 217 | { Input.Var x } 218 | | LPAREN t = _term RPAREN 219 | { t } 220 | 221 | vars: 222 | | vs = nonempty_list(name) 223 | { vs } 224 | 225 | mark_position(X): 226 | x = X 227 | { x, Common.Position ($startpos, $endpos) } 228 | 229 | %% 230 | -------------------------------------------------------------------------------- /src/print.ml: -------------------------------------------------------------------------------- 1 | (** Pretty-printing of expressions with the Ocaml [Format] library. *) 2 | 3 | (** Print an expression, possibly placing parentheses around it. We always 4 | print things at a given "level" [at_level]. If the level exceeds the 5 | maximum allowed level [max_level] then the expression should be parenthesized. 6 | 7 | Let us consider an example. When printing a left-associative operation, we should print [Op 8 | (Op (e1, e2), e3)] as ["e1 * e2 * e3"] and [Op(e1, Op(e2, e3))] as ["e1 * (e2 * e3)"]. So 9 | if we assign level 1 to applications, then during printing of [Op (e1, e2)] we should 10 | print [e1] at [max_level] 1 and [e2] at [max_level] 0. 11 | *) 12 | let print ?(max_level=9999) ?(at_level=0) ppf = 13 | if max_level < at_level then 14 | begin 15 | Format.fprintf ppf "(@[" ; 16 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@])") ppf 17 | end 18 | else 19 | begin 20 | Format.fprintf ppf "@[" ; 21 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@]") ppf 22 | end 23 | 24 | (** Print the given source code position. *) 25 | let print_position loc ppf = 26 | match loc with 27 | | Common.Nowhere -> 28 | Format.fprintf ppf "unknown position" 29 | | Common.Position (begin_pos, end_pos) -> 30 | let begin_char = begin_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 31 | let end_char = end_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 32 | let begin_line = begin_pos.Lexing.pos_lnum in 33 | let filename = begin_pos.Lexing.pos_fname in 34 | 35 | if String.length filename != 0 then 36 | Format.fprintf ppf "file %S, line %d, charaters %d-%d" 37 | filename (begin_line+1) begin_char end_char 38 | else 39 | Format.fprintf ppf "line %d, characters %d-%d" (begin_line-1) begin_char end_char 40 | 41 | (** Print a sequence of things with the given (optional) separator. *) 42 | let print_sequence ?(sep="") f lst ppf = 43 | let rec seq = function 44 | | [] -> print ppf "" 45 | | [x] -> print ppf "%t" (f x) 46 | | x :: xs -> print ppf "%t%s@ " (f x) sep ; seq xs 47 | in 48 | seq lst 49 | 50 | (** Support for printing of errors at various levels of verbosity. *) 51 | 52 | let verbosity = ref 2 53 | 54 | (** Print a message at a given location [loc] of message type [msg_type] and 55 | verbosity level [v]. *) 56 | let print_message ?(loc=Common.Nowhere) msg_type v = 57 | if v <= !verbosity then 58 | begin 59 | match loc with 60 | | Common.Nowhere -> 61 | Format.eprintf "%s:@\n@[" msg_type ; 62 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@]@.") Format.err_formatter 63 | | Common.Position _ -> 64 | Format.eprintf "%s at %t:@\n@[" msg_type (print_position loc) ; 65 | Format.kfprintf (fun ppf -> Format.fprintf ppf "@]@.") Format.err_formatter 66 | end 67 | else 68 | Format.ifprintf Format.err_formatter 69 | 70 | 71 | (** Print an error. *) 72 | let error (loc, err_type, msg) = print_message ~loc err_type 1 "%s" msg 73 | -------------------------------------------------------------------------------- /src/sat.ml: -------------------------------------------------------------------------------- 1 | (* An alternative algorithm for generation of algebras that uses the following 2 | strategy. 3 | 4 | Given a partially created algebra, i.e., with some -1's in some places, we 5 | check axioms. Checking an axiom may lead to one of the following results: 6 | 7 | - an axiom is invalid, in which case we must backtrack 8 | 9 | - an axiom is valid, we continue 10 | 11 | - an axiom can be made valid in one of several ways, in which 12 | case we branch on them. 13 | *) 14 | 15 | open Theory 16 | open Algebra 17 | 18 | type partial_term = 19 | | TValue of int 20 | | TPartial of term * (int * int) 21 | 22 | type partial_formula = 23 | | FValue of bool 24 | | FPartial of formula' * (int * int) 25 | 26 | let print_conjuncts cs = 27 | Printf.printf "conjuncts (%d):\n%s\n" 28 | (List.length cs) 29 | (String.concat "\n" (List.map (fun (f, (k1,k2)) -> 30 | string_of_int k1 ^ "," ^ string_of_int k2 ^ " ... " ^ string_of_formula' f) cs)) 31 | 32 | let and_of n i f = 33 | let rec loop k a = 34 | if k = n 35 | then a 36 | else loop (k+1) (And (subst_formula i (Elem k) f, a)) 37 | in 38 | if n = 0 then True else loop 1 (subst_formula i (Elem 0) f) 39 | 40 | let or_of n i f = 41 | let rec loop k a = 42 | if k = n 43 | then a 44 | else loop (k+1) (Or (subst_formula i (Elem k) f, a)) 45 | in 46 | if n = 0 then True else loop 1 (subst_formula i (Elem 0) f) 47 | 48 | (* We measure complexity of a formula by a pair (k,m) where k is the 49 | number of unary undefined operations and m the number of binary 50 | undefined operations. *) 51 | let compare_complexity (k1,m1) (k2,m2) = 52 | if k1 = k2 && m1 = m2 then 0 53 | else if k1 + m1 <= 1 then -1 54 | else if k2 + m2 <= 1 then 1 55 | else (k1 + 3 * m1) - (k2 + 3 * m2) 56 | 57 | (* Generate all algebras for theory [th] of size [n]. Pass each one to the 58 | continuation [k]. You may optionally pass in a partially constructed algebra, 59 | and the algorithm will fill in the rest. *) 60 | let generate ?start n ({th_const=const; th_equations=eqs; th_axioms=axs} as th) k = 61 | if n >= Array.length const then 62 | let a = (match start with None -> Algebra.empty n th | Some a -> a) in 63 | let const = a.alg_const in 64 | let unary = a.alg_unary in 65 | let binary = a.alg_binary in 66 | let pred = a.alg_predicates in 67 | let rel = a.alg_relations in 68 | 69 | (* Partial evlauation of a term. It returns the partially evaluated term together 70 | with a count of how many table entries need to be filled in for the term to 71 | become completely evaluated. *) 72 | let rec eval_term = function 73 | | Var i -> Error.internal_error "eval_term: variable encountered" 74 | | Elem e -> TValue e 75 | | Const i -> TValue const.(i) (* NB: We assume constants are always defined. *) 76 | | Unary (op, t) -> 77 | begin match eval_term t with 78 | | TValue v -> 79 | if unary.(op).(v) = -1 80 | then TPartial (Unary(op, Elem v), (1,0)) 81 | else TValue unary.(op).(v) 82 | | TPartial (t, (k,m)) -> TPartial (Unary (op, t), (k+1,m)) 83 | end 84 | | Binary (op, t1, t2) -> 85 | begin match eval_term t1, eval_term t2 with 86 | | TValue v1, TValue v2 -> 87 | let u = binary.(op).(v1).(v2) in 88 | if u = -1 89 | then TPartial (Binary (op, Elem v1, Elem v2), (0,1)) 90 | else TValue u 91 | | TValue v1, TPartial (t2,(k2,m2)) -> TPartial (Binary (op, Elem v1, t2), (k2,m2+1)) 92 | | TPartial (t1,(k1,m1)), TValue v2 -> TPartial (Binary (op, t1, Elem v2), (k1,m1+1)) 93 | | TPartial (t1,(k1,m1)), TPartial (t2,(k2,m2)) -> TPartial (Binary (op, t1, t2), (k1+k2, m1+m2+1)) 94 | end 95 | in 96 | 97 | let rec eval_formula = function 98 | | True -> FValue true 99 | | False -> FValue false 100 | | Predicate (p, t) -> 101 | begin match eval_term t with 102 | | TValue v -> 103 | let u = pred.(p).(v) in 104 | if u = -1 105 | then FPartial (Predicate (p, Elem v), (1,0)) 106 | else FValue (u = 1) 107 | | TPartial (t, (k,m)) -> FPartial (Predicate (p, t), (k+1,m)) 108 | end 109 | | Relation (r, t1, t2) -> 110 | begin match eval_term t1, eval_term t2 with 111 | | TValue v1, TValue v2 -> 112 | let u = rel.(r).(v1).(v2) in 113 | if u = -1 114 | then FPartial (Relation (r, Elem v1, Elem v2), (0,1)) 115 | else FValue (u = 1) 116 | | TValue v1, TPartial (t2,(k2,m2)) -> FPartial (Relation (r, Elem v1, t2), (k2,m2+1)) 117 | | TPartial (t1,(k1,m1)), TValue v2 -> FPartial (Relation (r, t1, Elem v2), (k1,m1+1)) 118 | | TPartial (t1,(k1,m1)), TPartial (t2,(k2,m2)) -> FPartial (Relation (r, t1, t2), (k1+k2,m1+m2+1)) 119 | end 120 | | Equal (t1, t2) -> 121 | begin match eval_term t1, eval_term t2 with 122 | | TValue v1, TValue v2 -> FValue (v1 = v2) 123 | | TValue v1, TPartial (t2,(k2,m2)) -> FPartial (Equal (Elem v1, t2), (k2,m2)) 124 | | TPartial (t1,(k1,m1)), TValue v2 -> FPartial (Equal (Elem v2, t1), (k1,m1)) 125 | | TPartial (t1,(k1,m1)), TPartial (t2,(k2,m2)) -> 126 | if t1 = t2 then FValue true 127 | else if compare_complexity (k1,m1) (k2,m2) <= 0 128 | then FPartial (Equal(t1, t2), (k1+k2,m1+m2)) 129 | else FPartial (Equal(t2, t1), (k1+k2,m1+m2)) 130 | end 131 | | Not f -> 132 | begin match eval_formula f with 133 | | FValue b -> FValue (not b) 134 | | FPartial (f, (k,m)) -> FPartial (Not f, (k,m)) 135 | end 136 | | And (f1, f2) -> 137 | begin match eval_formula f1 with 138 | | FValue true -> eval_formula f2 139 | | FValue false -> FValue false 140 | | FPartial (f1,(k1,m1)) -> 141 | begin match eval_formula f2 with 142 | | FValue true -> FPartial (f1,(k1,m1)) 143 | | FValue false -> FValue false 144 | | FPartial (f2,(k2,m2)) -> 145 | if f1 = f2 then FPartial (f1, (k1, m1)) 146 | else if compare_complexity (k1,m1) (k2,m2) <= 0 147 | then FPartial (And (f1,f2), (k1+k2,m1+m2)) 148 | else FPartial (And (f2,f1), (k1+k2,m1+m2)) 149 | end 150 | end 151 | | Or (f1, f2) -> 152 | begin match eval_formula f1 with 153 | | FValue false -> eval_formula f2 154 | | FValue true -> FValue true 155 | | FPartial (f1,(k1,m1)) -> 156 | begin match eval_formula f2 with 157 | | FValue false -> FPartial (f1,(k1,m1)) 158 | | FValue true -> FValue true 159 | | FPartial (f2,(k2,m2)) -> 160 | if f1 = f2 then FPartial (f1, (k1, m1)) 161 | else if compare_complexity (k1,m1) (k2,m2) <= 0 162 | then FPartial (Or (f1,f2), (k1+k2,m1+m2)) 163 | else FPartial (Or (f2,f1), (k1+k2,m1+m2)) 164 | end 165 | end 166 | | Imply (f1, f2) -> 167 | begin match eval_formula f1 with 168 | | FValue true -> eval_formula f2 169 | | FValue false -> FValue true 170 | | FPartial (f1,(k1,m1)) -> 171 | begin match eval_formula f2 with 172 | | FValue false -> FPartial (Not f1,(k1,m1)) 173 | | FValue true -> FValue true 174 | | FPartial (f2,(k2,m2)) -> 175 | if f1 = f2 then FValue true 176 | else FPartial (Imply (f1, f2), (k1+k2,m1+m2)) 177 | end 178 | end 179 | | Iff (f1, f2) -> 180 | begin match eval_formula f1 with 181 | | FValue true -> eval_formula f2 182 | | FValue false -> eval_formula (Not f2) 183 | | FPartial (f1,(k1,m1)) -> 184 | begin match eval_formula f2 with 185 | | FValue false -> FPartial (Not f1, (k1,m1)) 186 | | FValue true -> FPartial (f1, (k1,m1)) 187 | | FPartial (f2,(k2,m2)) -> 188 | if f1 = f2 then FValue true 189 | else if compare_complexity (k1,m1) (k2,m2) <= 0 190 | then FPartial (Iff (f1, f2), (k1+k2,m1+m2)) 191 | else FPartial (Iff (f2, f1), (k1+k2,m1+m2)) 192 | end 193 | end 194 | | Forall _ -> Error.internal_error "eval_formula: forall encountered" 195 | | Exists _ -> Error.internal_error "eval_formula: exists encountered" 196 | in 197 | 198 | (* Force [t] to have value [v]. Pass the results, if any, to continuation [k]. *) 199 | let rec force_term t v k = 200 | match t with 201 | | Var i -> Error.internal_error "force_term: variable encountered" 202 | | Elem e -> if v = -1 || e = v then k e 203 | | Const i -> 204 | if v = -1 then k (const.(i)) 205 | else if const.(i) = v then k v 206 | | Unary (op, t) -> 207 | force_term t (-1) 208 | (fun w -> 209 | if v = -1 then begin 210 | if unary.(op).(w) <> -1 211 | then k (unary.(op).(w)) 212 | else begin 213 | for u = 0 to n-1 do 214 | unary.(op).(w) <- u ; 215 | k u 216 | done ; 217 | unary.(op).(w) <- -1 218 | end 219 | end 220 | else begin 221 | if unary.(op).(w) = v then k v 222 | else if unary.(op).(w) = -1 223 | then begin 224 | unary.(op).(w) <- v; 225 | k v ; 226 | unary.(op).(w) <- -1 227 | end 228 | end) 229 | | Binary (op, t1, t2) -> 230 | force_term t1 (-1) 231 | (fun w1 -> force_term t2 (-1) 232 | (fun w2 -> 233 | if v = -1 then begin 234 | if binary.(op).(w1).(w2) <> -1 235 | then k (binary.(op).(w1).(w2)) 236 | else begin 237 | for u = 0 to n-1 do 238 | binary.(op).(w1).(w2) <- u ; 239 | k u 240 | done ; 241 | binary.(op).(w1).(w2) <- -1 242 | end 243 | end 244 | else begin 245 | if binary.(op).(w1).(w2) = v then k v 246 | else if binary.(op).(w1).(w2) = -1 247 | then begin 248 | binary.(op).(w1).(w2) <- v; 249 | k v ; 250 | binary.(op).(w1).(w2) <- -1 251 | end 252 | end)) 253 | in 254 | 255 | (* When forcing a formula we never have to consider forcing to an unknown truth value 256 | because that would mean we could have just skipped the formula in the first place. 257 | Consequently, [force_formula] need not pass any values to the continuation. 258 | *) 259 | let rec force_formula f b k = 260 | match f with 261 | | True -> if b = 1 then k () 262 | | False -> if b = 0 then k () 263 | | Predicate (p, t) -> 264 | force_term t (-1) 265 | (fun v -> 266 | if pred.(p).(v) = -1 267 | then begin 268 | pred.(p).(v) <- b ; 269 | k () ; 270 | pred.(p).(v) <- -1 271 | end 272 | else if pred.(p).(v) = b then k ()) 273 | | Relation (r, t1, t2) -> 274 | force_term t1 (-1) 275 | (fun v1 -> force_term t2 (-1) 276 | (fun v2 -> 277 | if rel.(r).(v1).(v2) = -1 278 | then begin 279 | rel.(r).(v1).(v2) <- b ; 280 | k () ; 281 | rel.(r).(v1).(v2) <- -1 282 | end 283 | else if rel.(r).(v1).(v2) = b then k ())) 284 | | Equal (t1, t2) -> 285 | begin match eval_term t1, eval_term t2 with 286 | | TValue v1, TValue v2 -> if v1 = v2 then k () 287 | | TValue v1, TPartial (t2,_) -> force_term t2 v1 (fun _ -> k ()) 288 | | TPartial (t2,_), TValue v2 -> force_term t1 v2 (fun _ -> k ()) 289 | | TPartial (t1,_), TPartial (t2,_) -> 290 | force_term t1 (-1) 291 | (fun v -> 292 | if b = 1 293 | then force_term t2 v (fun _ -> k ()) 294 | else begin 295 | for w = 0 to n-1 do 296 | if w <> v then force_term t2 w (fun _ -> k ()) 297 | done 298 | end) 299 | end 300 | | Not f -> force_formula f (1-b) k 301 | | And (f1, f2) -> 302 | if b = 1 then 303 | force_formula f1 1 (fun () -> force_formula f2 1 k) 304 | else begin 305 | force_formula f1 0 k ; 306 | force_formula f1 1 (fun () -> force_formula f2 0 k) 307 | end 308 | | Or (f1, f2) -> 309 | if b = 0 then 310 | force_formula f1 0 (fun () -> force_formula f2 0 k) 311 | else begin 312 | force_formula f1 1 k ; 313 | force_formula f1 0 (fun () -> force_formula f2 1 k) 314 | end 315 | | Imply (f1, f2) -> 316 | if b = 0 then 317 | force_formula f1 1 (fun () -> force_formula f2 0 k) 318 | else begin 319 | force_formula f1 0 k ; 320 | force_formula f1 1 (fun () -> force_formula f2 1 k) 321 | end 322 | | Iff (f1, f2) -> 323 | if b = 0 then begin 324 | force_formula f1 0 (fun () -> force_formula f2 1 k) ; 325 | force_formula f1 1 (fun () -> force_formula f2 0 k) 326 | end 327 | else begin 328 | force_formula f1 0 (fun () -> force_formula f2 0 k) ; 329 | force_formula f1 1 (fun () -> force_formula f2 1 k) 330 | end 331 | | Forall _ -> Error.internal_error "force_formula: forall encountered" 332 | | Exists _ -> Error.internal_error "force_formula: exists encountered" 333 | in 334 | 335 | let rec fill_relation k = 336 | let rec g r = 337 | if r >= Array.length rel then k () 338 | else begin 339 | let rec f (i,j) = 340 | if i >= n then g (r+1) 341 | else if rel.(r).(i).(j) = -1 342 | then begin 343 | for b = 0 to 1 do 344 | rel.(r).(i).(j) <- b ; 345 | f (if j = n-1 then (i+1,0) else (i,j+1)) 346 | done ; 347 | rel.(r).(i).(j) <- -1 348 | end 349 | else f (if j = n-1 then (i+1,0) else (i,j+1)) 350 | in 351 | f (0, 0) 352 | end 353 | in 354 | g 0 355 | in 356 | 357 | let rec fill_predicate k = 358 | let rec g p = 359 | if p >= Array.length pred then k () 360 | else begin 361 | let rec f i = 362 | if i >= n then g (p+1) 363 | else if pred.(p).(i) = -1 364 | then begin 365 | for b = 0 to 1 do 366 | pred.(p).(i) <- b ; 367 | f (i + 1) 368 | done ; 369 | pred.(p).(i) <- -1 370 | end 371 | else f (i + 1) 372 | in 373 | f 0 374 | end 375 | in 376 | g 0 377 | in 378 | 379 | let rec fill_binary k = 380 | let rec g op = 381 | if op >= Array.length binary then k () 382 | else begin 383 | let rec f (i,j) = 384 | if i >= n then g (op+1) 385 | else if binary.(op).(i).(j) = -1 386 | then begin 387 | for v = 0 to n-1 do 388 | binary.(op).(i).(j) <- v ; 389 | f (if j = n-1 then (i+1,0) else (i,j+1)) 390 | done ; 391 | binary.(op).(i).(j) <- -1 392 | end 393 | else f (if j = n-1 then (i+1,0) else (i,j+1)) 394 | in 395 | f (0,0) 396 | end 397 | in 398 | g 0 399 | in 400 | 401 | let rec fill_unary k = 402 | let rec g op = 403 | if op >= Array.length unary then k () 404 | else begin 405 | let rec f i = 406 | if i >= n then 407 | begin 408 | g (op+1) 409 | end 410 | else if unary.(op).(i) = -1 411 | then begin 412 | for v = 0 to n-1 do 413 | unary.(op).(i) <- v ; 414 | f (i + 1) 415 | done ; 416 | unary.(op).(i) <- -1 417 | end 418 | else f (i + 1) 419 | in 420 | f 0 421 | end 422 | in 423 | g 0 424 | in 425 | 426 | let rec prepare_formula = function 427 | | (True | False | Equal _ | Predicate _ | Relation _) as f -> f 428 | | Forall (i, f) -> prepare_formula (and_of n i f) 429 | | Exists (i, f) -> prepare_formula (or_of n i f) 430 | | Not f -> Not (prepare_formula f) 431 | | And (f1, f2) -> And (prepare_formula f1, prepare_formula f2) 432 | | Or (f1, f2) -> Or (prepare_formula f1, prepare_formula f2) 433 | | Imply (f1, f2) -> Imply (prepare_formula f1, prepare_formula f2) 434 | | Iff (f1, f2) -> Iff (prepare_formula f1, prepare_formula f2) 435 | in 436 | 437 | let prepare_equation (i, (t1, t2)) = 438 | prepare_formula 439 | (List.fold_right (fun x g -> Forall (x, g)) (Util.enumFromTo 0 (i-1)) (Equal (t1, t2))) 440 | in 441 | 442 | let prepare_axioms eqs axs = 443 | let rec conjuncts acc = function 444 | | True -> acc 445 | | And (f1, f2) -> conjuncts (conjuncts acc f1) f2 446 | | f -> f :: acc 447 | in 448 | let rec eval_conjuncts acc = function 449 | | [] -> acc 450 | | f :: fs -> 451 | begin match eval_formula f with 452 | | FValue false -> [(False,(0,0))] 453 | | FValue true -> eval_conjuncts acc fs 454 | | FPartial (f,km) -> eval_conjuncts ((f,km)::acc) fs 455 | end 456 | in 457 | List.sort (fun (_,c1) (_,c2) -> compare_complexity c1 c2) 458 | (eval_conjuncts [] 459 | (List.fold_left (fun cs (_,f) -> conjuncts cs (prepare_formula f)) 460 | (List.fold_left (fun cs e -> conjuncts cs (prepare_equation e)) [] eqs) axs)) 461 | in 462 | 463 | let simplify_conjuncts cs = 464 | let rec loop acc = function 465 | | [] -> acc 466 | | (c,_) :: cs -> 467 | begin match eval_formula c with 468 | | FValue true -> loop acc cs 469 | | FValue false -> [(False,(0,0))] 470 | | FPartial (f,km) -> loop ((f,km)::acc) cs 471 | end 472 | in 473 | List.sort (fun (_,c1) (_,c2) -> compare_complexity c1 c2) (loop [] cs) 474 | in 475 | 476 | let rec force_conjuncts cs k = 477 | let cs = 478 | (match cs with 479 | | [] -> [] 480 | | (_,(k,m)) :: _ -> 481 | if k+m <= 1 482 | then cs 483 | else simplify_conjuncts cs) 484 | in 485 | match cs with 486 | | [] -> k () 487 | | (f,_) :: cs -> force_formula f 1 (fun () -> force_conjuncts cs k) 488 | in 489 | 490 | (* Body of the main function *) 491 | if n <> a.alg_size then Error.internal_error "Sat.generate: size mismatch." 492 | else if n >= Array.length const then begin 493 | (* Make sure constants are filled in. *) 494 | let used = Array.to_list const in 495 | let unused = ref (List.filter (fun k -> not (List.mem k used)) (Util.enumFromTo 0 (n-1))) in 496 | for i = 0 to Array.length const - 1 do 497 | if const.(i) = -1 then 498 | match !unused with 499 | | [] -> Error.internal_error "Sat.generate: ran out of elements for constants." 500 | | c::cs -> const.(i) <- c ; unused := cs 501 | done ; 502 | (* Prepare conjuncts *) 503 | let cs = prepare_axioms eqs axs in 504 | (* Force conjuncts to be true and fill in the rest. *) 505 | force_conjuncts cs 506 | (fun () -> fill_unary 507 | (fun () -> fill_binary 508 | (fun () -> fill_predicate 509 | (fun () -> fill_relation 510 | (fun () -> k a))))) 511 | end 512 | -------------------------------------------------------------------------------- /src/theory.ml: -------------------------------------------------------------------------------- 1 | (* Singatures, terms, equations and axioms. *) 2 | 3 | (* Variables and operations are represented as integers, but we also keep around 4 | the original operation names so that results can be printed. *) 5 | type operation = int 6 | type relation = int 7 | type operation_name = Input.operation 8 | type relation_name = Input.operation 9 | 10 | type variable = int 11 | 12 | (* A term *) 13 | type term = 14 | | Var of variable 15 | | Elem of int 16 | | Const of operation 17 | | Unary of operation * term 18 | | Binary of operation * term * term 19 | 20 | (* An equation. *) 21 | type equation' = term * term 22 | 23 | type equation = int * equation' 24 | 25 | (* A raw formula. *) 26 | type formula' = 27 | | True 28 | | False 29 | | Predicate of relation * term 30 | | Relation of relation * term * term 31 | | Equal of term * term 32 | | Forall of variable * formula' 33 | | Exists of variable * formula' 34 | | And of formula' * formula' 35 | | Or of formula' * formula' 36 | | Imply of formula' * formula' 37 | | Iff of formula' * formula' 38 | | Not of formula' 39 | 40 | (* A formula in a context. The context is an array which is large enough for evaluation 41 | of the formula. *) 42 | and formula = int array * formula' 43 | 44 | type theory = { 45 | th_name : string; 46 | th_const : operation_name array; 47 | th_unary : operation_name array; 48 | th_binary : operation_name array; 49 | th_predicates : relation_name array; 50 | th_relations : relation_name array; 51 | th_equations : equation list; 52 | th_axioms : formula list 53 | } 54 | 55 | (* Used to indicate that a permanent inconsistency has been discovered. *) 56 | exception InconsistentAxioms 57 | 58 | (* Substitution functions. Warning: they assume no shadowing will occur. *) 59 | let rec subst_term x t = function 60 | | Var y -> if x = y then t else Var y 61 | | Elem e -> Elem e 62 | | Const k -> Const k 63 | | Unary (f, s) -> Unary (f, subst_term x t s) 64 | | Binary (f, s1, s2) -> Binary (f, subst_term x t s1, subst_term x t s2) 65 | 66 | let rec subst_formula x t = function 67 | | True -> True 68 | | False -> False 69 | | Predicate (p, s) -> Predicate (p, subst_term x t s) 70 | | Relation (r, s1, s2) -> Relation (r, subst_term x t s1, subst_term x t s2) 71 | | Equal (s1, s2) -> Equal (subst_term x t s1, subst_term x t s2) 72 | | Not f -> Not (subst_formula x t f) 73 | | And (f1, f2) -> And (subst_formula x t f1, subst_formula x t f2) 74 | | Or (f1, f2) -> Or (subst_formula x t f1, subst_formula x t f2) 75 | | Imply (f1, f2) -> Imply (subst_formula x t f1, subst_formula x t f2) 76 | | Iff (f1, f2) -> Iff (subst_formula x t f1, subst_formula x t f2) 77 | | Forall (y, f) -> Forall (y, subst_formula x t f) 78 | | Exists (y, f) -> Exists (y, subst_formula x t f) 79 | 80 | (* Conversion to string, for debugging purposes. *) 81 | let embrace s = "(" ^ s ^ ")" 82 | 83 | let rec string_of_term = function 84 | | Var k -> "x" ^ string_of_int k 85 | | Elem e -> "e" ^ string_of_int e 86 | | Const k -> "c" ^ string_of_int k 87 | | Unary (f, t) -> "u" ^ string_of_int f ^ "(" ^ string_of_term t ^ ")" 88 | | Binary (f, t1, t2) -> "b" ^ string_of_int f ^ "(" ^ string_of_term t1 ^ ", " ^ string_of_term t2 ^ ")" 89 | 90 | let string_of_equation (t1, t2) = 91 | string_of_term t1 ^ " = " ^ string_of_term t2 92 | 93 | let rec string_of_formula' = function 94 | | True -> "True" 95 | | False -> "False" 96 | | Predicate (r, t) -> "p" ^ string_of_int r ^ " " ^ embrace (string_of_term t) 97 | | Relation (r, t1, t2) -> "r" ^ string_of_int r ^ " " ^ embrace (string_of_term t1 ^ ", " ^ string_of_term t2) 98 | | Equal (t1, t2) -> string_of_equation (t1, t2) 99 | | Not f -> "not " ^ embrace (string_of_formula' f) 100 | | And (f1, f2) -> embrace (string_of_formula' f1) ^ " /\\ " ^ embrace (string_of_formula' f2) 101 | | Or (f1, f2) -> embrace (string_of_formula' f1) ^ " \\/ " ^ embrace (string_of_formula' f2) 102 | | Imply (f1, f2) -> embrace (string_of_formula' f1) ^ " -> " ^ embrace (string_of_formula' f2) 103 | | Iff (f1, f2) -> embrace (string_of_formula' f1) ^ " <-> " ^ embrace (string_of_formula' f2) 104 | | Forall (x,f) -> "forall x" ^ string_of_int x ^ ", " ^ string_of_formula' f 105 | | Exists (x,f) -> "exists x" ^ string_of_int x ^ ", " ^ string_of_formula' f 106 | 107 | let string_of_formula (a, f) = string_of_int (Array.length a) ^ " |- " ^ string_of_formula' f 108 | 109 | let string_of_theory {th_name=name; 110 | th_const=const; 111 | th_unary=unary; 112 | th_binary=binary; 113 | th_predicates=predicates; 114 | th_relations=relations; 115 | th_equations=equations; 116 | th_axioms=axioms} = 117 | "Theory: " ^ name ^ "\n" ^ 118 | "Constant: " ^ String.concat " " (Array.to_list const) ^ "\n" ^ 119 | "Unary: " ^ String.concat " " (Array.to_list unary) ^ "\n" ^ 120 | "Binary: " ^ String.concat " " (Array.to_list binary) ^ "\n" ^ 121 | "Predicates: " ^ String.concat " " (Array.to_list predicates) ^ "\n" ^ 122 | "Relations: " ^ String.concat " " (Array.to_list relations) ^ "\n" ^ 123 | "Equations:\n" ^ String.concat "\n" (List.map (fun (_,e) -> string_of_equation e) equations) ^ "\n" ^ 124 | "Axioms:\n" ^ String.concat "\n" (List.map string_of_formula axioms) ^ "\n" 125 | -------------------------------------------------------------------------------- /src/util.ml: -------------------------------------------------------------------------------- 1 | open Theory 2 | open Algebra 3 | 4 | module IntMap = 5 | Map.Make(struct 6 | type t = int 7 | let compare = compare 8 | end) ;; 9 | 10 | (* Return the list of lines in the given file. *) 11 | let read_lines filename = 12 | let fh = open_in filename in 13 | let lines = ref [] in 14 | begin try 15 | while true do 16 | let line = input_line fh in 17 | lines := line :: !lines ; 18 | done 19 | with End_of_file -> close_in fh 20 | end ; 21 | List.rev !lines 22 | 23 | (* Return the filename extension or "" if there isn't one. *) 24 | let filename_extension filename = 25 | let fn = Filename.basename filename in 26 | try 27 | let k = String.rindex fn '.' in 28 | String.sub fn (k+1) (String.length fn - k - 1) 29 | with Not_found -> "" 30 | 31 | (* The number of characters an non-negative int takes to print out. *) 32 | let rec strlen = function 33 | | k when k < 10 -> 1 34 | | k -> 1 + strlen (k / 10) 35 | 36 | (* Return a duplicate element in the list, if one exists. *) 37 | let rec find_duplicate = function 38 | | [] -> None 39 | | x :: xs -> if List.mem x xs then Some x else find_duplicate xs 40 | 41 | (* Associative list lookup without exceptions. *) 42 | let lookup x lst = 43 | try 44 | Some (List.assoc x lst) 45 | with Not_found -> None 46 | 47 | (* A combination of map and filter *) 48 | let rec filter_map f = function 49 | | [] -> [] 50 | | x::xs -> 51 | begin match f x with 52 | | None -> filter_map f xs 53 | | Some y -> y :: filter_map f xs 54 | end 55 | 56 | (* Lists as sets. *) 57 | let rec union lst1 lst2 = 58 | match lst1, lst2 with 59 | | [], lst2 -> lst2 60 | | lst1, [] -> lst1 61 | | x::xs, ys -> 62 | if List.mem x ys 63 | then union xs ys 64 | else x :: union xs ys 65 | 66 | (* Lists as sets. *) 67 | let rec union lst1 lst2 = 68 | match lst1, lst2 with 69 | | [], lst2 -> lst2 70 | | lst1, [] -> lst1 71 | | x::xs, ys -> 72 | if List.mem x ys 73 | then union xs ys 74 | else x :: union xs ys 75 | 76 | let rec remove x = function 77 | | [] -> [] 78 | | y::ys -> 79 | if x = y then ys 80 | else y :: remove x ys 81 | 82 | let rec remove_many xs = function 83 | | [] -> [] 84 | | y :: ys -> 85 | if List.mem y xs then ys 86 | else y :: remove_many xs ys 87 | 88 | let intersect lst1 lst2 = 89 | List.fold_left (fun acc a -> if List.mem a lst2 then a::acc else acc) [] lst1 90 | 91 | (* Missing array functions. *) 92 | let array_for_all p a = 93 | let n = Array.length a in 94 | let rec check k = (k >= n) || (p a.(k) && check (k+1)) in 95 | check 0 96 | 97 | let matrix_for_all p a = 98 | array_for_all (fun r -> array_for_all p r) a 99 | 100 | let array_exists p a = 101 | let n = Array.length a in 102 | let rec check k = (k < n) && (p a.(k) || check (k+1)) in 103 | check 0 104 | 105 | let matrix_forall p a = 106 | array_exists (fun r -> array_exists p r) a 107 | 108 | let matrix_copy a = 109 | Array.init (Array.length a) (fun k -> Array.copy a.(k)) 110 | 111 | let array3d_copy a = 112 | Array.init (Array.length a) (fun k -> matrix_copy a.(k)) 113 | 114 | let array_map2 f a1 a2 = 115 | let n = Array.length a1 in 116 | if n <> Array.length a2 117 | then failwith "array_map2: invalid argument" 118 | else 119 | Array.init n (fun i -> f a1.(i) a2.(i)) 120 | 121 | let array_map2_list f a1 a2 = 122 | let n = Array.length a1 in 123 | if n <> Array.length a2 124 | then failwith "array_map2: invalid argument" 125 | else 126 | let lst = ref [] in 127 | for i = 0 to n-1 do 128 | lst := f a1.(i) a2.(i) :: !lst 129 | done ; 130 | List.rev !lst 131 | 132 | let rec array_iter2 f arr1 arr2 = 133 | for i = 0 to Array.length arr1 - 1 do 134 | f arr1.(i) arr2.(i) 135 | done 136 | 137 | (* Missing list functions. *) 138 | let enumFromTo s e = 139 | let rec loop = function 140 | | n when n <= e -> n :: loop (n+1) 141 | | _ -> [] 142 | in 143 | loop s 144 | 145 | (* Like List.map with indices. *) 146 | let map_enum f lst = 147 | let rec loop i = function 148 | | [] -> [] 149 | | x::xs -> (f i x) :: loop (i+1) xs 150 | in 151 | loop 0 lst 152 | 153 | (* Like List.iter with indices *) 154 | let iter_enum f lst = 155 | let rec loop i = function 156 | | [] -> () 157 | | x::xs -> (f i x) ; loop (i+1) xs 158 | in 159 | loop 0 lst 160 | 161 | let is_empty = function 162 | | [] -> true 163 | | _ -> false 164 | 165 | let is_sublist xs ys = 166 | List.for_all (fun x -> List.mem x ys) xs 167 | 168 | let rec replicate n a = 169 | if n = 0 then [] else a :: replicate (n-1) a 170 | 171 | let rev_combine xs ys = 172 | let rec rev_combine' acc xs ys = 173 | match (xs,ys) with 174 | | ([],_) | (_,[]) -> acc 175 | | (x::xs',y::ys') -> rev_combine' ((x,y) :: acc) xs' ys' 176 | in rev_combine' [] xs ys 177 | 178 | let rev_take n xs = 179 | let rec rev_take acc n = function 180 | | [] -> acc 181 | | (x::xs) when n = 0 -> acc 182 | | (x::xs) -> rev_take (x::acc) (n-1) xs in 183 | rev_take [] n xs 184 | 185 | let rec split x = function 186 | | [] -> ([],[]) 187 | | (y::ys) as ys' when y <> x -> ([], ys') 188 | | (y::ys) -> let (xs', ys') = split x ys 189 | in (y::xs', ys') 190 | 191 | let rec group = function 192 | | [] -> [] 193 | | (x::xs) -> let (xs', ys) = split x xs 194 | in (x, List.length xs') :: group ys 195 | 196 | let fromSome = function 197 | | (Some a) -> a 198 | | _ -> invalid_arg "fromSome called with None argument" 199 | 200 | (* 201 | Generating all ntuples. 202 | *) 203 | let exp_int a = function 204 | | b when b <= 0 -> 1 205 | | b -> 206 | let rec loop = function 207 | | n when n = 1 -> a 208 | | n when n mod 2 = 0 -> let t = loop (n / 2) in t * t 209 | | n -> let t = loop (n / 2) in t * t * a 210 | in loop b 211 | 212 | (* generate array of all n tuples with elements from 0..j-1 *) 213 | let ntuples j n = 214 | let arr = Array.make_matrix (exp_int j n) n 0 in 215 | let place = ref 0 in 216 | let rec loop = function 217 | | k when k = n -> place := !place + 1 218 | | k -> for i=0 to j-1 do 219 | begin 220 | let start = !place in 221 | begin 222 | loop (k+1) ; 223 | for j=start to !place-1 do 224 | arr.(j).(k) <- i 225 | done 226 | end 227 | end 228 | done in loop 0 ; arr 229 | 230 | let fac n = 231 | let r = ref 1 in 232 | for i=2 to n do 233 | r := !r * i 234 | done ; !r 235 | 236 | (* Make fresh copies of operation tables of a given algebra. *) 237 | let copy_algebra a = 238 | { a with 239 | alg_const = Array.copy a.alg_const; 240 | alg_unary = matrix_copy a.alg_unary; 241 | alg_binary = array3d_copy a.alg_binary; 242 | alg_predicates = matrix_copy a.alg_predicates; 243 | alg_relations = array3d_copy a.alg_relations 244 | } 245 | 246 | (* 247 | Make fresh copies of operation tables of a given algebra. 248 | Do not copy cache. 249 | *) 250 | let copy_algebra_with_cache (a,cache) = 251 | ({ a with 252 | alg_const = Array.copy a.alg_const; 253 | alg_unary = matrix_copy a.alg_unary; 254 | alg_binary = array3d_copy a.alg_binary; 255 | alg_predicates = matrix_copy a.alg_predicates; 256 | alg_relations = array3d_copy a.alg_relations 257 | }, cache) 258 | 259 | let alg_prod a1 a2 i1 i2 = 260 | match a1, a2, i1, i2 with 261 | | _, _, Some lst1, Some lst2 -> Some (lst1 @ lst2) 262 | | Some i1, _, None, Some lst2 -> Some (i1 :: lst2) 263 | | _, Some i2, Some lst1, None -> Some (lst1 @ [i2]) 264 | | Some i1, Some i2, None, None -> Some [i1; i2] 265 | | _, _, _, _ -> None 266 | 267 | let print_arr a = 268 | for i=0 to Array.length a - 1 do 269 | Printf.printf "%d " a.(i) 270 | done ; print_endline "" 271 | 272 | let print_matrix m = Array.iter print_arr m 273 | 274 | 275 | (* Auxiliary functions. *) 276 | 277 | (* Enumerate a list, return the number of elements and the enumerated list. *) 278 | let enum lst = List.fold_left (fun (k,lst) c -> (k+1, (c,k)::lst)) (0,[]) lst 279 | 280 | (* Invert assoc list. *) 281 | let invert xs = List.map (fun (a,b) -> (b,a)) xs 282 | 283 | (* Various foralls and exists *) 284 | 285 | (* Check function for all elements in range i - j *) 286 | let for_all f i j = 287 | let rec 288 | loop c = (c > j) || f c && loop (c + 1) 289 | in loop i 290 | 291 | (* Check function for all elements in range i - j and k - l *) 292 | let for_all2 f i j k l = for_all (fun x -> for_all (f x) k l) i j 293 | 294 | (* Dual to for_all *) 295 | let exists f i j = 296 | let rec loop c = (c <= j) && (f c || loop (c + 1)) 297 | in loop i 298 | 299 | (* Dual to for_all2 *) 300 | let exists2 f i j k l = exists (fun x -> exists (f x) k l) i j 301 | 302 | 303 | (* Equivalent to List.for_all f (List.combine xs ys) but works with arrays *) 304 | let for_all_pairs f xs ys = 305 | let n = Array.length xs in 306 | if n <> Array.length ys then 307 | failwith "for_all_pairs: invalid arguments" 308 | else 309 | let b = ref true in 310 | let i = ref 0 in 311 | while !b && !i < n do 312 | b := f xs.(!i) ys.(!i) ; 313 | incr i 314 | done ; 315 | ! b 316 | 317 | (* Divisors of a number without the number itself, sorted by size *) 318 | let divisors n = 319 | let rec loop k acc1 acc2 = 320 | if k * k > n then List.rev acc1 @ acc2 321 | else if k * k = n then List.rev acc1 @ (k :: acc2) 322 | else if n mod k = 0 then loop (k+1) (k :: acc1) ((n / k) :: acc2) 323 | else loop (k+1) acc1 acc2 324 | in 325 | loop 2 [] [] 326 | 327 | (* Small divisors of n larger than 1, i.e., those not exceeding the square root of n. *) 328 | let rec small_divisors n = 329 | let rec loop k = 330 | if k * k > n then [] 331 | else if n mod k = 0 then k :: loop (k+1) 332 | else loop (k+1) 333 | in 334 | loop 2 335 | 336 | (* Return all partitions of n into a product of at least two non-decreasing numbers. *) 337 | let partitions n = 338 | let rec part n = function 339 | | [] -> [] 340 | | (d::ds) as lst when n mod d = 0 && d * d <= n -> 341 | let m = n/d in ([d;m] :: (List.map (fun p -> d :: p) (part m lst))) @ (part n ds) 342 | | _::ds -> part n ds 343 | in 344 | part n (small_divisors n) 345 | 346 | let apply_to_snd f (_,t) = f t 347 | -------------------------------------------------------------------------------- /theories/antisymmetric_relation.th: -------------------------------------------------------------------------------- 1 | Relation R. 2 | Axiom: R(x,y) /\ R(y,x) -> x = y. -------------------------------------------------------------------------------- /theories/band.th: -------------------------------------------------------------------------------- 1 | Theory Band. 2 | Binary *. 3 | 4 | Axiom: x * (y * z) = (x * y) * z. 5 | Axiom: x * x = x. 6 | 7 | -------------------------------------------------------------------------------- /theories/bijection.th: -------------------------------------------------------------------------------- 1 | Unary f g. 2 | Axiom: f (g x) = x. 3 | Axiom: g (f x) = x. 4 | -------------------------------------------------------------------------------- /theories/binary_function.th: -------------------------------------------------------------------------------- 1 | Theory binary_function. 2 | Binary f. -------------------------------------------------------------------------------- /theories/bipartite_graph.th: -------------------------------------------------------------------------------- 1 | # Bipartatite graph with distinguished side (left). 2 | 3 | Theory BipartiteGraph. 4 | Predicate left. 5 | Relation --. 6 | 7 | Axiom irreflexive: not (x -- x). 8 | Axiom symmetric: x -- y -> y -- x. 9 | Axiom bipartite: x -- y -> not (left(x) <-> left(y)). -------------------------------------------------------------------------------- /theories/boolean_algebra.th: -------------------------------------------------------------------------------- 1 | # Boolean algebra 2 | Constant 0 1. 3 | Unary ~. 4 | Binary & |. 5 | 6 | 7 | # properties of meet 8 | Axiom: x & y = y & x. 9 | Axiom: x & (y & z) = (x & y) & z. 10 | Axiom: x & ~x = 0. 11 | Theorem: x & x = x. 12 | Theorem: x & 1 = x. 13 | 14 | # properties of join 15 | Axiom: x | y = y | x. 16 | Axiom: x | (y | z) = (x | y) | z. 17 | Axiom: x | ~x = 1. 18 | Theorem: x | x = x. 19 | Theorem: x | 0 = x. 20 | 21 | # absorption laws 22 | Axiom: x & (x | y) = x. 23 | Axiom: x | (x & y) = x. 24 | 25 | #distributivity 26 | Axiom: x & (y | z) = (x & y) | (x & z). 27 | #Theorem: (y | z) & x = (y & x) | (z & x). 28 | 29 | Axiom: x | (y & z) = (x | y) & (x | z). 30 | #Theorem: (y & z) | x = (y | x) & (z | x). 31 | 32 | 33 | Theorem involution: ~(~x) = x. 34 | 35 | Theorem DeMorgan1: ~(x | y) = ~x & ~y. 36 | Theorem DeMorgan2: ~(x & y) = ~x | ~y. 37 | 38 | -------------------------------------------------------------------------------- /theories/bounded_distributive_lattice.th: -------------------------------------------------------------------------------- 1 | # The theory of a bounded distributive lattice. 2 | 3 | Constant 0 1. 4 | Binary &. # meet 5 | Binary |. # join 6 | 7 | # properties of 0 and 1 8 | Axiom: 0 | x = x. 9 | Axiom: x | 0 = x. 10 | Theorem: x | 1 = 1. 11 | Theorem: 1 | x = 1. 12 | Axiom: 1 & x = x. 13 | Axiom: x & 1 = x. 14 | Theorem: 0 & x = 0. 15 | Theorem: x & 0 = 0. 16 | 17 | # properties of meet 18 | Axiom: x & x = x. 19 | Axiom: x & y = y & x. 20 | Axiom: x & (y & z) = (x & y) & z. 21 | 22 | # properties of join 23 | Axiom: x | x = x. 24 | Axiom: x | y = y | x. 25 | Axiom: x | (y | z) = (x | y) | z. 26 | 27 | # absorption laws 28 | Axiom: x & (x | y) = x. 29 | Axiom: x | (x & y) = x. 30 | 31 | # distributivity 32 | Axiom: x & (y | z) = (x & y) | (x & z). 33 | Axiom: x | (y & z) = (x | y) & (x | z). 34 | -------------------------------------------------------------------------------- /theories/bounded_lattice.th: -------------------------------------------------------------------------------- 1 | # The theory of a bounded lattice. 2 | 3 | Constant 0 1. 4 | Binary &. # meet 5 | Binary |. # join 6 | 7 | # properties of 0 and 1 8 | Axiom: 0 | x = x. 9 | Axiom: x | 0 = x. 10 | Theorem: x | 1 = 1. 11 | Theorem: 1 | x = 1. 12 | Axiom: 1 & x = x. 13 | Axiom: x & 1 = x. 14 | Theorem: 0 & x = 0. 15 | Theorem: x & 0 = 0. 16 | 17 | # properties of meet 18 | Axiom: x & x = x. 19 | Axiom: x & y = y & x. 20 | Axiom: x & (y & z) = (x & y) & z. 21 | 22 | # properties of join 23 | Axiom: x | x = x. 24 | Axiom: x | y = y | x. 25 | Axiom: x | (y | z) = (x | y) | z. 26 | 27 | # absorption laws 28 | Axiom: x & (x | y) = x. 29 | Axiom: x | (x & y) = x. 30 | -------------------------------------------------------------------------------- /theories/commutative_group.th: -------------------------------------------------------------------------------- 1 | Theory abelian_group. 2 | Constant 0. 3 | Unary ~. 4 | Binary +. 5 | 6 | Axiom: (x + y) + z = x + (y + z). 7 | Axiom: x + y = y + x. 8 | Axiom: 0 + x = x. 9 | Axiom: x + 0 = x. 10 | Axiom: x + ~ x = 0. 11 | Axiom: ~ x + x = 0. 12 | 13 | Theorem: ~ 0 = 0. 14 | Theorem: ~ (~ x) = x. 15 | -------------------------------------------------------------------------------- /theories/commutative_group_inefficient.th: -------------------------------------------------------------------------------- 1 | # An inefficient axiomatization of abelian groups in which the unit 2 | # and the inverse are postulated to exist. It would be more efficient 3 | # to introduce them as a constant and a unary operation. 4 | 5 | Binary *. 6 | 7 | Axiom: (x * y) * z = x * (y * z). 8 | Axiom: x * y = y * x. 9 | Axiom: exists e, forall x, x * e = x /\ (exists y, x * y = e). 10 | 11 | -------------------------------------------------------------------------------- /theories/commutative_group_via_division.th: -------------------------------------------------------------------------------- 1 | # Abelian group axiomatized by division and a single axiom. 2 | $ 3 | # Reference: 4 | # A. Tarski, Ein Beitrag zur Axiomatik der Abelschen Gruppen. 5 | # Fundamenta Mathematicae 30:253--256, 1938. 6 | 7 | Binary /. 8 | Axiom: (x / (y / (z / (x / y)))) = z. -------------------------------------------------------------------------------- /theories/commutative_quantale.th: -------------------------------------------------------------------------------- 1 | # The theory of a commutative quantale 2 | 3 | Constant 0 1. # bottom and top 4 | Binary & |. # meet and join 5 | Binary *. # multiplication 6 | 7 | ### Lattice structure 8 | 9 | # properties of 0 and 1 10 | Axiom: 0 | x = x. 11 | Axiom: x | 0 = x. 12 | Axiom: x | 1 = 1. 13 | Axiom: 1 | x = 1. 14 | Axiom: 1 & x = x. 15 | Axiom: x & 1 = x. 16 | Axiom: 0 & x = 0. 17 | Axiom: x & 0 = 0. 18 | 19 | # properties of meet 20 | Axiom: x & x = x. 21 | Axiom: x & y = y & x. 22 | Axiom: x & (y & z) = (x & y) & z. 23 | 24 | # properties of join 25 | Axiom: x | x = x. 26 | Axiom: x | y = y | x. 27 | Axiom: x | (y | z) = (x | y) | z. 28 | 29 | # absorption laws 30 | Axiom: x & (x | y) = x. 31 | Axiom: x | (x & y) = x. 32 | 33 | ### Multiplication 34 | 35 | Axiom: x * y = y * x. 36 | Axiom: x * (y * z) = (x * y) * z. 37 | Axiom: x * (y | z) = (x | y) * (x | z). 38 | Axiom: (y | z) * x = (y | x) * (z | x). 39 | -------------------------------------------------------------------------------- /theories/commutative_ring.th: -------------------------------------------------------------------------------- 1 | Constant 0. 2 | Unary ~. 3 | Binary + *. 4 | 5 | Axiom plus_commutative: x + y = y + x. 6 | Axiom plus_associative: (x + y) + z = x + (y + z). 7 | Axiom zero_neutral_left: 0 + x = x. 8 | Axiom zero_neutral_right: x + 0 = x. 9 | Axiom negative_inverse: x + ~ x = 0. 10 | Axiom negative_inverse: ~ x + x = 0. 11 | Axiom zero_inverse: ~ x = 0. 12 | Axiom inverse_involution: ~ (~ x) = x. 13 | 14 | Axiom mult_commutative: x * y = y * x. 15 | Axiom mult_associative: (x * y) * z = x * (y * z). 16 | Axiom distrutivity_right: (x + y) * z = x * z + y * z. 17 | Axiom distributivity_left: x * (y + z) = x * y + x * z. 18 | 19 | -------------------------------------------------------------------------------- /theories/commutative_semigroup.th: -------------------------------------------------------------------------------- 1 | # Semigroup 2 | Binary *. 3 | Axiom: x * (y * z) = (x * y) * z. 4 | Axiom: x * y = y * x. -------------------------------------------------------------------------------- /theories/commuting_functions.th: -------------------------------------------------------------------------------- 1 | # The theory of two commuting functions 2 | Unary f g. 3 | Equation: f(g(x)) = g(f(x)). -------------------------------------------------------------------------------- /theories/complete_graph.th: -------------------------------------------------------------------------------- 1 | Theory Graph. 2 | Relation -- . 3 | Axiom irreflexive: not (x -- x). 4 | Axiom symmety: x -- y -> y -- x. 5 | 6 | Axiom completeness: x != y -> x -- y. 7 | -------------------------------------------------------------------------------- /theories/cubic_graph.th: -------------------------------------------------------------------------------- 1 | Theory CubicGraph. 2 | Relation --. 3 | 4 | Axiom: not (x -- x). 5 | Axiom: x -- y -> y -- x. 6 | Axiom: forall x, exists a, x -- a /\ 7 | exists b, a <> b /\ x -- b /\ 8 | exists c, a <> c /\ b <> c /\ x -- c /\ 9 | forall d, x -- d -> a = d \/ b = d \/ c = d. -------------------------------------------------------------------------------- /theories/digraph.th: -------------------------------------------------------------------------------- 1 | Theory Directed_Graph. 2 | Relation -- . 3 | Axiom irreflexive: not (x -- x). 4 | -------------------------------------------------------------------------------- /theories/disjoint_cycles.th: -------------------------------------------------------------------------------- 1 | Theory DisjointCycles. 2 | 3 | Relation -- . 4 | Axiom irreflexive: not (x -- x). 5 | Axiom symmety: x -- y -> y -- x. 6 | 7 | Axiom degreetwo: forall x, exists y, x -- y /\ 8 | exists z, y <> z /\ x -- z /\ 9 | forall w, w -- x -> w = y \/ w = z. 10 | -------------------------------------------------------------------------------- /theories/division_ring.th: -------------------------------------------------------------------------------- 1 | # The axioms for a division ring (non-commutative field). 2 | 3 | Constant 0 1. 4 | Unary neg. 5 | Binary + *. 6 | 7 | Axiom plus_commutative: x + y = y + x. 8 | Axiom plus_associative: (x + y) + z = x + (y + z). 9 | Axiom zero_neutral_left: 0 + x = x. 10 | Axiom negative_inverse: x + neg(x) = 0. 11 | Axiom mult_associative: (x * y) * z = x * (y * z). 12 | Axiom one_unit_left: 1 * x = x. 13 | Axiom one_unit_right: x * 1 = x. 14 | Axiom distrutivity_right: (x + y) * z = x * z + y * z. 15 | Axiom distributivity_left: x * (y + z) = x * y + x * z. 16 | 17 | # Consequences of axioms that make alg run faster: 18 | 19 | Axiom zero_neutral_right: x + 0 = x. 20 | Axiom negative_inverse: neg(x) + x = 0. 21 | Axiom zero_inverse: neg(0) = 0. 22 | Axiom inverse_involution: neg(neg(x)) = x. 23 | Axiom mult_zero_left: 0 * x = 0. 24 | Axiom mult_zero_right: x * 0 = 0. 25 | 26 | # The field axiom. 27 | Axiom field: forall x, x <> 0 -> exists y, x * y = 1 /\ y * x = 1. 28 | 29 | -------------------------------------------------------------------------------- /theories/domain.th: -------------------------------------------------------------------------------- 1 | Constant 0 1. 2 | Unary neg. 3 | Binary + *. 4 | 5 | Axiom plus_commutative: x + y = y + x. 6 | Axiom plus_associative: (x + y) + z = x + (y + z). 7 | Axiom zero_neutral_left: 0 + x = x. 8 | Axiom zero_neutral_right: x + 0 = x. 9 | Axiom negative_inverse: x + neg(x) = 0. 10 | Axiom negative_inverse: neg(x) + x = 0. 11 | Axiom zero_inverse: neg(0) = 0. 12 | Axiom inverse_involution: neg(neg(x)) = x. 13 | 14 | Axiom mult_unit_left: 1 * x = x. 15 | Axiom mutl_unit_right: x * 1 = x. 16 | Axiom mult_associative: (x * y) * z = x * (y * z). 17 | Axiom distrutivity_right: (x + y) * z = x * z + y * z. 18 | Axiom distributivity_left: x * (y + z) = x * y + x * z. 19 | 20 | Axiom no_zero_divisors: x * y = 0 -> x = 0 \/ y = 0. -------------------------------------------------------------------------------- /theories/equivalence_relation.th: -------------------------------------------------------------------------------- 1 | # Equivalence relation 2 | 3 | Theory equivalence_relation. 4 | 5 | Relation ==. 6 | 7 | Axiom reflexive: x == x. 8 | Axiom symmetric: x == y => y == x. 9 | Axiom transitive: x == y /\ y==z => x == z. 10 | -------------------------------------------------------------------------------- /theories/equivalence_relation_euclid.th: -------------------------------------------------------------------------------- 1 | # Equivalence relation using euclidean axiom 2 | 3 | Theory equivalence_relation. 4 | 5 | Relation ==. 6 | 7 | Axiom reflexive: x == x. 8 | Axiom euclidean: x == y /\ x==z => y == z. 9 | -------------------------------------------------------------------------------- /theories/field.th: -------------------------------------------------------------------------------- 1 | # The axioms for a (possibly non-commutative) field. 2 | 3 | Constant 0 1. 4 | Unary neg. 5 | Binary + *. 6 | 7 | Axiom plus_commutative: x + y = y + x. 8 | Axiom plus_associative: (x + y) + z = x + (y + z). 9 | Axiom zero_neutral_left: 0 + x = x. 10 | Axiom negative_inverse: x + neg(x) = 0. 11 | Axiom mult_associative: (x * y) * z = x * (y * z). 12 | Axiom one_unit_left: 1 * x = x. 13 | Axiom one_unit_right: x * 1 = x. 14 | Axiom distrutivity_right: (x + y) * z = x * z + y * z. 15 | Axiom distributivity_left: x * (y + z) = x * y + x * z. 16 | Axiom mult_commutative: x * y = y * x. 17 | 18 | # Consequences of axioms that make alg run faster: 19 | 20 | Axiom zero_neutral_right: x + 0 = x. 21 | Axiom negative_inverse: neg(x) + x = 0. 22 | Axiom zero_inverse: neg(0) = 0. 23 | Axiom inverse_involution: neg(neg(x)) = x. 24 | Axiom mult_zero_left: 0 * x = 0. 25 | Axiom mult_zero_right: x * 0 = 0. 26 | 27 | # The field axiom. 28 | Axiom field: forall x, x <> 0 -> exists y, x * y = 1 /\ y * x = 1. 29 | 30 | -------------------------------------------------------------------------------- /theories/function.th: -------------------------------------------------------------------------------- 1 | # The theory of a function 2 | Unary f. 3 | -------------------------------------------------------------------------------- /theories/function_as_relation.th: -------------------------------------------------------------------------------- 1 | #Function as a left-total functional relation 2 | 3 | Theory Function. 4 | 5 | Relation F. 6 | Axiom left_total: exists y, F(x,y). 7 | Axiom functional: F(x,y) /\ F(x,z) => y = z. -------------------------------------------------------------------------------- /theories/graph.th: -------------------------------------------------------------------------------- 1 | Theory Graph. 2 | Relation -- . 3 | Axiom irreflexive: not (x -- x). 4 | Axiom symmety: x -- y -> y -- x. 5 | -------------------------------------------------------------------------------- /theories/graph_via_action.py: -------------------------------------------------------------------------------- 1 | Theory GraphViaAction. 2 | 3 | # A graph may be described by a left action of the monoid M 4 | # of endofunctions from {0,1} to {0,1}. The monoid M has four 5 | # elements: the identity map, the twist map opp, and the 6 | # costants maps src(x) = 0, trg(x) = 1. An action of M on 7 | # a set S is given by maps 8 | # 9 | # id : S -> S 10 | # opp : S -> S 11 | # src : S -> S 12 | # trg : S -> S 13 | # 14 | # Because id is just the identity map we can ignore it. 15 | # Because trg is opp composed with src we don't need to speak about trg. 16 | # So we are left with two unary operations opp and src, which satisfy 17 | # the equations: 18 | 19 | Unary src opp. 20 | Axiom: opp(opp(x)) = x. 21 | Axiom: src(src(x)) = src(x). 22 | Axiom: opp(src(x)) = src(x). 23 | 24 | # To get a graph from such an action, think of S as the disjoint union 25 | # of vertices and half-edges. The vertices are the fixed-points of src, 26 | # while each half-edge e is connected to the vertex src(e) and to its 27 | # counter-part opp(e). To avoid the situation where a half-edge is its 28 | # own counter-part, we need to require that opp does not have fixed-points 29 | # other than vertices: 30 | 31 | Axiom: opp(x) = x -> src(x) = x. 32 | -------------------------------------------------------------------------------- /theories/graph_with_Z3_action.th: -------------------------------------------------------------------------------- 1 | Theory Graph. 2 | Relation -- . 3 | Unary move. 4 | Axiom irreflexive: not (x -- x). 5 | Axiom symmetry: x -- y -> y -- x. 6 | Axiom order3: move(move(move(x))) = x. 7 | Axiom compatible: x -- y <-> move(x) -- move(y). -------------------------------------------------------------------------------- /theories/group.th: -------------------------------------------------------------------------------- 1 | Theory group. 2 | Constant 1. 3 | Unary inv. 4 | Binary *. 5 | 6 | Axiom: 1 * x = x. 7 | Axiom: x * 1 = x. 8 | Axiom: inv(1) = 1. 9 | Axiom: inv(inv(x)) = x. 10 | Axiom: x * inv(x) = 1. 11 | Axiom: inv(x) * x = 1. 12 | Axiom: (x * y) * z = x * (y * z). 13 | -------------------------------------------------------------------------------- /theories/group_inefficient.th: -------------------------------------------------------------------------------- 1 | # Inefficient axioms for a group. 2 | 3 | Binary *. 4 | 5 | Axiom: (x * y) * z = x * (y * z). 6 | 7 | Axiom: exists e, forall x, x * e = x /\ e * x = x /\ (exists y, x * y = e /\ y * x = e). 8 | 9 | -------------------------------------------------------------------------------- /theories/group_order3.th: -------------------------------------------------------------------------------- 1 | Theory group_all_are_order_3. 2 | Constant 1. 3 | Unary inv. 4 | Binary *. 5 | 6 | Axiom: 1 * x = x. 7 | Axiom: x * 1 = x. 8 | Axiom: inv(1) = 1. 9 | Axiom: inv(inv(x)) = x. 10 | Axiom: x * inv(x) = 1. 11 | Axiom: inv(x) * x = 1. 12 | Axiom: (x * y) * z = x * (y * z). 13 | 14 | Axiom: x * x * x = 1. 15 | -------------------------------------------------------------------------------- /theories/group_via_division.th: -------------------------------------------------------------------------------- 1 | # Groups axiomatized by division. 2 | # 3 | # Reference: 4 | # G. Higman and B.H. Neumann. Groups as grupoids with one law. 5 | # Publicationes Mathematicae Debrecen, 2:215--227, 1952. 6 | 7 | # division x/y corresponds to x * y^(-1) 8 | Binary /. 9 | Axiom: (x / ((((x / x) / y) / z) / (((x / x) / x) / z))) = y. 10 | -------------------------------------------------------------------------------- /theories/idempotent_monoid.th: -------------------------------------------------------------------------------- 1 | # Idempotent monoids 2 | Constant 1. 3 | Binary *. 4 | Axiom: x * x = x. 5 | Axiom: 1 * x = x. 6 | Axiom: x * 1 = x. 7 | Axiom: x * (y * z) = (x * y) * z. 8 | -------------------------------------------------------------------------------- /theories/injection.th: -------------------------------------------------------------------------------- 1 | # The theory of an injective function. 2 | Unary f. 3 | Axiom: f(x) = f(y) => x = y. 4 | -------------------------------------------------------------------------------- /theories/integral_domain.th: -------------------------------------------------------------------------------- 1 | Constant 0 1. 2 | Unary neg. 3 | Binary + *. 4 | 5 | Axiom plus_commutative: x + y = y + x. 6 | Axiom plus_associative: (x + y) + z = x + (y + z). 7 | Axiom zero_neutral_left: 0 + x = x. 8 | Axiom zero_neutral_right: x + 0 = x. 9 | Axiom negative_inverse: x + neg(x) = 0. 10 | Axiom negative_inverse: neg(x) + x = 0. 11 | Axiom zero_inverse: neg(0) = 0. 12 | Axiom inverse_involution: neg(neg(x)) = x. 13 | 14 | Axiom mult_unit_left: 1 * x = x. 15 | Axiom mutl_unit_right: x * 1 = x. 16 | Axiom mult_commutative: x * y = y * x. 17 | Axiom mult_associative: (x * y) * z = x * (y * z). 18 | Axiom distrutivity_right: (x + y) * z = x * z + y * z. 19 | Axiom distributivity_left: x * (y + z) = x * y + x * z. 20 | 21 | Axiom no_zero_divisors: x * y = 0 -> x = 0 \/ y = 0. -------------------------------------------------------------------------------- /theories/involution.th: -------------------------------------------------------------------------------- 1 | Unary i. 2 | Axiom: i(i(x)) = x. -------------------------------------------------------------------------------- /theories/involutive_graph.th: -------------------------------------------------------------------------------- 1 | Theory GraphWithInvolution. 2 | 3 | Relation --. 4 | Unary inv. 5 | 6 | Axiom irreflexive: not (x -- x). 7 | Axiom symmetric: x -- y -> y -- x. 8 | 9 | Axiom involution: inv(inv(x)) = x. 10 | Axiom action: x -- y -> inv(x) -- inv(y). 11 | -------------------------------------------------------------------------------- /theories/involutive_unital_quantale.th: -------------------------------------------------------------------------------- 1 | # The theory of an involutive unital quantale 2 | Constant 1. # one 3 | Constant 0. # bottom 4 | Unary i. # involution 5 | Binary |. # join 6 | Binary &. # tensor 7 | 8 | ### 0 and | form a semilattice 9 | Axiom: 0 | x = x. 10 | Axiom: x | 0 = x. 11 | Axiom: x | y = y | x. 12 | Axiom: x | (y | z) = (x | y) | z. 13 | Axiom: x | x = x. 14 | 15 | ### 1 and & form a monoid 16 | Axiom: 1 & x = x. 17 | Axiom: x & 1 = x. 18 | Axiom: x & (y & z) = (x & y) & z. 19 | 20 | ### & and | 21 | Axiom: x & 0 = 0. 22 | Axiom: 0 & x = 0. 23 | Axiom: x & (y | z) = (x & y) | (x & z). 24 | Axiom: (x | y) & z = (x & z) | (y & z). 25 | 26 | ### involution 27 | Axiom: i(i(x)) = x. 28 | Axiom: i(x & y) = i(y) & i(x). 29 | Axiom: i(x | y) = i(x) | i(y). 30 | Axiom: i(1) = 1. 31 | Axiom: i(0) = 0. 32 | -------------------------------------------------------------------------------- /theories/lattice.th: -------------------------------------------------------------------------------- 1 | # The theory of a lattice. This theory is inefficient because it does not take into account 2 | # the fact that in a finite lattice there are always the bottom and top elements. See bounded_lattice instead. 3 | Binary & |. 4 | 5 | # properties of meet 6 | Axiom: x & x = x. 7 | Axiom: x & y = y & x. 8 | Axiom: x & (y & z) = (x & y) & z. 9 | 10 | # properties of join 11 | Axiom: x | x = x. 12 | Axiom: x | y = y | x. 13 | Axiom: x | (y | z) = (x | y) | z. 14 | 15 | # absorption laws 16 | Axiom: x & (x | y) = x. 17 | Axiom: x | (x & y) = x. 18 | 19 | -------------------------------------------------------------------------------- /theories/lattice_as_relation.th: -------------------------------------------------------------------------------- 1 | 2 | Relation <=. 3 | 4 | Axiom reflexivity: x <= x. 5 | Axiom transitivity: x <= y /\ y <= z -> x <= z. 6 | Axiom antisymmetry: x <= y /\ y <= x -> x = y. 7 | 8 | Axiom infimum: forall a b, exists c, c <= a /\ c <= b /\ 9 | (forall d, d <= a /\ d <= b -> d <= c). 10 | 11 | Axiom supremum: forall a b, exists c, a <= c /\ b <= c /\ 12 | (forall d, a <= d /\ b <= d -> c <= d). -------------------------------------------------------------------------------- /theories/linear_order.th: -------------------------------------------------------------------------------- 1 | Theory Linear_order. 2 | 3 | Relation <=. 4 | Axiom reflexivity: x <= x. 5 | Axiom transitivity: x <= y /\ y <= z -> x <= z. 6 | Axiom antisymmetry: x <= y /\ y <= x -> x = y. 7 | Axiom totality: x <= y \/ y <= x. -------------------------------------------------------------------------------- /theories/magma.th: -------------------------------------------------------------------------------- 1 | Theory Magma. 2 | Binary *. -------------------------------------------------------------------------------- /theories/monoid.th: -------------------------------------------------------------------------------- 1 | # Monoids 2 | Constant 1. 3 | Binary *. 4 | Axiom: 1 * x = x. 5 | Axiom: x * 1 = x. 6 | Axiom: x * (y * z) = (x * y) * z. 7 | -------------------------------------------------------------------------------- /theories/normal_skew_lattice.th: -------------------------------------------------------------------------------- 1 | Binary & |. 2 | 3 | # properties of meet 4 | Axiom: x & x = x. 5 | Axiom: x & (y & z) = (x & y) & z. 6 | # properties of join 7 | Axiom: x | x = x. 8 | Axiom: x | (y | z) = (x | y) | z. 9 | # absorption laws 10 | Axiom: x & (x | y) = x. 11 | Axiom: (x | y) & y = y. 12 | Axiom: x | (x & y) = x. 13 | Axiom: (x & y) | y = y. 14 | # normality 15 | Axiom: ((x & y) & z) & x = ((x & z) & y) & x. -------------------------------------------------------------------------------- /theories/ordered_field.th: -------------------------------------------------------------------------------- 1 | # The axioms for a (possibly non-commutative) ordered field. 2 | 3 | Constant 0 1. 4 | Unary neg. 5 | Binary + *. 6 | Relation <=. 7 | 8 | Axiom plus_commutative: x + y = y + x. 9 | Axiom plus_associative: (x + y) + z = x + (y + z). 10 | Axiom zero_neutral_left: 0 + x = x. 11 | Axiom negative_inverse: x + neg(x) = 0. 12 | Axiom mult_associative: (x * y) * z = x * (y * z). 13 | Axiom one_unit_left: 1 * x = x. 14 | Axiom one_unit_right: x * 1 = x. 15 | Axiom distrutivity_right: (x + y) * z = x * z + y * z. 16 | Axiom distributivity_left: x * (y + z) = x * y + x * z. 17 | 18 | # Consequences of axioms that make alg run faster: 19 | 20 | Axiom zero_neutral_right: x + 0 = x. 21 | Axiom negative_inverse: neg(x) + x = 0. 22 | Axiom zero_inverse: neg(0) = 0. 23 | Axiom inverse_involution: neg(neg(x)) = x. 24 | Axiom mult_zero_left: 0 * x = 0. 25 | Axiom mult_zero_right: x * 0 = 0. 26 | 27 | # The field axiom. 28 | Axiom field: forall x, x <> 0 -> exists y, x * y = 1 /\ y * x = 1. 29 | 30 | # order axioms 31 | Axiom reflexivity: x <= x. 32 | Axiom transitivity: x <= y /\ y <= z -> x <= z. 33 | Axiom antisymmetry: x <= y /\ y <= x -> x = y. 34 | Axiom totality: x <= y \/ y <= x. 35 | 36 | Axiom : x <= y => x + z <= y + z. 37 | Axiom : 0 <= x /\ 0 <= y => 0 <= x * y. -------------------------------------------------------------------------------- /theories/partially_ordered_group.th: -------------------------------------------------------------------------------- 1 | Theory Partially_ordered_group. 2 | 3 | Constant 1. 4 | Unary inv. 5 | Binary *. 6 | Relation <=. 7 | 8 | Axiom: 1 * x = x. 9 | Axiom: x * 1 = x. 10 | Theorem: inv(1) = 1. 11 | Theorem: inv(inv(x)) = x. 12 | Axiom: x * inv(x) = 1. 13 | Axiom: inv(x) * x = 1. 14 | Axiom: (x * y) * z = x * (y * z). 15 | 16 | Axiom: a <= b => a * c <= b * c. 17 | Axiom: a <= b => c * a <= c * b. 18 | 19 | Axiom reflexivity: x <= x. 20 | Axiom transitivity: x <= y /\ y <= z -> x <= z. 21 | Axiom antisymmetry: x <= y /\ y <= x -> x = y. 22 | -------------------------------------------------------------------------------- /theories/partially_ordered_semigroup.th: -------------------------------------------------------------------------------- 1 | # Partially ordered semigroup 2 | 3 | Binary *. 4 | Relation <=. 5 | 6 | Axiom: x * (y * z) = (x * y) * z. 7 | 8 | Axiom: a <= b => a * c <= b * c. 9 | Axiom: a <= b => c * a <= c * b. 10 | 11 | Axiom reflexivity: x <= x. 12 | Axiom transitivity: x <= y /\ y <= z -> x <= z. 13 | Axiom antisymmetry: x <= y /\ y <= x -> x = y. 14 | -------------------------------------------------------------------------------- /theories/poset.th: -------------------------------------------------------------------------------- 1 | Theory Poset. 2 | Relation <=. 3 | Axiom reflexivity: x <= x. 4 | Axiom transitivity: x <= y /\ y <= z -> x <= z. 5 | Axiom antisymmetry: x <= y /\ y <= x -> x = y. 6 | -------------------------------------------------------------------------------- /theories/quantale.th: -------------------------------------------------------------------------------- 1 | # The theory of a quantale 2 | 3 | Constant 1 0. 4 | Binary &. # meet 5 | Binary |. # join 6 | Binary *. # multiplication 7 | 8 | ### Lattice structure 9 | # properties of 0 and 1 10 | Axiom: 0 | x = x. 11 | Axiom: x | 0 = x. 12 | Axiom: x | 1 = 1. 13 | Axiom: 1 | x = 1. 14 | Axiom: 1 & x = x. 15 | Axiom: x & 1 = x. 16 | Axiom: 0 & x = 0. 17 | Axiom: x & 0 = 0. 18 | 19 | # properties of meet 20 | Axiom: x & x = x. 21 | Axiom: x & y = y & x. 22 | Axiom: x & (y & z) = (x & y) & z. 23 | 24 | # properties of join 25 | Axiom: x | x = x. 26 | Axiom: x | y = y | x. 27 | Axiom: x | (y | z) = (x | y) | z. 28 | 29 | # absorption laws 30 | Axiom: x & (x | y) = x. 31 | Axiom: x | (x & y) = x. 32 | 33 | ### Multiplication 34 | Axiom: x * (y * z) = (x * y) * z. 35 | Axiom: x * (y | z) = (x | y) * (x | z). 36 | Axiom: (y | z) * x = (y | x) * (z | x). -------------------------------------------------------------------------------- /theories/quasigroup.th: -------------------------------------------------------------------------------- 1 | #The axioms for a quasigroup 2 | Theory Quasigroup. 3 | 4 | Binary * \ /. 5 | 6 | Axiom: y = x * (x \ y). 7 | Axiom: y = x \ (x * y). 8 | Axiom: y = (y / x) * x. 9 | Axiom: y = (y * x) / x. -------------------------------------------------------------------------------- /theories/rectangular_band.th: -------------------------------------------------------------------------------- 1 | Theory RectangularBand. 2 | Binary *. 3 | 4 | Axiom: x * (y * z) = (x * y) * z. 5 | Axiom: x * x = x. 6 | Axiom: x * y * x = x. 7 | 8 | -------------------------------------------------------------------------------- /theories/relation.th: -------------------------------------------------------------------------------- 1 | Theory relation. 2 | 3 | Relation R. 4 | # -------------------------------------------------------------------------------- /theories/ring.th: -------------------------------------------------------------------------------- 1 | Constant 0. 2 | Unary ~. 3 | Binary + *. 4 | 5 | Axiom plus_commutative: x + y = y + x. 6 | Axiom plus_associative: (x + y) + z = x + (y + z). 7 | Axiom zero_neutral_left: 0 + x = x. 8 | Axiom zero_neutral_right: x + 0 = x. 9 | Axiom negative_inverse: x + ~ x = 0. 10 | Axiom negative_inverse: ~ x + x = 0. 11 | Axiom zero_inverse: ~ 0 = 0. 12 | Axiom inverse_involution: ~ (~ x) = x. 13 | 14 | Axiom mult_associative: (x * y) * z = x * (y * z). 15 | Axiom distrutivity_right: (x + y) * z = x * z + y * z. 16 | Axiom distributivity_left: x * (y + z) = x * y + x * z. 17 | -------------------------------------------------------------------------------- /theories/semigroup.th: -------------------------------------------------------------------------------- 1 | # Semigroup 2 | Binary *. 3 | Axiom: x * (y * z) = (x * y) * z. 4 | -------------------------------------------------------------------------------- /theories/semilattice.th: -------------------------------------------------------------------------------- 1 | Theory join_semilattice. 2 | Constant 0 1. 3 | Binary |. 4 | 5 | Axiom: 1 | x = 1. 6 | Axiom: x | 1 = 1. 7 | Axiom: 0 | x = x. 8 | Axiom: x | 0 = x. 9 | Axiom: x | y = y | x. 10 | Axiom: x | (y | z) = (x | y) | z. 11 | Axiom: x | x = x. 12 | -------------------------------------------------------------------------------- /theories/semiring.th: -------------------------------------------------------------------------------- 1 | # A semiring is like a ring without subtraction. 2 | 3 | Theory semiring. 4 | 5 | Constant 0. 6 | Binary + *. 7 | 8 | Axiom: 0 + x = x. 9 | Axiom: x + 0 = x. 10 | Axiom: x + (y + z) = (x + y) + z. 11 | Axiom: x + y = y + x. 12 | Axiom: x * (y * z) = (x * y) * z. 13 | Axiom: (x + y) * z = x * z + y * z. 14 | Axiom: x * (y + z) = x * y + x * z. 15 | Axiom: 0 * x = 0. 16 | Axiom: x * 0 = 0. 17 | -------------------------------------------------------------------------------- /theories/set.th: -------------------------------------------------------------------------------- 1 | # The theory of a set has no constants and no axioms. 2 | 3 | -------------------------------------------------------------------------------- /theories/set2.th: -------------------------------------------------------------------------------- 1 | # The theory of a set with two elements. 2 | 3 | Axiom at_least_two: exists x y, x <> y. 4 | Axiom at_most_two: forall x y z, x = y \/ y = z \/ z = x. -------------------------------------------------------------------------------- /theories/skew_lattice.th: -------------------------------------------------------------------------------- 1 | Theory skew_lattice. 2 | 3 | Binary & |. 4 | 5 | # properties of meet 6 | Axiom: x & x = x. 7 | Axiom: x & (y & z) = (x & y) & z. 8 | 9 | # properties of join 10 | Axiom: x | x = x. 11 | Axiom: x | (y | z) = (x | y) | z. 12 | 13 | # absorption laws 14 | Axiom: x & (x | y) = x. 15 | Axiom: (x | y) & y = y. 16 | Axiom: x | (x & y) = x. 17 | Axiom: (x & y) | y = y. 18 | 19 | -------------------------------------------------------------------------------- /theories/standard_abelian_group.th: -------------------------------------------------------------------------------- 1 | # Classical axioms for an abelian group 2 | Binary *. 3 | Axiom: (x * y) * z = x * (y * z). 4 | Axiom: x * y = y * x. 5 | Axiom: exists e, forall x, x * e = x /\ (exists y, x * y = e). 6 | -------------------------------------------------------------------------------- /theories/standard_group.th: -------------------------------------------------------------------------------- 1 | # Inefficient axioms for a group. 2 | 3 | Binary *. 4 | 5 | Axiom: (x * y) * z = x * (y * z). 6 | 7 | Axiom: exists e, forall x, x * e = x /\ e * x = x /\ (exists y, x * y = e /\ y * x = e). 8 | -------------------------------------------------------------------------------- /theories/strict_poset.th: -------------------------------------------------------------------------------- 1 | Theory Strict_Poset. 2 | 3 | Relation <. 4 | 5 | Axiom irrexivity: not (x < x). 6 | Axiom transitivity: x < y /\ y < z -> x < z. 7 | Theorem asymmetric: x < y => not (y < x). 8 | -------------------------------------------------------------------------------- /theories/tarski.th: -------------------------------------------------------------------------------- 1 | Theory Tarski. 2 | Constant 0. 3 | Constant 1. 4 | Binary +. 5 | Binary *. 6 | Binary ^. 7 | 8 | Axiom: 0 + x = x. 9 | Axiom: x + 0 = x. 10 | Axiom: x + y = y + x. 11 | Axiom: (x + y) + z = x + (y + z). 12 | Axiom: 0 * x = 0. 13 | Axiom: x * 0 = 0. 14 | Axiom: 1 * x = x. 15 | Axiom: x * 1 = x. 16 | Axiom: x * y = y * x. 17 | Axiom: (x * y) * z = x * (y * z). 18 | Axiom: x * (y + z) = (x * y) + (x * z). 19 | Axiom: (x + y) * z = (x * z) + (y * z). 20 | Axiom: x <> 0 => 0 ^ x = 0. 21 | Axiom: 0 ^ x = 0 => x <> 0. 22 | Axiom: x ^ 0 = 1. 23 | Axiom: 1 ^ x = 1. 24 | Axiom: x ^ 1 = x. 25 | Axiom: x ^ (y * z) = (x ^ y) ^ z. 26 | Axiom: (x * y) ^ z = (x ^ z) * (y ^ z). 27 | Axiom: x ^ (y + z) = (x ^ y) * (x ^ z). -------------------------------------------------------------------------------- /theories/tarski_high_school_algebra.th: -------------------------------------------------------------------------------- 1 | # Tarski's high school algebra (according to Wikipedia, which is a bit fishy) 2 | Constant 1. 3 | Binary + * ^. 4 | 5 | ### + is a commutative semigroup 6 | Axiom: x + y = y + x. 7 | Axiom: x + (y + z) = (x + y) + z. 8 | 9 | ### (1,*) is a commutative monoid 10 | Axiom: 1 * x = x. 11 | Axiom: x * 1 = x. 12 | Axiom: x * y = y * x. 13 | Axiom: x * (y * z) = (x * y) * z. 14 | 15 | ### distributivity of + and * 16 | Axiom: x * (y + z) = x * y + x * z. 17 | Axiom: (x + y) * z = x * z + y * z. 18 | 19 | ### Exponentiation 20 | Axiom: 1 ^ x = 1. 21 | Axiom: x ^ 1 = x. 22 | Axiom: (x * y) ^ z = (x ^ z) * (y ^ z). 23 | Axiom: x ^ (y + z) = (x ^ y) * (x ^ z). 24 | Axiom: x ^ (y * z) = (x ^ y) ^ z. 25 | -------------------------------------------------------------------------------- /theories/transitive_relation.th: -------------------------------------------------------------------------------- 1 | Theory Transitive_relation. 2 | Relation <=. 3 | Axiom transitivity: x <= y /\ y <= z -> x <= z. 4 | -------------------------------------------------------------------------------- /theories/triangle_free_graph.th: -------------------------------------------------------------------------------- 1 | Theory GraphWithoutTriangles. 2 | Relation -- . 3 | Axiom irreflexive: not (x -- x). 4 | Axiom symmety: x -- y -> y -- x. 5 | 6 | Axiom no_triangle: x -- y -> not (exists z, x -- z /\ y -- z). 7 | 8 | # Axiom no_triangle: x -- y -> forall z, not (x -- z) \/ not (y -- z). 9 | -------------------------------------------------------------------------------- /theories/tricolored_graph.th: -------------------------------------------------------------------------------- 1 | Theory TriColoredGraph. 2 | Predicates red green blue. 3 | Relation --. 4 | Axiom irreflexive: not (x -- x). 5 | Axiom symmetric: x -- y -> y -- x. 6 | 7 | Axiom: red(x) \/ green(x) \/ blue(x). 8 | Axiom: red(x) -> not green(x) /\ not blue(x). 9 | Axiom: green(x) -> not red(x) /\ not blue(x). 10 | Axiom: blue(x) -> not red(x) /\ not green(x). 11 | Axiom: x -- y -> (red(x) -> not red(y)) /\ (green(x) -> not green(y)) /\ (blue(x) -> not blue(y)). -------------------------------------------------------------------------------- /theories/unital_commutative_ring.th: -------------------------------------------------------------------------------- 1 | # The axioms for a ring 2 | 3 | Constant 0 1. 4 | Unary ~. 5 | Binary + *. 6 | 7 | Axiom plus_commutative: x + y = y + x. 8 | Axiom plus_associative: (x + y) + z = x + (y + z). 9 | Axiom zero_neutral_left: 0 + x = x. 10 | Axiom zero_neutral_right: x + 0 = x. 11 | Axiom negative_inverse: x + ~ x = 0. 12 | Axiom negative_inverse: ~ x + x = 0. 13 | Axiom zero_inverse: ~ 0 = 0. 14 | Axiom inverse_involution: ~ (~ x) = x. 15 | 16 | Axiom mult_unit_left: 1 * x = x. 17 | Axiom mutl_unit_right: x * 1 = x. 18 | Axiom mult_commutative: x * y = y * x. 19 | Axiom mult_associative: (x * y) * z = x * (y * z). 20 | Axiom distrutivity_right: (x + y) * z = x * z + y * z. 21 | Axiom distributivity_left: x * (y + z) = x * y + x * z. 22 | -------------------------------------------------------------------------------- /theories/unital_commutative_semiring.th: -------------------------------------------------------------------------------- 1 | # A unital commutative semiring is like a unital commtative ring without subtraction. 2 | 3 | Theory unital_commutative_semiring. 4 | 5 | Constant 0 1. 6 | Binary + *. 7 | 8 | Axiom: 0 + x = x. 9 | Axiom: x + 0 = x. 10 | Axiom: x + (y + z) = (x + y) + z. 11 | Axiom: x + y = y + x. 12 | 13 | Axiom: 1 * x = x. 14 | Axiom: x * 1 = x. 15 | Axiom: x * (y * z) = (x * y) * z. 16 | Axiom: x * y = y * x. 17 | 18 | Axiom: (x + y) * z = x * z + y * z. 19 | Axiom: x * (y + z) = x * y + x * z. 20 | 21 | Axiom: 0 * x = 0. 22 | Axiom: x * 0 = 0. 23 | -------------------------------------------------------------------------------- /theories/unital_ring.th: -------------------------------------------------------------------------------- 1 | Theory unital_ring. 2 | 3 | Constant 0 1. 4 | Unary ~. 5 | Binary + *. 6 | 7 | Axiom plus_commutative: x + y = y + x. 8 | Axiom plus_associative: (x + y) + z = x + (y + z). 9 | Axiom zero_neutral_left: 0 + x = x. 10 | Axiom negative_inverse: x + ~ x = 0. 11 | Axiom mult_associative: (x * y) * z = x * (y * z). 12 | Axiom one_unit_left: 1 * x = x. 13 | Axiom one_unit_right: x * 1 = x. 14 | Axiom distrutivity_right: (x + y) * z = x * z + y * z. 15 | Axiom distributivity_left: x * (y + z) = x * y + x * z. 16 | 17 | # Consequences of axioms that make alg run faster: 18 | 19 | Axiom zero_neutral_right: x + 0 = x. 20 | Axiom negative_inverse: ~ x + x = 0. 21 | Axiom zero_inverse: ~ 0 = 0. 22 | Axiom inverse_involution: ~ (~ x) = x. 23 | Axiom mult_zero_left: 0 * x = 0. 24 | Axiom mult_zero_right: x * 0 = 0. 25 | 26 | --------------------------------------------------------------------------------