diff --git a/.dockerignore b/.dockerignore new file mode 100644 index 000000000..d0b04c7bf --- /dev/null +++ b/.dockerignore @@ -0,0 +1,3 @@ +.git +examples +_build diff --git a/.gitignore b/.gitignore index f03a8fe3e..0490dd13a 100644 --- a/.gitignore +++ b/.gitignore @@ -38,3 +38,5 @@ setup.* examples benchs *.exe +*.install +.merlin diff --git a/.merlin b/.merlin deleted file mode 100644 index 08c8fd45c..000000000 --- a/.merlin +++ /dev/null @@ -1,30 +0,0 @@ -S src -S src/arbitrary/ -S src/core -S src/core/lib -S src/proofs -S src/parsers/ -S src/arbitrary/ -S src/meta -S src/solving/ -S src/tools/ -S src/tools/orient/ -S src/prover -S src/prover/lib -S src/prover/calculi -S src/prover/meta -S src/hornet/ -S src/main/ -S tests/ -B _build/src/** -B _build/tests/ -PKG zarith -PKG containers.data -PKG containers -PKG sequence -PKG gen -PKG qcheck -PKG unix -PKG msat -PKG tip_parser -FLG -w +a-4-44-48-50-58-60 diff --git a/.ocamlinit b/.ocamlinit deleted file mode 100644 index 45771d54f..000000000 --- a/.ocamlinit +++ /dev/null @@ -1,114 +0,0 @@ -#use "topfind";; -#require "unix";; -#require "zarith";; -#require "containers";; -#require "containers.data";; -#require "sequence";; -#require "gen";; -#require "oclock";; -#directory "_build/src/" -#directory "_build/src/core";; -#directory "_build/src/prover";; -#directory "_build/src/parsers";; -#directory "_build/src/meta/";; -#directory "_build/src/arbitrary/";; -#directory "_build/tests/";; - -print_endline "load base lib....";; -#load "logtk.cma";; -open Logtk;; -module ST = InnerTerm;; -module T = Term;; -module PT = STerm;; -let (~<) = ID.make;; -#install_printer ID.pp;; -#install_printer Type.pp;; -#install_printer T.pp;; -#install_printer STerm.pp;; -#install_printer TypedSTerm.pp;; -#install_printer UntypedAST.pp_statement;; -#install_printer HVar.pp;; -#install_printer Subst.pp;; -#install_printer Signature.pp;; -#install_printer ParseLocation.pp;; -#install_printer Precedence.pp;; -#install_printer Precedence.Weight.pp;; -#install_printer Ordering.pp;; -#install_printer Position.pp;; -#install_printer Ordinal.pp;; - -(* optional part: parser *) -print_endline "load parser lib...";; -#require "tip_parser";; -#load "logtk_parsers.cma";; -open Logtk_parsers;; - -let psterm, pstmt, pstmt_l = - let tyctx = TypeInference.Ctx.create () in - let pt s = - let t = Parse_zf.parse_term Lex_zf.token (Lexing.from_string s) in - let t = TypeInference.infer_exn tyctx t in - TypeInference.Ctx.exit_scope tyctx; - t - and pst s = - let t = Parse_zf.parse_statement Lex_zf.token (Lexing.from_string s) in - let t = TypeInference.infer_statement_exn tyctx t in - TypeInference.Ctx.exit_scope tyctx; - t - and pst_l s = - let l = Parse_zf.parse_statement_list Lex_zf.token (Lexing.from_string s) in - let l = TypeInference.infer_statements_exn ~on_var:`Default ~ctx:tyctx (Sequence.of_list l) in - TypeInference.Ctx.exit_scope tyctx; - CCVector.to_list l - in - pt, pst, pst_l -;; - -(* prelude *) -ignore (pstmt_l - "val term : type. - val a : term. - val b : term. - val c : term. - val d : term. - val e : term. - val f : term -> term -> term. - val g : term -> term. - val h : term -> term. - val ite : term -> term -> term -> term. - val p : term -> term -> prop. - val q : term -> prop. - val r : term -> prop. - val s : prop. - val f_ho2: (term -> term ) -> (term -> term) -> term. - val p_ho2: (term -> term ) -> (term -> term) -> prop. - ");; - -(* parse Term.t *) -let pterm = - let ctx = T.Conv.create() in - fun s -> - psterm s |> T.Conv.of_simple_term_exn ctx -;; - -(* optional part: arbitrary *) -#require "qcheck";; -#load "logtk_arbitrary.cma";; - -print_endline "load prover lib...";; -#load "libzipperposition_prover.cma";; -module M = Monome;; -module MF = Monome.Focus;; -#install_printer FOTerm.pp;; -#install_printer Literal.pp;; -#install_printer Clause.pp;; -#install_printer STerm.pp;; -#install_printer Substs.FO.pp;; -#install_printer Proof.pp;; -#install_printer Signature.pp;; -#install_printer Type.pp;; -#install_printer Monome.pp;; -let pterm_tptp s = Parse_tptp.parse_term Lex_tptp.token (Lexing.from_string s);; -let pform_tptp s = Parse_tptp.parse_formula Lex_tptp.token (Lexing.from_string s);; -let pterm_zf s = Parse_zf.parse_term Lex_zf.token (Lexing.from_string s);; -Printf.printf "finished loading\n";; diff --git a/CHANGELOG.md b/CHANGELOG.md index 84862f862..65e103258 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,75 @@ # Changelog +## 1.5 + +- be compatible with sequence >= 1.0 +- cli option to switch off maximal number of variables per clause +- Dockerfile and instructions to build a docker image +- add eta-reduction to `LLTerm` +- update phases API + params so it's easier to use from utop +- move to jbuilder + +- fail early when unifying a variable and a polymorphic constant +- More realistic test to expose a bug in unification of polymorphic terms +- upper bound on msat and deps on logtk +- fix for llprover (use congruence correctly for poly equalities) +- printer for congruence +- cache llproof checking result, display it in llproof-printing +- refactor proof checker to look more like a tableaux prover + dot printing +- llprover: hack to allow checking of rewriting steps that occur under binders +- split proof checker into its own module `LLProver` +- add linear expressions and arith predicates in `LLTerm` +- make demodulation more robust +- bugfix in `Type.apply` for polymorphic type arguments +- stop positive extensionality rule from removing type arguments +- moved detection for "distinct object" syntax into TypeInference +- omit type declarations for distinct objects in TPTP output +- bugfix restrict_to_scope: recursive call when variable already in scope +- bugfix: type of polymorphic application in app_encode tool +- bugfix: app_encode extensionality axiom needs type arguments +- `fo_detector` tool to count problems with applied variables +- clean up Subst module +- bugfix: wrong polymorphic types in returned unifier +- remove hornet from makefile, improve logitest targets +- remove hornet +- better type error messages +- make `Subst.apply` tailrec +- "int" mode for variable purification +- bugfix: unquote identifiers in TPTP parser + +## 1.4 + +- remove inlining on parsers +- cli option for ext-neg rule +- add `--check-types` for checking types deeply in new clauses +- Add ExistsConst (??) and ForallConst (!!) to TPTP parser +- TPTP parser: allow function types as THF terms +- add cli option `-bt` (alias to `--backtraces`) +- completion of equalities with λ-abstractions as RHS in type inference +- THF parser: allow for `@` applications in types +- cli flag for ext_pos +- App encode: binary for app-encoding HO applications into FO + +- bugfix in ho unification +- in unification, fix order in which bound variables are added to env +- bugfix in unification (would produce wrong type) +- do not simplify in demodulation +- Add StarExec instructions to readme +- bugfixes `app_encode` +- β-normalize rewrite rules that are eq-completed +- uniform output of “SZS status” instead of “SZS Status” +- auto flattening of applications in STerm +- fix `examples/ho/extensionality1.zf` by forbidding some HO demodulations +- fix tag managing (and therefore proof checking) for `Lit.is_absurd` +- bugfix in proof checking related to instantiation +- bugfix in NPDtree +- more elegant and robust sup-at-var condition +- sup-at-var condition with polymorphism +- remove literal comparison by constraint +- no selection of literals containing ho variables +- Stricter sup-at-vars condition +- purify naked variables + ## 1.3 - experimental proof checking with `--check` (and `--dot-llproof `) diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 000000000..8e9993695 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,21 @@ +FROM ocaml/opam:alpine as build +# init and set perms +WORKDIR /zipper/build +RUN sudo chown opam: /zipper/build +# deps +RUN eval `opam config env` && \ + opam update && \ + opam depext -i zarith && \ + opam install jbuilder zarith containers sequence msat menhir +# main build +COPY --chown=opam:nogroup src *.opam Makefile ./ +RUN eval `opam config env` && \ + make build && \ + cp _build/default/main/zipperposition.exe ./zipperposition + +# prepare lightweight production image +FROM alpine:latest as prod +WORKDIR /root +RUN apk update && apk add gmp-dev +COPY --from=build /zipper/build/zipperposition . +ENTRYPOINT ["./zipperposition"] diff --git a/Makefile b/Makefile index fd68794be..00e284e84 100644 --- a/Makefile +++ b/Makefile @@ -1,49 +1,23 @@ -# OASIS_START -# DO NOT EDIT (digest: b2ac72b97ac10c57bd1c0d74a664b293) -SETUP = ./setup.exe +J?=3 -build: setup.data $(SETUP) - $(SETUP) -build $(BUILDFLAGS) +all: build test -doc: setup.data $(SETUP) build - $(SETUP) -doc $(DOCFLAGS) +build: + jbuilder build @install -j $J -test: setup.data $(SETUP) build - $(SETUP) -test $(TESTFLAGS) +clean: + jbuilder clean -all: $(SETUP) - $(SETUP) -all $(ALLFLAGS) +doc: + jbuilder build @doc -install: setup.data $(SETUP) - $(SETUP) -install $(INSTALLFLAGS) - -uninstall: setup.data $(SETUP) - $(SETUP) -uninstall $(UNINSTALLFLAGS) - -reinstall: setup.data $(SETUP) - $(SETUP) -reinstall $(REINSTALLFLAGS) - -clean: $(SETUP) - $(SETUP) -clean $(CLEANFLAGS) - -distclean: $(SETUP) - $(SETUP) -distclean $(DISTCLEANFLAGS) - $(RM) $(SETUP) - -setup.data: $(SETUP) - $(SETUP) -configure $(CONFIGUREFLAGS) - -configure: $(SETUP) - $(SETUP) -configure $(CONFIGUREFLAGS) - -setup.exe: setup.ml - ocamlfind ocamlopt -o $@ setup.ml || ocamlfind ocamlc -o $@ setup.ml || true - $(RM) setup.cmi setup.cmo setup.cmx setup.o setup.cmt - -.PHONY: build doc test all install uninstall reinstall clean distclean configure +test: + jbuilder runtest --no-buffer -j $J + # ./tests/quick/all.sh # FIXME? -# OASIS_STOP +open_doc: doc + xdg-open _build/default/_doc/index.html rst_doc: @echo "build Sphinx documentation (into _build/doc)" @@ -51,65 +25,48 @@ rst_doc: mkdir -p gh-pages/rst/ cp -r _build/doc/*.html _build/doc/*.js _build/doc/_static gh-pages/rst -open_doc: rst_doc - firefox _build/doc/contents.html +open_rst_doc: rst_doc + xdg-open _build/doc/contents.html push_doc: doc rst_doc rsync -tavu logtk.docdir/* cedeela.fr:~/simon/root/software/logtk/ rsync -tavu _build/doc/* cedeela.fr:~/simon/root/software/logtk/rst/ -test-all: build - ./run_tests.native --verbose - # ./tests/quick/all.sh # FIXME? - INTERFACE_FILES = $(shell find src -name '*.mli') IMPLEMENTATION_FILES = $(shell find src -name '*.ml') -VERSION=$(shell awk '/^Version:/ {print $$2}' _oasis) +VERSION=$(shell awk '/^version:/ {print $$2}' zipperposition.opam) update_next_tag: @echo "update version to $(VERSION)..." zsh -c 'sed -i "s/NEXT_VERSION/$(VERSION)/g" src/**/*.ml{,i}(.)' zsh -c 'sed -i "s/NEXT_RELEASE/$(VERSION)/g" src/**/*.ml{,i}(.)' -tags: - otags $(IMPLEMENTATION_FILES) $(INTERFACE_FILES) - -dot: - for i in *.dot; do dot -Tsvg "$$i" > "$$( basename $$i .dot )".svg; done - -TEST_FILES = tests/ examples/ -TEST_TOOL = logitest -J?=2 -TEST_OPTS ?= -j $(J) --junit test.xml +TEST_FILES=tests/ examples/ +TEST_TOOL=logitest +TEST_OPTS?= -j $(J) --junit test.xml DATE=$(shell date +%FT%H:%M) -check-test-tool: - @if ! ( which $(TEST_TOOL) > /dev/null ) ; then echo "install $(TEST_TOOL)"; exit 1; fi +check_$(TEST_TOOL): + @if ` which $(TEST_TOOL) > /dev/null ` ; then true ; else echo "install $(TEST_TOOL)"; exit 1; fi -$(TEST_TOOL): check-test-tool +$(TEST_TOOL): check_$(TEST_TOOL) $(TEST_TOOL) run -c ./tests/conf.toml $(TEST_OPTS) $(TEST_FILES) -$(TEST_TOOL)-zipper: check-test-tool +$(TEST_TOOL)-zipper: check_$(TEST_TOOL) $(TEST_TOOL) run -p zipperposition -c ./tests/conf.toml $(TEST_OPTS) $(TEST_FILES) -$(TEST_TOOL)-hornet: check-test-tool - -check_$(TEST_TOOL): - @if not (which $(TEST_TOOL) > /dev/null) ; then echo "install $(TEST_TOOL)"; exit 1; fi - $(TEST_TOOL): check_$(TEST_TOOL) - $(TEST_TOOL) run -c ./tests/conf.toml $(TEST_OPTS) $(TEST_FILES) + $(TEST_TOOL) run -c ./tests/conf.toml $(TEST_OPTS) $(TEST_FILES) \ + --summary snapshots/full-$(DATE).txt \ + --csv snapshots/full-$(DATE).csv \ $(TEST_TOOL)-zipper: @mkdir -p snapshots $(TEST_TOOL) run -p zipperposition,zipperposition-check -c ./tests/conf.toml \ - --summary snapshots/tip-$(DATE).txt \ - --csv snapshots/tip-$(DATE).csv \ + --summary snapshots/zipper-$(DATE).txt \ + --csv snapshots/zipper-$(DATE).csv \ $(TEST_OPTS) $(TEST_FILES) -$(TEST_TOOL)-hornet: - $(TEST_TOOL) run -p hornet -c ./tests/conf.toml $(TEST_OPTS) $(TEST_FILES) - tip-benchmarks: git submodule update --init tip-benchmarks @@ -155,8 +112,7 @@ TARBALL=zipperposition.tar.gz package: clean rm $(TARBALL) || true oasis setup - tar cavf $(TARBALL) _oasis setup.ml configure myocamlbuild.ml _tags \ - Makefile pelletier_problems README.md src/ tests/ utils/ + tar cavf $(TARBALL) Makefile pelletier_problems README.md src/ tests/ utils/ WATCH?=all watch: @@ -178,10 +134,5 @@ reindent: ocp-indent gallery.svg: for i in gallery/*.dot ; do dot -Tsvg "$$i" > "gallery/`basename $${i} .dot`.svg" ; done -clean-generated: - rm myocamlbuild.ml || true - find \( -name '*.mldylib' -or -name '*.mlpack' \ - -or -name '*.mllib' -or -name '*.odocl' \) -delete - -.PHONY: push_doc dot package tags rst_doc open_doc test-all clean-generated +.PHONY: doc push_doc dot package tags rst_doc open_doc test-all diff --git a/README.adoc b/README.adoc index b4d2b5f7c..965e41c98 100644 --- a/README.adoc +++ b/README.adoc @@ -573,10 +573,24 @@ See http://c-cube.github.io/zipperposition/[this page]. There are some examples of how to use the code in `src/tools/` and `src/demo/`. +== Docker + +(experimental) + +to build an image: + +- `docker build -t zipper .` + +to use the image: + +- `docker run -i zipper < examples/pelletier_problems/pb47.zf` + == Howto (for devs) === Make a release +Now we use jbuilder, it should simplify the process compared to oasis. + - merge `dev` into `master`: `git checkout master; git merge dev` @@ -585,11 +599,9 @@ and `src/demo/`. - merge `master` into `stable` (branch with only releases): `git checkout stable; git merge master --no-ff` -- edit `_oasis` to update the version number (field `Version`). - Also edit the same field in `opam`. +- edit `*.opam` files to update the version number (field `version`). -- run `oasis setup` to update the build system with the new modules, version, - etc. +- `git commit -a -m "prepare for "` (to save the changes on the stable branch) - `make clean all` (to check everything builds properly) diff --git a/_oasis b/_oasis deleted file mode 100644 index b30f57d12..000000000 --- a/_oasis +++ /dev/null @@ -1,301 +0,0 @@ -OASISFormat: 0.4 -Name: zipperposition -Version: 1.4 -Homepage: https://github.com/c-cube/zipperposition -Authors: Simon Cruanes -License: BSD-3-clause -LicenseFile: LICENSE -Plugins: META (0.3), DevFiles (0.3) -OCamlVersion: >= 4.00.1 -BuildTools: ocamlbuild -FilesAB: src/prover/const.ml.ab -AlphaFeatures: compiled_setup_ml, ocamlbuild_more_args - -XOCamlbuildExtraArgs: "-menhir 'menhir --dump --explain' -j 0" - -Synopsis: Superposition theorem prover, for first order logic with equality. -Description: - Zipperposition is an experimental theorem prover based on - superposition. It aims at being flexible and extensible while retaining - decent performance (using indexing, for instance). - It ships with a logic toolkit, designed primarily for - first-order automated reasoning. It aims - at providing basic types and algorithms (terms, unification, orderings, - indexing, etc.) that can be factored out of several applications. - -Flag "tools" - Description: Build and install basic tools (CNF, etc.) - Default: false - -Flag "bench" - Description: Build and run benchmarks - Default: false - -Flag "long_tests" - Description: Test the prover against a set of problems - Default: false - -Flag "parsers" - Description: Build and install parsers (requires menhir) - Default: true - -Flag "solving" - Description: Build and install constraint solvers (requires "msat") - Default: false - -Flag "zipperposition_prover" - Description: Build and install Zipperposition - Default: true - -Flag "hornet_prover" - Description: Build and install Hornet - Default: false - -Flag "qcheck" - Description: Build and install QCheck random generators - Default: false - -Flag "demo" - Description: Build and install demo programs - Default: false - -Library "logtk" - Path: src/core/ - Pack: true - Modules: InnerTerm, Term, Type, Util, STerm, Interfaces, - DBEnv, Position, Var, HVar, Defined_pos, - Subst, Signature, Scoped, - Unif, Unif_intf, Unif_constr, Unif_subst, HO_unif, - TypeInference, Options, Comparison, Precedence, Builtin, - Ordering, Skolem, Cnf, ID, Head, SLiteral, - Index, Index_intf, Dtree, Fingerprint, NPDtree, Binder, - Congruence, Congruence_intf, Lambda, - FeatureVector, FV_tree, UntypedAST, Ind_ty, - TypedSTerm, Statement, Flex_state, Compute_prec, - Ordinal, Polynomial, Rewrite, Test_prop, Input_format, - Output_format, Proof, - Multisets, Literal, Literals, Int_lit, Rat_lit, Monome, - lib/Hashcons, lib/ParseLocation, lib/Multiset, lib/LazyList, - lib/Hash, lib/IArray, lib/AllocCache, lib/Multiset_intf, - lib/Signal, lib/UnionFind - CSources: util_stubs.c, util_stubs.h - CCOpt: -Wextra -Wno-unused-parameter - BuildDepends: zarith, unix, sequence, containers, - containers.data, bytes - -Library "logtk_proofs" - Path: src/proofs - Pack: true - FindlibParent: logtk - FindlibName: proofs - Modules: LLProof, LLProof_conv, LLProof_check, LLTerm - BuildDepends: logtk - -Library "logtk_parsers" - Path: src/parsers - Pack: true - Modules: Parse_tptp, Lex_tptp, Ast_tptp, Util_tptp, - Trace_tstp, Parse_zf, Lex_zf, Util_zf, Util_tip, - Tip_ast, Tip_parser, Tip_lexer, - Util_dk, Parse_dk, Lex_dk, Ast_dk, - Parsing_utils, CallProver - Build$: flag(parsers) - Install$: flag(parsers) - FindlibName: parsers - FindlibParent: logtk - BuildDepends: logtk - BuildTools: menhir - -Library "logtk_solving" - Path: src/solving - Pack: true - FindlibParent: logtk - FindlibName: solving - Modules: Lpo - Build$: flag(solving) - Install$: flag(solving) - BuildDepends: logtk, msat - -Library "logtk_arbitrary" - Path: src/arbitrary/ - Pack: true - FindlibName: arbitrary - FindlibParent: logtk - Modules: ArTerm, ArForm, ArType, ArID, ArLiteral - BuildDepends: logtk, qcheck - Build$: flag(qcheck) - Install$: flag(qcheck) - -Library "libzipperposition" - Path: src/prover/ - Pack: true - FindlibName: libzipperposition - Modules: ClauseQueue, Clause, SClause, Const, Extensions, - Ctx, ProofState, Bool_clause, - Saturate, Selection, AC, AC_intf, SimplM, - Params, Env, Signals, Classify_cst, - Ctx_intf, Clause_intf, Env_intf, ProofState_intf, - BBox, ClauseContext, ClauseQueue_intf, - Bool_lit, Bool_lit_intf, Sat_solver, Sat_solver_intf, - Trail, Ind_cst, Cover_set, Cut_form, Phases, Phases_impl, - calculi/Avatar, calculi/Avatar_intf, - calculi/Induction, calculi/Induction_intf, - calculi/Superposition, calculi/Superposition_intf, - calculi/Rewriting, - calculi/EnumTypes, - calculi/Arith_int, - calculi/Arith_rat, - calculi/Heuristics, - calculi/Ind_types, - calculi/Fool, - calculi/Higher_order - InternalModules: lib/Simplex - Build$: flag(parsers) && flag("zipperposition_prover") - Install$: flag(parsers) && flag("zipperposition_prover") - BuildDepends: containers, sequence, unix, zarith, msat, - logtk, logtk.parsers, logtk.proofs - -# main executable for the prover -Executable zipperposition - Path: src/main/ - Install: true - CompiledObject: native - MainIs: zipperposition.ml - Build$: flag(parsers) && flag("zipperposition_prover") - Install$: flag(parsers) && flag("zipperposition_prover") - BuildDepends: containers, sequence, unix, - logtk, logtk.parsers, libzipperposition - -# experimental prover -Executable hornet - Path: src/hornet/ - Install: true - CompiledObject: native - MainIs: hornet.ml - Build$: flag(parsers) && flag("hornet_prover") - Install$: flag(parsers) && flag("hornet_prover") - BuildDepends: containers, sequence, unix, msat, - logtk, logtk.parsers - -Document logtk - Title: Documentation for Logtk - Abstract: Main API documentation for Logtk. - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install$: flag(docs) - Build$: flag(docs) - XOCamlbuildPath: . - XOCamlbuildLibraries: logtk - XOCamlbuildExtraArgs: "-docflags '-keep-code -colorize-code -short-functors -charset utf-8'" - -Document logtk_parsers - Title: Logtk_parsers documentation - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install$: flag(docs) && flag(parsers) - Build$: flag(docs) && flag(parsers) - XOCamlbuildPath: . - XOCamlbuildLibraries: logtk.parsers - -Document logtk_arbitrary - Title: Logtk_arbitrary documentation - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install$: flag(docs) && flag(qcheck) - Build$: flag(docs) && flag(qcheck) - XOCamlbuildPath: . - XOCamlbuildLibraries: logtk.arbitrary - -Document libzipperposition - Title: Libzipperpositio documentation - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install$: flag(docs) - Build$: flag(docs) - XOCamlbuildPath: . - XOCamlbuildLibraries: libzipperposition - -Executable run_bench - Path: tests/bench/ - Install: false - CompiledObject: native - MainIs: run_bench.ml - Build$: flag(bench) && flag(tests) - BuildDepends: logtk, benchmark, qcheck, logtk.arbitrary - -Test all - Command: make test-all - TestTools: run_tests - Run$: flag(tests) && flag(qcheck) - -Test run - Command: make frogtest - Run$: flag(tests) && flag(long_tests) - -Executable run_tests - Path: tests/ - Install: false - CompiledObject: native - MainIs: run_tests.ml - Build$: flag(tests) && flag(qcheck) && flag(parsers) - BuildDepends: logtk, logtk.parsers, oUnit, - logtk.arbitrary, qcheck - -# TPTP syntax and type checking -Executable type_check - Path: src/tools/ - Build$: flag(tools) && flag(parsers) - Install$: flag(tools) && flag(parsers) - CompiledObject: native - MainIs: type_check.ml - BuildDepends: logtk, logtk.parsers - -# Conversion to CNF -Executable cnf_of - Path: src/tools/ - Build$: flag(tools) && flag(parsers) - Install$: flag(tools) && flag(parsers) - CompiledObject: native - MainIs: cnf_of.ml - BuildDepends: logtk, logtk.parsers - -# Applicative encoding -Executable app_encode - Path: src/tools/ - Build$: flag(tools) && flag(parsers) - Install$: flag(tools) && flag(parsers) - CompiledObject: native - MainIs: app_encode.ml - BuildDepends: logtk, logtk.parsers - -# proof checking -Executable tptp_to_zf - Path: src/tools/ - Build$: flag(tools) && flag(parsers) - Install$: flag(tools) && flag(parsers) - CompiledObject: native - MainIs: tptp_to_zf.ml - BuildDepends: logtk, logtk.parsers - -# proof checking -Executable proof_check_tstp - Path: src/tools/ - Build$: flag(tools) && flag(parsers) - Install$: flag(tools) && flag(parsers) - CompiledObject: native - MainIs: proof_check_tstp.ml - BuildDepends: logtk, logtk.parsers - -# Demo: resolution -Executable resolution1 - Path: src/demo/resolution - Build$: flag(parsers) && flag(demo) - Install: false - CompiledObject: native - MainIs: resolution1.ml - BuildDepends: logtk, logtk.parsers, sequence, containers - -SourceRepository head - Type: git - Location: https://github.com/c-cube/zipperposition - Browser: https://github.com/c-cube/zipperposition/tree/master/src diff --git a/_tags b/_tags deleted file mode 100644 index 1d73e1957..000000000 --- a/_tags +++ /dev/null @@ -1,432 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: bf0e9b4542a1ebdd9122f6807c0f025f) -# Ignore VCS directories, you can use the same kind of rule outside -# OASIS_START/STOP if you want to exclude directories that contains -# useless stuff for the build process -true: annot, bin_annot -<**/.svn>: -traverse -<**/.svn>: not_hygienic -".bzr": -traverse -".bzr": not_hygienic -".hg": -traverse -".hg": not_hygienic -".git": -traverse -".git": not_hygienic -"_darcs": -traverse -"_darcs": not_hygienic -# Library logtk -"src/core/logtk.cmxs": use_logtk -"src/core/InnerTerm.cmx": for-pack(Logtk) -"src/core/Term.cmx": for-pack(Logtk) -"src/core/Type.cmx": for-pack(Logtk) -"src/core/Util.cmx": for-pack(Logtk) -"src/core/STerm.cmx": for-pack(Logtk) -"src/core/Interfaces.cmx": for-pack(Logtk) -"src/core/DBEnv.cmx": for-pack(Logtk) -"src/core/Position.cmx": for-pack(Logtk) -"src/core/Var.cmx": for-pack(Logtk) -"src/core/HVar.cmx": for-pack(Logtk) -"src/core/Defined_pos.cmx": for-pack(Logtk) -"src/core/Subst.cmx": for-pack(Logtk) -"src/core/Signature.cmx": for-pack(Logtk) -"src/core/Scoped.cmx": for-pack(Logtk) -"src/core/Unif.cmx": for-pack(Logtk) -"src/core/Unif_intf.cmx": for-pack(Logtk) -"src/core/Unif_constr.cmx": for-pack(Logtk) -"src/core/Unif_subst.cmx": for-pack(Logtk) -"src/core/HO_unif.cmx": for-pack(Logtk) -"src/core/TypeInference.cmx": for-pack(Logtk) -"src/core/Options.cmx": for-pack(Logtk) -"src/core/Comparison.cmx": for-pack(Logtk) -"src/core/Precedence.cmx": for-pack(Logtk) -"src/core/Builtin.cmx": for-pack(Logtk) -"src/core/Ordering.cmx": for-pack(Logtk) -"src/core/Skolem.cmx": for-pack(Logtk) -"src/core/Cnf.cmx": for-pack(Logtk) -"src/core/ID.cmx": for-pack(Logtk) -"src/core/Head.cmx": for-pack(Logtk) -"src/core/SLiteral.cmx": for-pack(Logtk) -"src/core/Index.cmx": for-pack(Logtk) -"src/core/Index_intf.cmx": for-pack(Logtk) -"src/core/Dtree.cmx": for-pack(Logtk) -"src/core/Fingerprint.cmx": for-pack(Logtk) -"src/core/NPDtree.cmx": for-pack(Logtk) -"src/core/Binder.cmx": for-pack(Logtk) -"src/core/Congruence.cmx": for-pack(Logtk) -"src/core/Congruence_intf.cmx": for-pack(Logtk) -"src/core/Lambda.cmx": for-pack(Logtk) -"src/core/FeatureVector.cmx": for-pack(Logtk) -"src/core/FV_tree.cmx": for-pack(Logtk) -"src/core/UntypedAST.cmx": for-pack(Logtk) -"src/core/Ind_ty.cmx": for-pack(Logtk) -"src/core/TypedSTerm.cmx": for-pack(Logtk) -"src/core/Statement.cmx": for-pack(Logtk) -"src/core/Flex_state.cmx": for-pack(Logtk) -"src/core/Compute_prec.cmx": for-pack(Logtk) -"src/core/Ordinal.cmx": for-pack(Logtk) -"src/core/Polynomial.cmx": for-pack(Logtk) -"src/core/Rewrite.cmx": for-pack(Logtk) -"src/core/Test_prop.cmx": for-pack(Logtk) -"src/core/Input_format.cmx": for-pack(Logtk) -"src/core/Output_format.cmx": for-pack(Logtk) -"src/core/Proof.cmx": for-pack(Logtk) -"src/core/Multisets.cmx": for-pack(Logtk) -"src/core/Literal.cmx": for-pack(Logtk) -"src/core/Literals.cmx": for-pack(Logtk) -"src/core/Int_lit.cmx": for-pack(Logtk) -"src/core/Rat_lit.cmx": for-pack(Logtk) -"src/core/Monome.cmx": for-pack(Logtk) -"src/core/lib/Hashcons.cmx": for-pack(Logtk) -"src/core/lib/ParseLocation.cmx": for-pack(Logtk) -"src/core/lib/Multiset.cmx": for-pack(Logtk) -"src/core/lib/LazyList.cmx": for-pack(Logtk) -"src/core/lib/Hash.cmx": for-pack(Logtk) -"src/core/lib/IArray.cmx": for-pack(Logtk) -"src/core/lib/AllocCache.cmx": for-pack(Logtk) -"src/core/lib/Multiset_intf.cmx": for-pack(Logtk) -"src/core/lib/signal.cmx": for-pack(Logtk) -"src/core/lib/UnionFind.cmx": for-pack(Logtk) -: oasis_library_logtk_ccopt -: oasis_library_logtk_ccopt -"src/core/util_stubs.c": oasis_library_logtk_ccopt -: use_liblogtk_stubs -: package(bytes) -: package(containers) -: package(containers.data) -: package(sequence) -: package(unix) -: package(zarith) -: package(bytes) -: package(containers) -: package(containers.data) -: package(sequence) -: package(unix) -: package(zarith) -"src/core/util_stubs.c": package(bytes) -"src/core/util_stubs.c": package(containers) -"src/core/util_stubs.c": package(containers.data) -"src/core/util_stubs.c": package(sequence) -"src/core/util_stubs.c": package(unix) -"src/core/util_stubs.c": package(zarith) -# Library logtk_proofs -"src/proofs/logtk_proofs.cmxs": use_logtk_proofs -"src/proofs/LLProof.cmx": for-pack(Logtk_proofs) -"src/proofs/LLProof_conv.cmx": for-pack(Logtk_proofs) -"src/proofs/LLProof_check.cmx": for-pack(Logtk_proofs) -"src/proofs/LLTerm.cmx": for-pack(Logtk_proofs) -: package(bytes) -: package(containers) -: package(containers.data) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -# Library logtk_parsers -"src/parsers/logtk_parsers.cmxs": use_logtk_parsers -"src/parsers/parse_tptp.cmx": for-pack(Logtk_parsers) -"src/parsers/lex_tptp.cmx": for-pack(Logtk_parsers) -"src/parsers/ast_tptp.cmx": for-pack(Logtk_parsers) -"src/parsers/util_tptp.cmx": for-pack(Logtk_parsers) -"src/parsers/trace_tstp.cmx": for-pack(Logtk_parsers) -"src/parsers/parse_zf.cmx": for-pack(Logtk_parsers) -"src/parsers/lex_zf.cmx": for-pack(Logtk_parsers) -"src/parsers/util_zf.cmx": for-pack(Logtk_parsers) -"src/parsers/util_tip.cmx": for-pack(Logtk_parsers) -"src/parsers/Tip_ast.cmx": for-pack(Logtk_parsers) -"src/parsers/Tip_parser.cmx": for-pack(Logtk_parsers) -"src/parsers/Tip_lexer.cmx": for-pack(Logtk_parsers) -"src/parsers/Util_dk.cmx": for-pack(Logtk_parsers) -"src/parsers/parse_dk.cmx": for-pack(Logtk_parsers) -"src/parsers/lex_dk.cmx": for-pack(Logtk_parsers) -"src/parsers/Ast_dk.cmx": for-pack(Logtk_parsers) -"src/parsers/parsing_utils.cmx": for-pack(Logtk_parsers) -"src/parsers/callProver.cmx": for-pack(Logtk_parsers) -: package(bytes) -: package(containers) -: package(containers.data) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -# Library logtk_solving -"src/solving/logtk_solving.cmxs": use_logtk_solving -"src/solving/lpo.cmx": for-pack(Logtk_solving) -: package(bytes) -: package(containers) -: package(containers.data) -: package(msat) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -# Library logtk_arbitrary -"src/arbitrary/logtk_arbitrary.cmxs": use_logtk_arbitrary -"src/arbitrary/arTerm.cmx": for-pack(Logtk_arbitrary) -"src/arbitrary/arForm.cmx": for-pack(Logtk_arbitrary) -"src/arbitrary/arType.cmx": for-pack(Logtk_arbitrary) -"src/arbitrary/arID.cmx": for-pack(Logtk_arbitrary) -"src/arbitrary/arLiteral.cmx": for-pack(Logtk_arbitrary) -: package(bytes) -: package(containers) -: package(containers.data) -: package(qcheck) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -# Library libzipperposition -"src/prover/libzipperposition.cmxs": use_libzipperposition -"src/prover/clauseQueue.cmx": for-pack(Libzipperposition) -"src/prover/clause.cmx": for-pack(Libzipperposition) -"src/prover/SClause.cmx": for-pack(Libzipperposition) -"src/prover/const.cmx": for-pack(Libzipperposition) -"src/prover/extensions.cmx": for-pack(Libzipperposition) -"src/prover/ctx.cmx": for-pack(Libzipperposition) -"src/prover/proofState.cmx": for-pack(Libzipperposition) -"src/prover/Bool_clause.cmx": for-pack(Libzipperposition) -"src/prover/saturate.cmx": for-pack(Libzipperposition) -"src/prover/selection.cmx": for-pack(Libzipperposition) -"src/prover/AC.cmx": for-pack(Libzipperposition) -"src/prover/AC_intf.cmx": for-pack(Libzipperposition) -"src/prover/simplM.cmx": for-pack(Libzipperposition) -"src/prover/params.cmx": for-pack(Libzipperposition) -"src/prover/env.cmx": for-pack(Libzipperposition) -"src/prover/signals.cmx": for-pack(Libzipperposition) -"src/prover/Classify_cst.cmx": for-pack(Libzipperposition) -"src/prover/ctx_intf.cmx": for-pack(Libzipperposition) -"src/prover/clause_intf.cmx": for-pack(Libzipperposition) -"src/prover/env_intf.cmx": for-pack(Libzipperposition) -"src/prover/proofState_intf.cmx": for-pack(Libzipperposition) -"src/prover/bBox.cmx": for-pack(Libzipperposition) -"src/prover/clauseContext.cmx": for-pack(Libzipperposition) -"src/prover/clauseQueue_intf.cmx": for-pack(Libzipperposition) -"src/prover/bool_lit.cmx": for-pack(Libzipperposition) -"src/prover/bool_lit_intf.cmx": for-pack(Libzipperposition) -"src/prover/sat_solver.cmx": for-pack(Libzipperposition) -"src/prover/sat_solver_intf.cmx": for-pack(Libzipperposition) -"src/prover/trail.cmx": for-pack(Libzipperposition) -"src/prover/Ind_cst.cmx": for-pack(Libzipperposition) -"src/prover/Cover_set.cmx": for-pack(Libzipperposition) -"src/prover/Cut_form.cmx": for-pack(Libzipperposition) -"src/prover/phases.cmx": for-pack(Libzipperposition) -"src/prover/phases_impl.cmx": for-pack(Libzipperposition) -"src/prover/calculi/avatar.cmx": for-pack(Libzipperposition) -"src/prover/calculi/avatar_intf.cmx": for-pack(Libzipperposition) -"src/prover/calculi/induction.cmx": for-pack(Libzipperposition) -"src/prover/calculi/induction_intf.cmx": for-pack(Libzipperposition) -"src/prover/calculi/superposition.cmx": for-pack(Libzipperposition) -"src/prover/calculi/superposition_intf.cmx": for-pack(Libzipperposition) -"src/prover/calculi/Rewriting.cmx": for-pack(Libzipperposition) -"src/prover/calculi/enumTypes.cmx": for-pack(Libzipperposition) -"src/prover/calculi/Arith_int.cmx": for-pack(Libzipperposition) -"src/prover/calculi/Arith_rat.cmx": for-pack(Libzipperposition) -"src/prover/calculi/heuristics.cmx": for-pack(Libzipperposition) -"src/prover/calculi/ind_types.cmx": for-pack(Libzipperposition) -"src/prover/calculi/fool.cmx": for-pack(Libzipperposition) -"src/prover/calculi/Higher_order.cmx": for-pack(Libzipperposition) -"src/prover/lib/simplex.cmx": for-pack(Libzipperposition) -: package(bytes) -: package(containers) -: package(containers.data) -: package(msat) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -: use_logtk_parsers -: use_logtk_proofs -: package(bytes) -: package(containers) -: package(containers.data) -: package(msat) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -: use_logtk_parsers -: use_logtk_proofs -: package(bytes) -: package(containers) -: package(containers.data) -: package(msat) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -: use_logtk_parsers -: use_logtk_proofs -# Executable zipperposition -"src/main/zipperposition.native": package(bytes) -"src/main/zipperposition.native": package(containers) -"src/main/zipperposition.native": package(containers.data) -"src/main/zipperposition.native": package(msat) -"src/main/zipperposition.native": package(sequence) -"src/main/zipperposition.native": package(unix) -"src/main/zipperposition.native": package(zarith) -"src/main/zipperposition.native": use_libzipperposition -"src/main/zipperposition.native": use_logtk -"src/main/zipperposition.native": use_logtk_parsers -"src/main/zipperposition.native": use_logtk_proofs -: package(bytes) -: package(containers) -: package(containers.data) -: package(msat) -: package(sequence) -: package(unix) -: package(zarith) -: use_libzipperposition -: use_logtk -: use_logtk_parsers -: use_logtk_proofs -# Executable hornet -"src/hornet/hornet.native": package(bytes) -"src/hornet/hornet.native": package(containers) -"src/hornet/hornet.native": package(containers.data) -"src/hornet/hornet.native": package(msat) -"src/hornet/hornet.native": package(sequence) -"src/hornet/hornet.native": package(unix) -"src/hornet/hornet.native": package(zarith) -"src/hornet/hornet.native": use_logtk -"src/hornet/hornet.native": use_logtk_parsers -: package(bytes) -: package(containers) -: package(containers.data) -: package(msat) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -: use_logtk_parsers -# Executable run_bench -"tests/bench/run_bench.native": package(benchmark) -"tests/bench/run_bench.native": package(bytes) -"tests/bench/run_bench.native": package(containers) -"tests/bench/run_bench.native": package(containers.data) -"tests/bench/run_bench.native": package(qcheck) -"tests/bench/run_bench.native": package(sequence) -"tests/bench/run_bench.native": package(unix) -"tests/bench/run_bench.native": package(zarith) -"tests/bench/run_bench.native": use_logtk -"tests/bench/run_bench.native": use_logtk_arbitrary -: package(benchmark) -: package(bytes) -: package(containers) -: package(containers.data) -: package(qcheck) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -: use_logtk_arbitrary -# Executable run_tests -"tests/run_tests.native": package(bytes) -"tests/run_tests.native": package(containers) -"tests/run_tests.native": package(containers.data) -"tests/run_tests.native": package(oUnit) -"tests/run_tests.native": package(qcheck) -"tests/run_tests.native": package(sequence) -"tests/run_tests.native": package(unix) -"tests/run_tests.native": package(zarith) -"tests/run_tests.native": use_logtk -"tests/run_tests.native": use_logtk_arbitrary -"tests/run_tests.native": use_logtk_parsers -: package(bytes) -: package(containers) -: package(containers.data) -: package(oUnit) -: package(qcheck) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -: use_logtk_arbitrary -: use_logtk_parsers -# Executable type_check -"src/tools/type_check.native": package(bytes) -"src/tools/type_check.native": package(containers) -"src/tools/type_check.native": package(containers.data) -"src/tools/type_check.native": package(sequence) -"src/tools/type_check.native": package(unix) -"src/tools/type_check.native": package(zarith) -"src/tools/type_check.native": use_logtk -"src/tools/type_check.native": use_logtk_parsers -# Executable cnf_of -"src/tools/cnf_of.native": package(bytes) -"src/tools/cnf_of.native": package(containers) -"src/tools/cnf_of.native": package(containers.data) -"src/tools/cnf_of.native": package(sequence) -"src/tools/cnf_of.native": package(unix) -"src/tools/cnf_of.native": package(zarith) -"src/tools/cnf_of.native": use_logtk -"src/tools/cnf_of.native": use_logtk_parsers -# Executable app_encode -"src/tools/app_encode.native": package(bytes) -"src/tools/app_encode.native": package(containers) -"src/tools/app_encode.native": package(containers.data) -"src/tools/app_encode.native": package(sequence) -"src/tools/app_encode.native": package(unix) -"src/tools/app_encode.native": package(zarith) -"src/tools/app_encode.native": use_logtk -"src/tools/app_encode.native": use_logtk_parsers -# Executable tptp_to_zf -"src/tools/tptp_to_zf.native": package(bytes) -"src/tools/tptp_to_zf.native": package(containers) -"src/tools/tptp_to_zf.native": package(containers.data) -"src/tools/tptp_to_zf.native": package(sequence) -"src/tools/tptp_to_zf.native": package(unix) -"src/tools/tptp_to_zf.native": package(zarith) -"src/tools/tptp_to_zf.native": use_logtk -"src/tools/tptp_to_zf.native": use_logtk_parsers -# Executable proof_check_tstp -"src/tools/proof_check_tstp.native": package(bytes) -"src/tools/proof_check_tstp.native": package(containers) -"src/tools/proof_check_tstp.native": package(containers.data) -"src/tools/proof_check_tstp.native": package(sequence) -"src/tools/proof_check_tstp.native": package(unix) -"src/tools/proof_check_tstp.native": package(zarith) -"src/tools/proof_check_tstp.native": use_logtk -"src/tools/proof_check_tstp.native": use_logtk_parsers -: package(bytes) -: package(containers) -: package(containers.data) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -: use_logtk_parsers -# Executable resolution1 -"src/demo/resolution/resolution1.native": package(bytes) -"src/demo/resolution/resolution1.native": package(containers) -"src/demo/resolution/resolution1.native": package(containers.data) -"src/demo/resolution/resolution1.native": package(sequence) -"src/demo/resolution/resolution1.native": package(unix) -"src/demo/resolution/resolution1.native": package(zarith) -"src/demo/resolution/resolution1.native": use_logtk -"src/demo/resolution/resolution1.native": use_logtk_parsers -: package(bytes) -: package(containers) -: package(containers.data) -: package(sequence) -: package(unix) -: package(zarith) -: use_logtk -: use_logtk_parsers -# OASIS_STOP - -# avoid compiler error -: optimize(classic), inline(0) - -<**/*.cmx>: inline(15) -true: bin_annot, no_alias_deps, use_menhir, color(always), optimize(3) - -"tests/quick/": -traverse -"tests/quick/": not_hygienic -"Problems": -traverse -"tptp": -traverse -<*bench*/>: -traverse - -: warn(+a-4-42-44-48-50-58-32-60@8) - -: for-pack(Libzipperposition) - -: inline(20) diff --git a/configure b/configure deleted file mode 100755 index 7f72e84c3..000000000 --- a/configure +++ /dev/null @@ -1,31 +0,0 @@ -#!/bin/sh - -# OASIS_START -# DO NOT EDIT (digest: c4f9525da0bd6ffb05b2621d51841920) -set -e - -FST=true -for i in "$@"; do - if $FST; then - set -- - FST=false - fi - - case $i in - --*=*) - ARG=${i%%=*} - VAL=${i##*=} - set -- "$@" "$ARG" "$VAL" - ;; - *) - set -- "$@" "$i" - ;; - esac -done - -if [ ! -e setup.exe ] || [ _oasis -nt setup.exe ] || [ setup.ml -nt setup.exe ] || [ configure -nt setup.exe ]; then - ocamlfind ocamlopt -o setup.exe setup.ml || ocamlfind ocamlc -o setup.exe setup.ml || exit 1 - rm -f setup.cmi setup.cmo setup.cmx setup.o setup.cmt -fi -./setup.exe -configure "$@" -# OASIS_STOP diff --git a/data/bench.toml b/data/bench.toml index c596af761..49b71dd1c 100644 --- a/data/bench.toml +++ b/data/bench.toml @@ -1,5 +1,5 @@ -provers = [ "zipperposition", "zipperposition-thf", "zipperposition-check", "hornet", "read-tptp", "leo2", "satallax" ] +provers = [ "zipperposition", "zipperposition-thf", "zipperposition-check", "read-tptp", "leo2", "satallax" ] [test] @@ -48,15 +48,6 @@ sat = "SZS status (CounterSatisfiable|Satisfiable)" timeout = "SZS status ResourceOut" version = "git:." -[hornet] - -binary = "./hornet.native" -cmd = "./hornet.native $file -t $timeout --max-depth 200" -unsat = "UNSAT" -sat = "^SAT" -timeout = "SZS status ResourceOut" -version = "git:." - [satallax] cmd = "~/bin/satallax -t $timeout $file" diff --git a/doc/TODO.md b/doc/TODO.md deleted file mode 100644 index bd7dcf57e..000000000 --- a/doc/TODO.md +++ /dev/null @@ -1,53 +0,0 @@ -# TODO - -- nettoyer le code. - * avoir un second langage d'entrée qui permette de décrire les features - au dessus (marre de TPTP), et qui soit accessoirement plus lisible. - * entrée SMTlib - * écrire un système de tests directement lié à Sledgehammer -- améliorer le support du polymorphisme (avec pleins de tests venant de - Sledgehammer en entrée, ça devrait être naturel). -- ajouter une notion d'égalité définitionnelle, au moins pour les - définitions non récursives de termes (et peut-être de proposition); on - verra si ça intersecte avec le travail de David sur la - super-superposition. -- ajouter une notion d'application currifiée (un genre de `@` infixe - qui fait que les fonctions deviennent des constantes, et donc qu'on - peut appliques des variables `x @ y`); - le cas `f @ a1 @ ... @ an` avec `f` n-aire se réduit à `f(a1,...,an)`. - En l'absence de λ on reste fondamentalement au premier ordre. -- ajouter une vraie notion de type inductif (co-inductif: je ne sais - pas) et réfléchir à un remplacement/encodage du pattern matching. J'ai déjà - quasiment toutes les briques de base sous la main, mais c'est laid - et je voudrais un traitement efficace et général. En particulier, - gérer correctement l'acyclicité et l'injectivité. -- nettoyer l'induction en la basant sur les types inductifs au dessus; - possiblement aussi améliorer les heuristiques qui sont pour l'instant - faibles. -- extensionalité (avec `@` on peut parler d'égalité entre fonctions) -- implèm complète d'AVATAR (geler les clauses, etc.) - * peut être plus simple en virant l'aspect QBF (et en spécialisant sur Msat) - -## Ideas - -- merge definitional rewriting and demodulation -- how to deal with definitions: - * Build a symbol dependency graph such that if `f x y := t[x,y]` is non-recursive, - then `f -> g` is in the graph for every symbol `g ∈ t`. Then, a DFS on - the graph gives us a _layer level_ for every symbol (it also breaks - cycles arbitrarily), such that `f -> g` implies `level(f) ≥ level(g)+1` - (except for cycles of course). - `compare(f,g) -> compare(level(f), level(g))` is then a proper order for - computing precedences. - * For inductive symbols, `n := 0 | succ(n2)` could be dealt with this way, - by using possibly negative levels and enforcing `level(n2) = level(n)-1`. -- AVATAR: - * store locks in each clause, and keep a map `b_lit -> clauses it locks` - for efficiently retrieving clauses that might be unlocked when this lit - changes - * store interpretation as a `b_lit set` - * compute difference between current and previous interpretation, and - check whether the corresponding clauses are unlocked. - * keep locked clauses in term indices! Makes model changes less costly - (maybe this should be an option, performance impact unclear) - diff --git a/doc/api_intro.text b/doc/api_intro.text deleted file mode 100644 index cb93a4659..000000000 --- a/doc/api_intro.text +++ /dev/null @@ -1,69 +0,0 @@ - -This is the API documentation for Logtk (the library for terms, formulas, -literals, unification, type inference, etc.), - -{2 API Documentation for Logtk} - -{!modules: -Binder -Builtin -Cache -Cnf -Comparison -Compute_prec -Congruence -DBEnv -Dtree -Term -FeatureVector -Fingerprint -Flex_state -Formula -FormulaShape -FV_tree -Hashcons -HVar -IArray -ID -Head -Index -Ind_ty -InnerTerm -Interfaces -Lambda -LazyGraph -LazyList -Multiset -NPDtree -Options -Ordering -Ordering_intf -Ordinal -ParseLocation -Position -Precedence -Purify -Rewrite_term -STerm -Scoped -Signal -Signature -Skolem -Sourced -SLiteral -STerm -Subst -Transform -Type -TypeInference -TypedSTerm -Unif -UnionFind -UntypedAST -Util -Var -} - -{2 List of modules} - -{!indexlist} diff --git a/libzipperposition.odocl b/libzipperposition.odocl deleted file mode 100644 index 23183612d..000000000 --- a/libzipperposition.odocl +++ /dev/null @@ -1,51 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3b88eb037da90e86b49e2856ccc7213c) -src/prover/ClauseQueue -src/prover/Clause -src/prover/SClause -src/prover/Const -src/prover/Extensions -src/prover/Ctx -src/prover/ProofState -src/prover/Bool_clause -src/prover/Saturate -src/prover/Selection -src/prover/AC -src/prover/AC_intf -src/prover/SimplM -src/prover/Params -src/prover/Env -src/prover/Signals -src/prover/Classify_cst -src/prover/Ctx_intf -src/prover/Clause_intf -src/prover/Env_intf -src/prover/ProofState_intf -src/prover/BBox -src/prover/ClauseContext -src/prover/ClauseQueue_intf -src/prover/Bool_lit -src/prover/Bool_lit_intf -src/prover/Sat_solver -src/prover/Sat_solver_intf -src/prover/Trail -src/prover/Ind_cst -src/prover/Cover_set -src/prover/Cut_form -src/prover/Phases -src/prover/Phases_impl -src/prover/calculi/Avatar -src/prover/calculi/Avatar_intf -src/prover/calculi/Induction -src/prover/calculi/Induction_intf -src/prover/calculi/Superposition -src/prover/calculi/Superposition_intf -src/prover/calculi/Rewriting -src/prover/calculi/EnumTypes -src/prover/calculi/Arith_int -src/prover/calculi/Arith_rat -src/prover/calculi/Heuristics -src/prover/calculi/Ind_types -src/prover/calculi/Fool -src/prover/calculi/Higher_order -# OASIS_STOP diff --git a/libzipperposition.opam b/libzipperposition.opam new file mode 100644 index 000000000..00bb639d3 --- /dev/null +++ b/libzipperposition.opam @@ -0,0 +1,26 @@ +opam-version: "1.2" +maintainer: "simon.cruanes@inria.fr" +author: "Simon Cruanes" +homepage: "https://github.com/c-cube/zipperposition" +build: ["jbuilder" "build" "-p" name] +build-doc: ["jbuilder" "build" "@doc"] +install: ["jbuilder" "install" name] +remove: ["jbuilder" "uninstall" name] +depends: [ + "ocamlfind" { build } + "base-bytes" + "base-unix" + "zarith" + "containers" { >= "1.0" } + "sequence" { >= "0.4" } + "jbuilder" { build } + "msat" { >= "0.5" < "1.0" } + "menhir" {build} +] +available: [ + ocaml-version >= "4.03.0" +] +tags: [ "logic" "unification" "term" "superposition" "prover" ] +bug-reports: "https://github.com/c-cube/zipperposition/issues" +dev-repo: "https://github.com/c-cube/zipperposition.git" + diff --git a/libzipperposition_arbitrary.odocl b/libzipperposition_arbitrary.odocl deleted file mode 100644 index ad23a9726..000000000 --- a/libzipperposition_arbitrary.odocl +++ /dev/null @@ -1,7 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ea1af52e6882501755312244c711272b) -src/arbitrary/ArTerm -src/arbitrary/ArForm -src/arbitrary/ArType -src/arbitrary/ArID -# OASIS_STOP diff --git a/libzipperposition_meta.odocl b/libzipperposition_meta.odocl deleted file mode 100644 index 7cb70bf95..000000000 --- a/libzipperposition_meta.odocl +++ /dev/null @@ -1,7 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ee8d02674ababe3397fc79a0ee08848c) -src/meta/Encoding -src/meta/Reasoner -src/meta/Plugin -src/meta/Prover -# OASIS_STOP diff --git a/libzipperposition_parsers.odocl b/libzipperposition_parsers.odocl deleted file mode 100644 index eb7367a81..000000000 --- a/libzipperposition_parsers.odocl +++ /dev/null @@ -1,16 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 7a7fbdf346489a923426d189a18ec735) -src/parsers/Parse_tptp -src/parsers/Lex_tptp -src/parsers/Ast_tptp -src/parsers/Util_tptp -src/parsers/Ast_ho -src/parsers/Lex_ho -src/parsers/Parse_ho -src/parsers/Trace_tstp -src/parsers/Parse_zf -src/parsers/Lex_zf -src/parsers/Util_zf -src/parsers/Parsing_utils -src/parsers/CallProver -# OASIS_STOP diff --git a/libzipperposition_prover.odocl b/libzipperposition_prover.odocl deleted file mode 100644 index 673320e8f..000000000 --- a/libzipperposition_prover.odocl +++ /dev/null @@ -1,56 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 8ec322b90047799ee4064555a6f8c4fd) -src/prover/ClauseQueue -src/prover/Clause -src/prover/SClause -src/prover/Const -src/prover/Extensions -src/prover/Literal -src/prover/Literals -src/prover/Ctx -src/prover/ProofStep -src/prover/ProofPrint -src/prover/ProofState -src/prover/Saturate -src/prover/Selection -src/prover/AC -src/prover/AC_intf -src/prover/SimplM -src/prover/Compute_prec -src/prover/Params -src/prover/Env -src/prover/Monome -src/prover/ArithLit -src/prover/Signals -src/prover/Multisets -src/prover/Ctx_intf -src/prover/Clause_intf -src/prover/Env_intf -src/prover/ProofState_intf -src/prover/BBox -src/prover/ClauseContext -src/prover/ClauseQueue_intf -src/prover/Bool_lit -src/prover/Bool_lit_intf -src/prover/Sat_solver -src/prover/Sat_solver_intf -src/prover/Trail -src/prover/Ind_cst -src/prover/Phases -src/prover/Phases_impl -src/prover/Flex_state -src/prover/Classify_cst -src/prover/Rewrite_rule -src/prover/calculi/Avatar -src/prover/calculi/Avatar_intf -src/prover/calculi/Induction -src/prover/calculi/Induction_intf -src/prover/calculi/Superposition -src/prover/calculi/Rewriting -src/prover/calculi/EnumTypes -src/prover/calculi/ArithInt -src/prover/calculi/Heuristics -src/prover/calculi/Ind_types -src/prover/meta/MetaProverState -src/prover/meta/MetaProverState_intf -# OASIS_STOP diff --git a/logtk.odocl b/logtk.odocl deleted file mode 100644 index d57f53bfd..000000000 --- a/logtk.odocl +++ /dev/null @@ -1,73 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 35f9a15cba625100e1bf7496fa5a0a37) -src/core/InnerTerm -src/core/Term -src/core/Type -src/core/Util -src/core/STerm -src/core/Interfaces -src/core/DBEnv -src/core/Position -src/core/Var -src/core/HVar -src/core/Defined_pos -src/core/Subst -src/core/Signature -src/core/Scoped -src/core/Unif -src/core/Unif_intf -src/core/Unif_constr -src/core/Unif_subst -src/core/HO_unif -src/core/TypeInference -src/core/Options -src/core/Comparison -src/core/Precedence -src/core/Builtin -src/core/Ordering -src/core/Skolem -src/core/Cnf -src/core/ID -src/core/Head -src/core/SLiteral -src/core/Index -src/core/Index_intf -src/core/Dtree -src/core/Fingerprint -src/core/NPDtree -src/core/Binder -src/core/Congruence -src/core/Congruence_intf -src/core/Lambda -src/core/FeatureVector -src/core/FV_tree -src/core/UntypedAST -src/core/Ind_ty -src/core/TypedSTerm -src/core/Statement -src/core/Flex_state -src/core/Compute_prec -src/core/Ordinal -src/core/Polynomial -src/core/Rewrite -src/core/Test_prop -src/core/Input_format -src/core/Output_format -src/core/Proof -src/core/Multisets -src/core/Literal -src/core/Literals -src/core/Int_lit -src/core/Rat_lit -src/core/Monome -src/core/lib/Hashcons -src/core/lib/ParseLocation -src/core/lib/Multiset -src/core/lib/LazyList -src/core/lib/Hash -src/core/lib/IArray -src/core/lib/AllocCache -src/core/lib/Multiset_intf -src/core/lib/Signal -src/core/lib/UnionFind -# OASIS_STOP diff --git a/logtk.opam b/logtk.opam new file mode 100644 index 000000000..7cfc6fd19 --- /dev/null +++ b/logtk.opam @@ -0,0 +1,32 @@ +opam-version: "1.2" +maintainer: "simon.cruanes@inria.fr" +author: "Simon Cruanes" +homepage: "https://github.com/c-cube/zipperposition" +build: ["jbuilder" "build" "-p" name] +build-doc: ["jbuilder" "build" "@doc"] +install: ["jbuilder" "install" name] +remove: ["jbuilder" "uninstall" name] +build-test: [ + ["jbuilder" "runtest"] +] +depends: [ + "ocamlfind" { build } + "base-bytes" + "base-unix" + "zarith" + "containers" { >= "1.0" } + "sequence" { >= "0.4" } + "jbuilder" { build } +] +depopts: [ + "qcheck" {test} + "msat" { >= "0.5" < "1.0" } + "menhir" {build} +] +available: [ + ocaml-version >= "4.03.0" +] +tags: [ "logic" "unification" "term" ] +bug-reports: "https://github.com/c-cube/zipperposition/issues" +dev-repo: "https://github.com/c-cube/zipperposition.git" + diff --git a/logtk_arbitrary.odocl b/logtk_arbitrary.odocl deleted file mode 100644 index 47f9aa3f9..000000000 --- a/logtk_arbitrary.odocl +++ /dev/null @@ -1,8 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 48adcd572b8b9036362ad8e4a746c2ed) -src/arbitrary/ArTerm -src/arbitrary/ArForm -src/arbitrary/ArType -src/arbitrary/ArID -src/arbitrary/ArLiteral -# OASIS_STOP diff --git a/logtk_parsers.odocl b/logtk_parsers.odocl deleted file mode 100644 index d16758515..000000000 --- a/logtk_parsers.odocl +++ /dev/null @@ -1,21 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 22bb77dfe110de62f431717a96f3aa9d) -src/parsers/Parse_tptp -src/parsers/Lex_tptp -src/parsers/Ast_tptp -src/parsers/Util_tptp -src/parsers/Trace_tstp -src/parsers/Parse_zf -src/parsers/Lex_zf -src/parsers/Util_zf -src/parsers/Util_tip -src/parsers/Tip_ast -src/parsers/Tip_parser -src/parsers/Tip_lexer -src/parsers/Util_dk -src/parsers/Parse_dk -src/parsers/Lex_dk -src/parsers/Ast_dk -src/parsers/Parsing_utils -src/parsers/CallProver -# OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml deleted file mode 100644 index ab9c02dc8..000000000 --- a/myocamlbuild.ml +++ /dev/null @@ -1,966 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 6e0e46e4f1f2658932a826addf81a5a0) *) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - - - let ns_ str = str - let s_ str = str - let f_ (str: ('a, 'b, 'c, 'd) format4) = str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = [] -end - -module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - !what_idx = String.length what - - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - !what_idx = -1 - - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - - let replace_chars f s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents buf - - let lowercase_ascii = - replace_chars - (fun c -> - if (c >= 'A' && c <= 'Z') then - Char.chr (Char.code c + 32) - else - c) - - let uncapitalize_ascii s = - if s <> "" then - (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - - let uppercase_ascii = - replace_chars - (fun c -> - if (c >= 'a' && c <= 'z') then - Char.chr (Char.code c - 32) - else - c) - - let capitalize_ascii s = - if s <> "" then - (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - -end - -module OASISUtils = struct -(* # 22 "src/oasis/OASISUtils.ml" *) - - - open OASISGettext - - - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end - - - module MapString = MapExt.Make(String) - - - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list = elements - end - end - - - module SetString = SetExt.Make(String) - - - let compare_csl s1 s2 = - String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - let equal s1 s2 = (compare_csl s1 s2) = 0 - let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) - end) - - module SetStringCsl = - SetExt.Make - (struct - type t = string - let compare = compare_csl - end) - - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - OASISString.lowercase_ascii buf - end - - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - - let failwithf fmt = Printf.ksprintf failwith fmt - - - let rec file_location ?pos1 ?pos2 ?lexbuf () = - match pos1, pos2, lexbuf with - | Some p, None, _ | None, Some p, _ -> - file_location ~pos1:p ~pos2:p ?lexbuf () - | Some p1, Some p2, _ -> - let open Lexing in - let fn, lineno = p1.pos_fname, p1.pos_lnum in - let c1 = p1.pos_cnum - p1.pos_bol in - let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in - Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 - | _, _, Some lexbuf -> - file_location - ~pos1:(Lexing.lexeme_start_p lexbuf) - ~pos2:(Lexing.lexeme_end_p lexbuf) - () - | None, None, None -> - s_ "" - - - let failwithpf ?pos1 ?pos2 ?lexbuf fmt = - let loc = file_location ?pos1 ?pos2 ?lexbuf () in - Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - open OASISGettext - open OASISUtils - - - type test = string - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - - -# 437 "myocamlbuild.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = - let line = ref 1 in - let lexer st = - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - Genlex.make_lexer ["="] st_line - in - let rec read_file lxr mp = - match Stream.npeek 3 lxr with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; - read_file lxr (MapString.add nm value mp) - | [] -> mp - | _ -> - failwith - (Printf.sprintf "Malformed data file '%s' line %d" filename !line) - in - match stream with - | Some st -> read_file (lexer st) MapString.empty - | None -> - if Sys.file_exists filename then begin - let chn = open_in_bin filename in - let st = Stream.of_channel chn in - try - let mp = read_file (lexer st) MapString.empty in - close_in chn; mp - with e -> - close_in chn; raise e - end else if allow_empty then begin - MapString.empty - end else begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let rec var_expand str env = - let buff = Buffer.create ((String.length str) * 2) in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = var_expand (MapString.find name env) env - let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst -end - - -# 517 "myocamlbuild.ml" -module MyOCamlbuildFindlib = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) - - - (** OCamlbuild extension, copied from - * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html - * by N. Pouillard and others - * - * Updated on 2016-06-02 - * - * Modified by Sylvain Le Gall - *) - open Ocamlbuild_plugin - - - type conf = {no_automatic_syntax: bool} - - - let run_and_read = Ocamlbuild_pack.My_unix.run_and_read - - - let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings - - - let exec_from_conf exec = - let exec = - let env = BaseEnvLight.load ~allow_empty:true () in - try - BaseEnvLight.var_get exec env - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" exec; - exec - in - let fix_win32 str = - if Sys.os_type = "Win32" then begin - let buff = Buffer.create (String.length str) in - (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) - String.iter - (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) - str; - Buffer.contents buff - end else begin - str - end - in - fix_win32 exec - - - let split s ch = - let buf = Buffer.create 13 in - let x = ref [] in - let flush () = - x := (Buffer.contents buf) :: !x; - Buffer.clear buf - in - String.iter - (fun c -> - if c = ch then - flush () - else - Buffer.add_char buf c) - s; - flush (); - List.rev !x - - - let split_nl s = split s '\n' - - - let before_space s = - try - String.before s (String.index s ' ') - with Not_found -> s - - (* ocamlfind command *) - let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] - - (* This lists all supported packages. *) - let find_packages () = - List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) - - - (* Mock to list available syntaxes. *) - let find_syntaxes () = ["camlp4o"; "camlp4r"] - - - let well_known_syntax = [ - "camlp4.quotations.o"; - "camlp4.quotations.r"; - "camlp4.exceptiontracer"; - "camlp4.extend"; - "camlp4.foldgenerator"; - "camlp4.listcomprehension"; - "camlp4.locationstripper"; - "camlp4.macro"; - "camlp4.mapgenerator"; - "camlp4.metagenerator"; - "camlp4.profiler"; - "camlp4.tracer" - ] - - - let dispatch conf = - function - | After_options -> - (* By using Before_options one let command line options have an higher - * priority on the contrary using After_options will guarantee to have - * the higher priority override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop"; - Options.ocamlmklib := ocamlfind & A"ocamlmklib" - - | After_rules -> - - (* Avoid warnings for unused tag *) - flag ["tests"] N; - - (* When one link an OCaml library/binary/package, one should use - * -linkpkg *) - flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let (args, pargs) = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if not (conf.no_automatic_syntax) && - (Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax) then - (syn_args @ base_args, syn_args) - else - (base_args, []) - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - - (* TODO: Check if this is allowed for OCaml < 3.12.1 *) - flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; - end - (find_packages ()); - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> - flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & - S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); - flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); - flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); - - | _ -> - () -end - -module MyOCamlbuildBase = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - (** Base functions for writing myocamlbuild.ml - @author Sylvain Le Gall - *) - - - open Ocamlbuild_plugin - module OC = Ocamlbuild_pack.Ocaml_compiler - - - type dir = string - type file = string - type name = string - type tag = string - - - type t = - { - lib_ocaml: (name * dir list * string list) list; - lib_c: (name * dir * file list) list; - flags: (tag list * (spec OASISExpr.choices)) list; - (* Replace the 'dir: include' from _tags by a precise interdepends in - * directory. - *) - includes: (dir * dir list) list; - } - - -(* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - let env_filename = Pathname.basename BaseEnvLight.default_filename - - - let dispatch_combine lst = - fun e -> - List.iter - (fun dispatch -> dispatch e) - lst - - - let tag_libstubs nm = - "use_lib"^nm^"_stubs" - - - let nm_libstubs nm = - nm^"_stubs" - - - let dispatch t e = - let env = BaseEnvLight.load ~allow_empty:true () in - match e with - | Before_options -> - let no_trailing_dot s = - if String.length s >= 1 && s.[0] = '.' then - String.sub s 1 ((String.length s) - 1) - else - s - in - List.iter - (fun (opt, var) -> - try - opt := no_trailing_dot (BaseEnvLight.var_get var env) - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" var) - [ - Options.ext_obj, "ext_obj"; - Options.ext_lib, "ext_lib"; - Options.ext_dll, "ext_dll"; - ] - - | After_rules -> - (* Declare OCaml libraries *) - List.iter - (function - | nm, [], intf_modules -> - ocaml_lib nm; - let cmis = - List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis - | nm, dir :: tl, intf_modules -> - ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> - List.iter - (fun str -> - flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) - ["compile"; "infer_interface"; "doc"]) - tl; - let cmis = - List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] - cmis) - t.lib_ocaml; - - (* Declare directories dependencies, replace "include" in _tags. *) - List.iter - (fun (dir, include_dirs) -> - Pathname.define_context dir include_dirs) - t.includes; - - (* Declare C libraries *) - List.iter - (fun (lib, dir, headers) -> - (* Handle C part of library *) - flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; - A("-l"^(nm_libstubs lib))]); - - flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] - (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - - if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then - flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); - - (* When ocaml link something that use the C library, then one - need that file to be up to date. - This holds both for programs and for libraries. - *) - dep ["link"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - dep ["compile"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - (* TODO: be more specific about what depends on headers *) - (* Depends on .h files *) - dep ["compile"; "c"] - headers; - - (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] - (S[A"-I"; P(dir)]); - ) - t.lib_c; - - (* Add flags *) - List.iter - (fun (tags, cond_specs) -> - let spec = BaseEnvLight.var_choose cond_specs env in - let rec eval_specs = - function - | S lst -> S (List.map eval_specs lst) - | A str -> A (BaseEnvLight.var_expand str env) - | spec -> spec - in - flag tags & (eval_specs spec)) - t.flags - | _ -> - () - - - let dispatch_default conf t = - dispatch_combine - [ - dispatch t; - MyOCamlbuildFindlib.dispatch conf; - ] - - -end - - -# 878 "myocamlbuild.ml" -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = - [ - ("logtk", ["src/core"; "src/core/lib"], []); - ("logtk_proofs", ["src/proofs"], []); - ("logtk_parsers", ["src/parsers"], []); - ("logtk_solving", ["src/solving"], []); - ("logtk_arbitrary", ["src/arbitrary"], []); - ("libzipperposition", ["src/prover"; "src/prover/calculi"], []) - ]; - lib_c = [("logtk", "src/core/", ["src/core/util_stubs.h"])]; - flags = - [ - (["oasis_library_logtk_ccopt"; "compile"], - [ - (OASISExpr.EBool true, - S - [ - A "-ccopt"; - A "-Wextra"; - A "-ccopt"; - A "-Wno-unused-parameter" - ]) - ]) - ]; - includes = - [ - ("tests/bench", ["src/arbitrary"; "src/core"; "src/core/lib"]); - ("tests", - ["src/arbitrary"; "src/core"; "src/core/lib"; "src/parsers"]); - ("src/tools", ["src/core"; "src/core/lib"; "src/parsers"]); - ("src/solving", ["src/core"; "src/core/lib"]); - ("src/prover/lib", - [ - "src/core"; - "src/core/lib"; - "src/parsers"; - "src/proofs"; - "src/prover"; - "src/prover/calculi" - ]); - ("src/prover/calculi", - [ - "src/core"; - "src/core/lib"; - "src/parsers"; - "src/proofs"; - "src/prover"; - "src/prover/lib" - ]); - ("src/prover", - [ - "src/core"; - "src/core/lib"; - "src/parsers"; - "src/proofs"; - "src/prover/calculi"; - "src/prover/lib" - ]); - ("src/proofs", ["src/core"; "src/core/lib"]); - ("src/parsers", ["src/core"; "src/core/lib"]); - ("src/main", - [ - "src/core"; - "src/core/lib"; - "src/parsers"; - "src/prover"; - "src/prover/calculi" - ]); - ("src/hornet", ["src/core"; "src/core/lib"; "src/parsers"]); - ("src/demo/resolution", - ["src/core"; "src/core/lib"; "src/parsers"]); - ("src/core/lib", ["src/core"]); - ("src/core", ["src/core/lib"]); - ("src/arbitrary", ["src/core"; "src/core/lib"]) - ] - } - ;; - -let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} - -let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; - -# 965 "myocamlbuild.ml" -(* OASIS_STOP *) -Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/opam b/opam deleted file mode 100644 index fe414d88a..000000000 --- a/opam +++ /dev/null @@ -1,50 +0,0 @@ -opam-version: "1.2" -name: "zipperposition" -version: "1.4" -maintainer: "simon.cruanes@inria.fr" -author: "Simon Cruanes" -homepage: "https://github.com/c-cube/zipperposition" -build: [ - ["./configure" - "--bindir" "%{bin}%" - "--disable-tests" - "--disable-docs" - "--%{menhir:enable}%-parsers" - "--disable-hornet-prover" - "--enable-zipperposition-prover" - "--disable-solving" - "--disable-qcheck" - "--disable-tools" - ] - [make] -] -install: [make "install"] -remove: [ - ["ocamlfind" "remove" "logtk"] - ["ocamlfind" "remove" "libzipperposition"] - ["rm" "-f" "%{bin}%/zipperposition"] - ["rm" "-f" "%{bin}%/hornet"] -] -depends: [ - "ocamlfind" { build } - "base-bytes" - "base-unix" - "zarith" - "containers" { >= "1.0" } - "sequence" { >= "0.4" } - "msat" { >= "0.5" } - "menhir" {build} -] -depopts: [ - "qcheck" {test} -] -available: [ - ocaml-version >= "4.03.0" -] -conflicts: [ - "logtk" -] -tags: [ "logic" "unification" "term" "superposition" "prover" ] -bug-reports: "https://github.com/c-cube/zipperposition/issues" -dev-repo: "https://github.com/c-cube/zipperposition.git" - diff --git a/setup.ml b/setup.ml deleted file mode 100644 index 9b7e09dd2..000000000 --- a/setup.ml +++ /dev/null @@ -1,10107 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.4.4 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: e674214876b4d7ef36b78560efd40297) *) -(* - Regenerated by OASIS v0.4.10 - Visit http://oasis.forge.ocamlcore.org for more information and - documentation about functions used in this file. -*) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - - - let ns_ str = str - let s_ str = str - let f_ (str: ('a, 'b, 'c, 'd) format4) = str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = [] -end - -module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - !what_idx = String.length what - - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - !what_idx = -1 - - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - - let replace_chars f s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents buf - - let lowercase_ascii = - replace_chars - (fun c -> - if (c >= 'A' && c <= 'Z') then - Char.chr (Char.code c + 32) - else - c) - - let uncapitalize_ascii s = - if s <> "" then - (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - - let uppercase_ascii = - replace_chars - (fun c -> - if (c >= 'a' && c <= 'z') then - Char.chr (Char.code c - 32) - else - c) - - let capitalize_ascii s = - if s <> "" then - (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - -end - -module OASISUtils = struct -(* # 22 "src/oasis/OASISUtils.ml" *) - - - open OASISGettext - - - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end - - - module MapString = MapExt.Make(String) - - - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list = elements - end - end - - - module SetString = SetExt.Make(String) - - - let compare_csl s1 s2 = - String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - let equal s1 s2 = (compare_csl s1 s2) = 0 - let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) - end) - - module SetStringCsl = - SetExt.Make - (struct - type t = string - let compare = compare_csl - end) - - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - OASISString.lowercase_ascii buf - end - - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - - let failwithf fmt = Printf.ksprintf failwith fmt - - - let rec file_location ?pos1 ?pos2 ?lexbuf () = - match pos1, pos2, lexbuf with - | Some p, None, _ | None, Some p, _ -> - file_location ~pos1:p ~pos2:p ?lexbuf () - | Some p1, Some p2, _ -> - let open Lexing in - let fn, lineno = p1.pos_fname, p1.pos_lnum in - let c1 = p1.pos_cnum - p1.pos_bol in - let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in - Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 - | _, _, Some lexbuf -> - file_location - ~pos1:(Lexing.lexeme_start_p lexbuf) - ~pos2:(Lexing.lexeme_end_p lexbuf) - () - | None, None, None -> - s_ "" - - - let failwithpf ?pos1 ?pos2 ?lexbuf fmt = - let loc = file_location ?pos1 ?pos2 ?lexbuf () in - Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt - - -end - -module OASISUnixPath = struct -(* # 22 "src/oasis/OASISUnixPath.ml" *) - - - type unix_filename = string - type unix_dirname = string - - - type host_filename = string - type host_dirname = string - - - let current_dir_name = "." - - - let parent_dir_name = ".." - - - let is_current_dir fn = - fn = current_dir_name || fn = "" - - - let concat f1 f2 = - if is_current_dir f1 then - f2 - else - let f1' = - try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 - in - f1'^"/"^f2 - - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (OASISString.capitalize_ascii base) - - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (OASISString.uncapitalize_ascii base) - - -end - -module OASISHostPath = struct -(* # 22 "src/oasis/OASISHostPath.ml" *) - - - open Filename - open OASISGettext - - - module Unix = OASISUnixPath - - - let make = - function - | [] -> - invalid_arg "OASISHostPath.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - - let of_unix ufn = - match Sys.os_type with - | "Unix" | "Cygwin" -> ufn - | "Win32" -> - make - (List.map - (fun p -> - if p = Unix.current_dir_name then - current_dir_name - else if p = Unix.parent_dir_name then - parent_dir_name - else - p) - (OASISString.nsplit ufn '/')) - | os_type -> - OASISUtils.failwithf - (f_ "Don't know the path format of os_type %S when translating unix \ - filename. %S") - os_type ufn - - -end - -module OASISFileSystem = struct -(* # 22 "src/oasis/OASISFileSystem.ml" *) - - (** File System functions - - @author Sylvain Le Gall - *) - - type 'a filename = string - - class type closer = - object - method close: unit - end - - class type reader = - object - inherit closer - method input: Buffer.t -> int -> unit - end - - class type writer = - object - inherit closer - method output: Buffer.t -> unit - end - - class type ['a] fs = - object - method string_of_filename: 'a filename -> string - method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer - method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader - method file_exists: 'a filename -> bool - method remove: 'a filename -> unit - end - - - module Mode = - struct - let default_in = [Open_rdonly] - let default_out = [Open_wronly; Open_creat; Open_trunc] - - let text_in = Open_text :: default_in - let text_out = Open_text :: default_out - - let binary_in = Open_binary :: default_in - let binary_out = Open_binary :: default_out - end - - let std_length = 4096 (* Standard buffer/read length. *) - let binary_out = Mode.binary_out - let binary_in = Mode.binary_in - - let of_unix_filename ufn = (ufn: 'a filename) - let to_unix_filename fn = (fn: string) - - - let defer_close o f = - try - let r = f o in o#close; r - with e -> - o#close; raise e - - - let stream_of_reader rdr = - let buf = Buffer.create std_length in - let pos = ref 0 in - let eof = ref false in - let rec next idx = - let bpos = idx - !pos in - if !eof then begin - None - end else if bpos < Buffer.length buf then begin - Some (Buffer.nth buf bpos) - end else begin - pos := !pos + Buffer.length buf; - Buffer.clear buf; - begin - try - rdr#input buf std_length; - with End_of_file -> - if Buffer.length buf = 0 then - eof := true - end; - next idx - end - in - Stream.from next - - - let read_all buf rdr = - try - while true do - rdr#input buf std_length - done - with End_of_file -> - () - - class ['a] host_fs rootdir : ['a] fs = - object (self) - method private host_filename fn = Filename.concat rootdir fn - method string_of_filename = self#host_filename - - method open_out ?(mode=Mode.text_out) ?(perm=0o666) fn = - let chn = open_out_gen mode perm (self#host_filename fn) in - object - method close = close_out chn - method output buf = Buffer.output_buffer chn buf - end - - method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn = - (* TODO: use Buffer.add_channel when minimal version of OCaml will - * be >= 4.03.0 (previous version was discarding last chars). - *) - let chn = open_in_gen mode perm (self#host_filename fn) in - let strm = Stream.of_channel chn in - object - method close = close_in chn - method input buf len = - let read = ref 0 in - try - for _i = 0 to len do - Buffer.add_char buf (Stream.next strm); - incr read - done - with Stream.Failure -> - if !read = 0 then - raise End_of_file - end - - method file_exists fn = Sys.file_exists (self#host_filename fn) - method remove fn = Sys.remove (self#host_filename fn) - end - -end - -module OASISContext = struct -(* # 22 "src/oasis/OASISContext.ml" *) - - - open OASISGettext - - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - - type source - type source_filename = source OASISFileSystem.filename - - - let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn - - - type t = - { - (* TODO: replace this by a proplist. *) - quiet: bool; - info: bool; - debug: bool; - ignore_plugins: bool; - ignore_unknown_fields: bool; - printf: level -> string -> unit; - srcfs: source OASISFileSystem.fs; - load_oasis_plugin: string -> bool; - } - - - let printf lvl str = - let beg = - match lvl with - | `Error -> s_ "E: " - | `Warning -> s_ "W: " - | `Info -> s_ "I: " - | `Debug -> s_ "D: " - in - prerr_endline (beg^str) - - - let default = - ref - { - quiet = false; - info = false; - debug = false; - ignore_plugins = false; - ignore_unknown_fields = false; - printf = printf; - srcfs = new OASISFileSystem.host_fs(Sys.getcwd ()); - load_oasis_plugin = (fun _ -> false); - } - - - let quiet = - {!default with quiet = true} - - - let fspecs () = - (* TODO: don't act on default. *) - let ignore_plugins = ref false in - ["-quiet", - Arg.Unit (fun () -> default := {!default with quiet = true}), - s_ " Run quietly"; - - "-info", - Arg.Unit (fun () -> default := {!default with info = true}), - s_ " Display information message"; - - - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - s_ " Output debug message"; - - "-ignore-plugins", - Arg.Set ignore_plugins, - s_ " Ignore plugin's field."; - - "-C", - Arg.String - (fun str -> - Sys.chdir str; - default := {!default with srcfs = new OASISFileSystem.host_fs str}), - s_ "dir Change directory before running (affects setup.{data,log})."], - fun () -> {!default with ignore_plugins = !ignore_plugins} -end - -module PropList = struct -(* # 22 "src/oasis/PropList.ml" *) - - - open OASISGettext - - - type name = string - - - exception Not_set of name * string option - exception No_printer of name - exception Unknown_field of name * name - - - let () = - Printexc.register_printer - (function - | Not_set (nm, Some rsn) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) - | Not_set (nm, None) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set") nm) - | No_printer nm -> - Some - (Printf.sprintf (f_ "No default printer for value %s") nm) - | Unknown_field (nm, schm) -> - Some - (Printf.sprintf - (f_ "Field %s is not defined in schema %s") nm schm) - | _ -> - None) - - - module Data = - struct - type t = - (name, unit -> unit) Hashtbl.t - - let create () = - Hashtbl.create 13 - - let clear t = - Hashtbl.clear t - - -(* # 77 "src/oasis/PropList.ml" *) - end - - - module Schema = - struct - type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } - - type ('ctxt, 'extra) t = - { - name: name; - fields: (name, ('ctxt, 'extra) value) Hashtbl.t; - order: name Queue.t; - name_norm: string -> string; - } - - let create ?(case_insensitive=false) nm = - { - name = nm; - fields = Hashtbl.create 13; - order = Queue.create (); - name_norm = - (if case_insensitive then - OASISString.lowercase_ascii - else - fun s -> s); - } - - let add t nm set get extra help = - let key = - t.name_norm nm - in - - if Hashtbl.mem t.fields key then - failwith - (Printf.sprintf - (f_ "Field '%s' is already defined in schema '%s'") - nm t.name); - Hashtbl.add - t.fields - key - { - set = set; - get = get; - help = help; - extra = extra; - }; - Queue.add nm t.order - - let mem t nm = - Hashtbl.mem t.fields nm - - let find t nm = - try - Hashtbl.find t.fields (t.name_norm nm) - with Not_found -> - raise (Unknown_field (nm, t.name)) - - let get t data nm = - (find t nm).get data - - let set t data nm ?context x = - (find t nm).set - data - ?context - x - - let fold f acc t = - Queue.fold - (fun acc k -> - let v = - find t k - in - f acc k v.extra v.help) - acc - t.order - - let iter f t = - fold - (fun () -> f) - () - t - - let name t = - t.name - end - - - module Field = - struct - type ('ctxt, 'value, 'extra) t = - { - set: Data.t -> ?context:'ctxt -> 'value -> unit; - get: Data.t -> 'value; - sets: Data.t -> ?context:'ctxt -> string -> unit; - gets: Data.t -> string; - help: (unit -> string) option; - extra: 'extra; - } - - let new_id = - let last_id = - ref 0 - in - fun () -> incr last_id; !last_id - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - (* Default value container *) - let v = - ref None - in - - (* If name is not given, create unique one *) - let nm = - match name with - | Some s -> s - | None -> Printf.sprintf "_anon_%d" (new_id ()) - in - - (* Last chance to get a value: the default *) - let default () = - match default with - | Some d -> d - | None -> raise (Not_set (nm, Some (s_ "no default value"))) - in - - (* Get data *) - let get data = - (* Get value *) - try - (Hashtbl.find data nm) (); - match !v with - | Some x -> x - | None -> default () - with Not_found -> - default () - in - - (* Set data *) - let set data ?context x = - let x = - match update with - | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end - | None -> - x - in - Hashtbl.replace - data - nm - (fun () -> v := Some x) - in - - (* Parse string value, if possible *) - let parse = - match parse with - | Some f -> - f - | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) - in - - (* Set data, from string *) - let sets data ?context s = - set ?context data (parse ?context s) - in - - (* Output value as string, if possible *) - let print = - match print with - | Some f -> - f - | None -> - fun _ -> raise (No_printer nm) - in - - (* Get data, as a string *) - let gets data = - print (get data) - in - - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; - - { - set = set; - get = get; - sets = sets; - gets = gets; - help = help; - extra = extra; - } - - let fset data t ?context x = - t.set data ?context x - - let fget data t = - t.get data - - let fsets data t ?context s = - t.sets data ?context s - - let fgets data t = - t.gets data - end - - - module FieldRO = - struct - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = - Field.create ?schema ?name ?parse ?print ?default ?update ?help extra - in - fun data -> Field.fget data fld - end -end - -module OASISMessage = struct -(* # 22 "src/oasis/OASISMessage.ml" *) - - - open OASISGettext - open OASISContext - - - let generic_message ~ctxt lvl fmt = - let cond = - if ctxt.quiet then - false - else - match lvl with - | `Debug -> ctxt.debug - | `Info -> ctxt.info - | _ -> true - in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt - - - let debug ~ctxt fmt = - generic_message ~ctxt `Debug fmt - - - let info ~ctxt fmt = - generic_message ~ctxt `Info fmt - - - let warning ~ctxt fmt = - generic_message ~ctxt `Warning fmt - - - let error ~ctxt fmt = - generic_message ~ctxt `Error fmt - -end - -module OASISVersion = struct -(* # 22 "src/oasis/OASISVersion.ml" *) - - - open OASISGettext - - - type t = string - - - type comparator = - | VGreater of t - | VGreaterEqual of t - | VEqual of t - | VLesser of t - | VLesserEqual of t - | VOr of comparator * comparator - | VAnd of comparator * comparator - - - (* Range of allowed characters *) - let is_digit c = '0' <= c && c <= '9' - let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false - - - let rec version_compare v1 v2 = - if v1 <> "" || v2 <> "" then - begin - (* Compare ascii string, using special meaning for version - * related char - *) - let val_ascii c = - if c = '~' then -1 - else if is_digit c then 0 - else if c = '\000' then 0 - else if is_alpha c then Char.code c - else (Char.code c) + 256 - in - - let len1 = String.length v1 in - let len2 = String.length v2 in - - let p = ref 0 in - - (** Compare ascii part *) - let compare_vascii () = - let cmp = ref 0 in - while !cmp = 0 && - !p < len1 && !p < len2 && - not (is_digit v1.[!p] && is_digit v2.[!p]) do - cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); - incr p - done; - if !cmp = 0 && !p < len1 && !p = len2 then - val_ascii v1.[!p] - else if !cmp = 0 && !p = len1 && !p < len2 then - - (val_ascii v2.[!p]) - else - !cmp - in - - (** Compare digit part *) - let compare_digit () = - let extract_int v p = - let start_p = !p in - while !p < String.length v && is_digit v.[!p] do - incr p - done; - let substr = - String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with - | "" -> 0 - | s -> int_of_string s - in - res, substr - in - let i1, tl1 = extract_int v1 (ref !p) in - let i2, tl2 = extract_int v2 (ref !p) in - i1 - i2, tl1, tl2 - in - - match compare_vascii () with - | 0 -> - begin - match compare_digit () with - | 0, tl1, tl2 -> - if tl1 <> "" && is_digit tl1.[0] then - 1 - else if tl2 <> "" && is_digit tl2.[0] then - -1 - else - version_compare tl1 tl2 - | n, _, _ -> - n - end - | n -> - n - end - else begin - 0 - end - - - let version_of_string str = str - - - let string_of_version t = t - - - let chop t = - try - let pos = - String.rindex t '.' - in - String.sub t 0 pos - with Not_found -> - t - - - let rec comparator_apply v op = - match op with - | VGreater cv -> - (version_compare v cv) > 0 - | VGreaterEqual cv -> - (version_compare v cv) >= 0 - | VLesser cv -> - (version_compare v cv) < 0 - | VLesserEqual cv -> - (version_compare v cv) <= 0 - | VEqual cv -> - (version_compare v cv) = 0 - | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) - | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) - - - let rec string_of_comparator = - function - | VGreater v -> "> "^(string_of_version v) - | VEqual v -> "= "^(string_of_version v) - | VLesser v -> "< "^(string_of_version v) - | VGreaterEqual v -> ">= "^(string_of_version v) - | VLesserEqual v -> "<= "^(string_of_version v) - | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) - - - let rec varname_of_comparator = - let concat p v = - OASISUtils.varname_concat - p - (OASISUtils.varname_of_string - (string_of_version v)) - in - function - | VGreater v -> concat "gt" v - | VLesser v -> concat "lt" v - | VEqual v -> concat "eq" v - | VGreaterEqual v -> concat "ge" v - | VLesserEqual v -> concat "le" v - | VOr (c1, c2) -> - (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) - | VAnd (c1, c2) -> - (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - - -end - -module OASISLicense = struct -(* # 22 "src/oasis/OASISLicense.ml" *) - - - (** License for _oasis fields - @author Sylvain Le Gall - *) - - - type license = string - type license_exception = string - - - type license_version = - | Version of OASISVersion.t - | VersionOrLater of OASISVersion.t - | NoVersion - - - type license_dep_5_unit = - { - license: license; - excption: license_exception option; - version: license_version; - } - - - type license_dep_5 = - | DEP5Unit of license_dep_5_unit - | DEP5Or of license_dep_5 list - | DEP5And of license_dep_5 list - - - type t = - | DEP5License of license_dep_5 - | OtherLicense of string (* URL *) - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - open OASISGettext - open OASISUtils - - - type test = string - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - type t = elt list - -end - -module OASISSourcePatterns = struct -(* # 22 "src/oasis/OASISSourcePatterns.ml" *) - - open OASISUtils - open OASISGettext - - module Templater = - struct - (* TODO: use this module in BaseEnv.var_expand and BaseFileAB, at least. *) - type t = - { - atoms: atom list; - origin: string - } - and atom = - | Text of string - | Expr of expr - and expr = - | Ident of string - | String of string - | Call of string * expr - - - type env = - { - variables: string MapString.t; - functions: (string -> string) MapString.t; - } - - - let eval env t = - let rec eval_expr env = - function - | String str -> str - | Ident nm -> - begin - try - MapString.find nm env.variables - with Not_found -> - (* TODO: add error location within the string. *) - failwithf - (f_ "Unable to find variable %S in source pattern %S") - nm t.origin - end - - | Call (fn, expr) -> - begin - try - (MapString.find fn env.functions) (eval_expr env expr) - with Not_found -> - (* TODO: add error location within the string. *) - failwithf - (f_ "Unable to find function %S in source pattern %S") - fn t.origin - end - in - String.concat "" - (List.map - (function - | Text str -> str - | Expr expr -> eval_expr env expr) - t.atoms) - - - let parse env s = - let lxr = Genlex.make_lexer [] in - let parse_expr s = - let st = lxr (Stream.of_string s) in - match Stream.npeek 3 st with - | [Genlex.Ident fn; Genlex.Ident nm] -> Call(fn, Ident nm) - | [Genlex.Ident fn; Genlex.String str] -> Call(fn, String str) - | [Genlex.String str] -> String str - | [Genlex.Ident nm] -> Ident nm - (* TODO: add error location within the string. *) - | _ -> failwithf (f_ "Unable to parse expression %S") s - in - let parse s = - let lst_exprs = ref [] in - let ss = - let buff = Buffer.create (String.length s) in - Buffer.add_substitute - buff - (fun s -> lst_exprs := (parse_expr s) :: !lst_exprs; "\000") - s; - Buffer.contents buff - in - let rec join = - function - | hd1 :: tl1, hd2 :: tl2 -> Text hd1 :: Expr hd2 :: join (tl1, tl2) - | [], tl -> List.map (fun e -> Expr e) tl - | tl, [] -> List.map (fun e -> Text e) tl - in - join (OASISString.nsplit ss '\000', List.rev (!lst_exprs)) - in - let t = {atoms = parse s; origin = s} in - (* We rely on a simple evaluation for checking variables/functions. - It works because there is no if/loop statement. - *) - let _s : string = eval env t in - t - -(* # 144 "src/oasis/OASISSourcePatterns.ml" *) - end - - - type t = Templater.t - - - let env ~modul () = - { - Templater. - variables = MapString.of_list ["module", modul]; - functions = MapString.of_list - [ - "capitalize_file", OASISUnixPath.capitalize_file; - "uncapitalize_file", OASISUnixPath.uncapitalize_file; - ]; - } - - let all_possible_files lst ~path ~modul = - let eval = Templater.eval (env ~modul ()) in - List.fold_left - (fun acc pat -> OASISUnixPath.concat path (eval pat) :: acc) - [] lst - - - let to_string t = t.Templater.origin - - -end - -module OASISTypes = struct -(* # 22 "src/oasis/OASISTypes.ml" *) - - - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string (* TODO: replace everywhere. *) - type host_dirname = string (* TODO: replace everywhere. *) - type host_filename = string (* TODO: replace everywhere. *) - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - - - type findlib_name = string - type findlib_full = string - - - type compiled_object = - | Byte - | Native - | Best - - - type dependency = - | FindlibPackage of findlib_full * OASISVersion.comparator option - | InternalLibrary of name - - - type tool = - | ExternalTool of name - | InternalExecutable of name - - - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch - | Monotone - | OtherVCS of url - - - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] - - - type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] - - - type 'a plugin = 'a * name * OASISVersion.t option - - - type all_plugin = plugin_kind plugin - - - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list - - - type 'a conditional = 'a OASISExpr.choices - - - type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } - - - type common_section = - { - cs_name: name; - cs_data: PropList.Data.t; - cs_plugin_data: plugin_data; - } - - - type build_section = - { - bs_build: bool conditional; - bs_install: bool conditional; - bs_path: unix_dirname; - bs_compiled_object: compiled_object; - bs_build_depends: dependency list; - bs_build_tools: tool list; - bs_interface_patterns: OASISSourcePatterns.t list; - bs_implementation_patterns: OASISSourcePatterns.t list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_findlib_extra_files: unix_filename list; - bs_ccopt: args conditional; - bs_cclib: args conditional; - bs_dlllib: args conditional; - bs_dllpath: args conditional; - bs_byteopt: args conditional; - bs_nativeopt: args conditional; - } - - - type library = - { - lib_modules: string list; - lib_pack: bool; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_directory: unix_dirname option; - lib_findlib_containers: findlib_name list; - } - - - type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - obj_findlib_directory: unix_dirname option; - } - - - type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } - - - type flag = - { - flag_description: string option; - flag_default: bool conditional; - } - - - type source_repository = - { - src_repo_type: vcs; - src_repo_location: url; - src_repo_browser: url option; - src_repo_module: string option; - src_repo_branch: string option; - src_repo_tag: string option; - src_repo_subdir: unix_filename option; - } - - - type test = - { - test_type: [`Test] plugin; - test_command: command_line conditional; - test_custom: custom; - test_working_directory: unix_filename option; - test_run: bool conditional; - test_tools: tool list; - } - - - type doc_format = - | HTML of unix_filename (* TODO: source filename. *) - | DocText - | PDF - | PostScript - | Info of unix_filename (* TODO: source filename. *) - | DVI - | OtherDoc - - - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; (* TODO: dest filename ?. *) - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - (* TODO: src filename. *) - doc_data_files: (unix_filename * unix_filename option) list; - doc_build_tools: tool list; - } - - - type section = - | Library of common_section * build_section * library - | Object of common_section * build_section * object_ - | Executable of common_section * build_section * executable - | Flag of common_section * flag - | SrcRepo of common_section * source_repository - | Test of common_section * test - | Doc of common_section * doc - - - type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; (* TODO: source filename. *) - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - bugreports: url option; - synopsis: string; - description: OASISText.t option; - tags: string list; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; (* TODO: source filename. *) - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; (* TODO: source filename. *) - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - - -end - -module OASISFeatures = struct -(* # 22 "src/oasis/OASISFeatures.ml" *) - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISVersion - - module MapPlugin = - Map.Make - (struct - type t = plugin_kind * name - let compare = Pervasives.compare - end) - - module Data = - struct - type t = - { - oasis_version: OASISVersion.t; - plugin_versions: OASISVersion.t option MapPlugin.t; - alpha_features: string list; - beta_features: string list; - } - - let create oasis_version alpha_features beta_features = - { - oasis_version = oasis_version; - plugin_versions = MapPlugin.empty; - alpha_features = alpha_features; - beta_features = beta_features - } - - let of_package pkg = - create - pkg.OASISTypes.oasis_version - pkg.OASISTypes.alpha_features - pkg.OASISTypes.beta_features - - let add_plugin (plugin_kind, plugin_name, plugin_version) t = - {t with - plugin_versions = MapPlugin.add - (plugin_kind, plugin_name) - plugin_version - t.plugin_versions} - - let plugin_version plugin_kind plugin_name t = - MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version (t:t).oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) - end - - type origin = - | Field of string * string - | Section of string - | NoOrigin - - type stage = Alpha | Beta - - - let string_of_stage = - function - | Alpha -> "alpha" - | Beta -> "beta" - - - let field_of_stage = - function - | Alpha -> "AlphaFeatures" - | Beta -> "BetaFeatures" - - type publication = InDev of stage | SinceVersion of OASISVersion.t - - type t = - { - name: string; - plugin: all_plugin option; - publication: publication; - description: unit -> string; - } - - (* TODO: mutex protect this. *) - let all_features = Hashtbl.create 13 - - - let since_version ver_str = SinceVersion (version_of_string ver_str) - let alpha = InDev Alpha - let beta = InDev Beta - - - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - (t:t).name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - - let data_check t data origin = - let no_message = "no message" in - - let check_feature features stage = - let has_feature = List.mem (t:t).name features in - if not has_feature then - match (origin:origin) with - | Field (fld, where) -> - Some - (Printf.sprintf - (f_ "Field %s in %s is only available when feature %s \ - is in field %s.") - fld where t.name (field_of_stage stage)) - | Section sct -> - Some - (Printf.sprintf - (f_ "Section %s is only available when features %s \ - is in field %s.") - sct t.name (field_of_stage stage)) - | NoOrigin -> - Some no_message - else - None - in - - let version_is_good ~min_version version fmt = - let version_is_good = - OASISVersion.comparator_apply - version (OASISVersion.VGreaterEqual min_version) - in - Printf.ksprintf - (fun str -> if version_is_good then None else Some str) - fmt - in - - match origin, t.plugin, t.publication with - | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha - | _, _, InDev Beta -> check_feature data.Data.beta_features Beta - | Field(fld, where), None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Field %s in %s is only valid since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking \ - OASIS changelog.") - fld where (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Field(fld, where), Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Field %s in %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - fld where plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Field %s in %s is only valid when the OASIS plugin %s \ - is defined.") - fld where plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Field %s in %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - fld where plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | Section sct, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Section %s is only valid for since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking OASIS \ - changelog.") - sct (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Section sct, Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Section %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - sct plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Section %s is only valid when the OASIS plugin %s \ - is defined.") - sct plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Section %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - sct plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | NoOrigin, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version "%s" no_message - - | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> - begin - try - let plugin_version_current = - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> raise Not_found - in - version_is_good ~min_version plugin_version_current - "%s" no_message - with Not_found -> - Some no_message - end - - - let data_assert t data origin = - match data_check t data origin with - | None -> () - | Some str -> failwith str - - - let data_test t data = - match data_check t data NoOrigin with - | None -> true - | Some _ -> false - - - let package_test t pkg = - data_test t (Data.of_package pkg) - - - let create ?plugin name publication description = - let () = - if Hashtbl.mem all_features name then - failwithf "Feature '%s' is already declared." name - in - let t = - { - name = name; - plugin = plugin; - publication = publication; - description = description; - } - in - Hashtbl.add all_features name t; - t - - - let get_stage name = - try - (Hashtbl.find all_features name).publication - with Not_found -> - failwithf (f_ "Feature %s doesn't exist.") name - - - let list () = - Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] - - (* - * Real flags. - *) - - - let features = - create "features_fields" - (since_version "0.4") - (fun () -> - s_ "Enable to experiment not yet official features.") - - - let flag_docs = - create "flag_docs" - (since_version "0.3") - (fun () -> - s_ "Make building docs require '-docs' flag at configure.") - - - let flag_tests = - create "flag_tests" - (since_version "0.3") - (fun () -> - s_ "Make running tests require '-tests' flag at configure.") - - - let pack = - create "pack" - (since_version "0.3") - (fun () -> - s_ "Allow to create packed library.") - - - let section_object = - create "section_object" beta - (fun () -> - s_ "Implement an object section.") - - - let dynrun_for_release = - create "dynrun_for_release" alpha - (fun () -> - s_ "Make '-setup-update dynamic' suitable for releasing project.") - - - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "Compile the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allow the OASIS section comments and digests to be omitted in \ - generated files.") - - let no_automatic_syntax = - create "no_automatic_syntax" alpha - (fun () -> - s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ - that matches the internal heuristic (if a dependency ends with \ - a .syntax or is a well known syntax).") - - let findlib_directory = - create "findlib_directory" beta - (fun () -> - s_ "Allow to install findlib libraries in sub-directories of the target \ - findlib directory.") - - let findlib_extra_files = - create "findlib_extra_files" beta - (fun () -> - s_ "Allow to install extra files for findlib libraries.") - - let source_patterns = - create "source_patterns" alpha - (fun () -> - s_ "Customize mapping between module name and source file.") -end - -module OASISSection = struct -(* # 22 "src/oasis/OASISSection.ml" *) - - - open OASISTypes - - - let section_kind_common = - function - | Library (cs, _, _) -> - `Library, cs - | Object (cs, _, _) -> - `Object, cs - | Executable (cs, _, _) -> - `Executable, cs - | Flag (cs, _) -> - `Flag, cs - | SrcRepo (cs, _) -> - `SrcRepo, cs - | Test (cs, _) -> - `Test, cs - | Doc (cs, _) -> - `Doc, cs - - - let section_common sct = - snd (section_kind_common sct) - - - let section_common_set cs = - function - | Library (_, bs, lib) -> Library (cs, bs, lib) - | Object (_, bs, obj) -> Object (cs, bs, obj) - | Executable (_, bs, exec) -> Executable (cs, bs, exec) - | Flag (_, flg) -> Flag (cs, flg) - | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) - | Test (_, tst) -> Test (cs, tst) - | Doc (_, doc) -> Doc (cs, doc) - - - (** Key used to identify section - *) - let section_id sct = - let k, cs = - section_kind_common sct - in - k, cs.cs_name - - - let string_of_section_kind = - function - | `Library -> "library" - | `Object -> "object" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc" - - - let string_of_section sct = - let k, nm = section_id sct in - (string_of_section_kind k)^" "^nm - - - let section_find id scts = - List.find - (fun sct -> id = section_id sct) - scts - - - module CSection = - struct - type t = section - - let id = section_id - - let compare t1 t2 = - compare (id t1) (id t2) - - let equal t1 t2 = - (id t1) = (id t2) - - let hash t = - Hashtbl.hash (id t) - end - - - module MapSection = Map.Make(CSection) - module SetSection = Set.Make(CSection) - - -end - -module OASISBuildSection = struct -(* # 22 "src/oasis/OASISBuildSection.ml" *) - - open OASISTypes - - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists bs modul = - let possible_lst = - OASISSourcePatterns.all_possible_files - (bs.bs_interface_patterns @ bs.bs_implementation_patterns) - ~path:bs.bs_path - ~modul - in - match List.filter source_file_exists possible_lst with - | (fn :: _) as fn_lst -> `Sources (OASISUnixPath.chop_extension fn, fn_lst) - | [] -> - let open OASISUtils in - let _, rev_lst = - List.fold_left - (fun (set, acc) fn -> - let base_fn = OASISUnixPath.chop_extension fn in - if SetString.mem base_fn set then - set, acc - else - SetString.add base_fn set, base_fn :: acc) - (SetString.empty, []) possible_lst - in - `No_sources (List.rev rev_lst) - - -end - -module OASISExecutable = struct -(* # 22 "src/oasis/OASISExecutable.ml" *) - - - open OASISTypes - - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = - OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.dirname exec.exec_main_is) - in - let is_native_exec = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native () - | Byte -> false - in - - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), - - if not is_native_exec && - not exec.exec_custom && - bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) - else - None - - -end - -module OASISLibrary = struct -(* # 22 "src/oasis/OASISLibrary.ml" *) - - - open OASISTypes - open OASISGettext - - let find_module ~ctxt source_file_exists cs bs modul = - match OASISBuildSection.find_module source_file_exists bs modul with - | `Sources _ as res -> res - | `No_sources _ as res -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching module '%s' in library %s.") - modul cs.cs_name; - OASISMessage.warning - ~ctxt - (f_ "Use InterfacePatterns or ImplementationPatterns to define \ - this file with feature %S.") - (OASISFeatures.source_patterns.OASISFeatures.name); - res - - let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (base_fn, lst) -> (base_fn, lst) :: acc - | `No_sources _ -> acc) - [] - (lib.lib_modules @ lib.lib_internal_modules) - - - let generated_unix_files - ~ctxt - ~is_native - ~has_native_dynlink - ~ext_lib - ~ext_dll - ~source_file_exists - (cs, bs, lib) = - - let find_modules lst ext = - let find_module modul = - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (_, [fn]) when ext <> "cmi" - && Filename.check_suffix fn ".mli" -> - None (* No implementation files for pure interface. *) - | `Sources (base_fn, _) -> Some [base_fn] - | `No_sources lst -> Some lst - in - List.fold_left - (fun acc nm -> - match find_module nm with - | None -> acc - | Some base_fns -> - List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) - [] - lst - in - - (* The .cmx that be compiled along *) - let cmxs = - let should_be_built = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false - in - if should_be_built then - if lib.lib_pack then - find_modules - [cs.cs_name] - "cmx" - else - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" - else - [] - in - - let acc_nopath = - [] - in - - (* The headers and annot/cmt files that should be compiled along *) - let headers = - let sufx = - if lib.lib_pack - then [".cmti"; ".cmt"; ".annot"] - else [".cmi"; ".cmti"; ".cmt"; ".annot"] - in - List.map - (List.fold_left - (fun accu s -> - let dot = String.rindex s '.' in - let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu) - []) - (find_modules lib.lib_modules "cmi") - in - - (* Compute what libraries should be built *) - let acc_nopath = - (* Add the packed header file if required *) - let add_pack_header acc = - if lib.lib_pack then - [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc - else - acc - in - let byte acc = - add_pack_header ([cs.cs_name^".cma"] :: acc) - in - let native acc = - let acc = - add_pack_header - (if has_native_dynlink then - [cs.cs_name^".cmxs"] :: acc - else acc) - in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc - in - match bs.bs_compiled_object with - | Native -> byte (native acc_nopath) - | Best when is_native -> byte (native acc_nopath) - | Byte | Best -> byte acc_nopath - in - - (* Add C library to be built *) - let acc_nopath = - if bs.bs_c_sources <> [] then begin - ["lib"^cs.cs_name^"_stubs"^ext_lib] - :: - if has_native_dynlink then - ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath - else - acc_nopath - end else begin - acc_nopath - end - in - - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - (headers @ cmxs) - - -end - -module OASISObject = struct -(* # 22 "src/oasis/OASISObject.ml" *) - - - open OASISTypes - open OASISGettext - - - let find_module ~ctxt source_file_exists cs bs modul = - match OASISBuildSection.find_module source_file_exists bs modul with - | `Sources _ as res -> res - | `No_sources _ as res -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching module '%s' in object %s.") - modul cs.cs_name; - OASISMessage.warning - ~ctxt - (f_ "Use InterfacePatterns or ImplementationPatterns to define \ - this file with feature %S.") - (OASISFeatures.source_patterns.OASISFeatures.name); - res - - let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (base_fn, lst) -> (base_fn, lst) :: acc - | `No_sources _ -> acc) - [] - obj.obj_modules - - - let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = - - let find_module ext modul = - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (base_fn, _) -> [base_fn ^ ext] - | `No_sources lst -> lst - in - - let header, byte, native, c_object, f = - match obj.obj_modules with - | [ m ] -> (find_module ".cmi" m, - find_module ".cmo" m, - find_module ".cmx" m, - find_module ".o" m, - fun x -> x) - | _ -> ([cs.cs_name ^ ".cmi"], - [cs.cs_name ^ ".cmo"], - [cs.cs_name ^ ".cmx"], - [cs.cs_name ^ ".o"], - OASISUnixPath.concat bs.bs_path) - in - List.map (List.map f) ( - match bs.bs_compiled_object with - | Native -> - native :: c_object :: byte :: header :: [] - | Best when is_native -> - native :: c_object :: byte :: header :: [] - | Byte | Best -> - byte :: header :: []) - - -end - -module OASISFindlib = struct -(* # 22 "src/oasis/OASISFindlib.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - - - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - [`Library of library | `Object of object_] * - unix_dirname option * - group_t list) - - - type data = common_section * - build_section * - [`Library of library | `Object of object_] - type tree = - | Node of (data option) * (tree MapString.t) - | Leaf of data - - - let findlib_mapping pkg = - (* Map from library name to either full findlib name or parts + parent. *) - let fndlb_parts_of_lib_name = - let fndlb_parts cs lib = - let name = - match lib.lib_findlib_name with - | Some nm -> nm - | None -> cs.cs_name - in - let name = - String.concat "." (lib.lib_findlib_containers @ [name]) - in - name - in - List.fold_left - (fun mp -> - function - | Library (cs, _, lib) -> - begin - let lib_name = cs.cs_name in - let fndlb_parts = fndlb_parts cs lib in - if MapString.mem lib_name mp then - failwithf - (f_ "The library name '%s' is used more than once.") - lib_name; - match lib.lib_findlib_parent with - | Some lib_name_parent -> - MapString.add - lib_name - (`Unsolved (lib_name_parent, fndlb_parts)) - mp - | None -> - MapString.add - lib_name - (`Solved fndlb_parts) - mp - end - - | Object (cs, _, obj) -> - begin - let obj_name = cs.cs_name in - if MapString.mem obj_name mp then - failwithf - (f_ "The object name '%s' is used more than once.") - obj_name; - let findlib_full_name = match obj.obj_findlib_fullname with - | Some ns -> String.concat "." ns - | None -> obj_name - in - MapString.add - obj_name - (`Solved findlib_full_name) - mp - end - - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections - in - - (* Solve the above graph to be only library name to full findlib name. *) - let fndlb_name_of_lib_name = - let rec solve visited mp lib_name lib_name_child = - if SetString.mem lib_name visited then - failwithf - (f_ "Library '%s' is involved in a cycle \ - with regard to findlib naming.") - lib_name; - let visited = SetString.add lib_name visited in - try - match MapString.find lib_name mp with - | `Solved fndlb_nm -> - fndlb_nm, mp - | `Unsolved (lib_nm_parent, post_fndlb_nm) -> - let pre_fndlb_nm, mp = - solve visited mp lib_nm_parent lib_name - in - let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in - fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp - with Not_found -> - failwithf - (f_ "Library '%s', which is defined as the findlib parent of \ - library '%s', doesn't exist.") - lib_name lib_name_child - in - let mp = - MapString.fold - (fun lib_name status mp -> - match status with - | `Solved _ -> - (* Solved initialy, no need to go further *) - mp - | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "" in - mp) - fndlb_parts_of_lib_name - fndlb_parts_of_lib_name - in - MapString.map - (function - | `Solved fndlb_nm -> fndlb_nm - | `Unsolved _ -> assert false) - mp - in - - (* Convert an internal library name to a findlib name. *) - let findlib_name_of_library_name lib_nm = - try - MapString.find lib_nm fndlb_name_of_lib_name - with Not_found -> - raise (InternalLibraryNotFound lib_nm) - in - - (* Add a library to the tree. - *) - let add sct mp = - let fndlb_fullname = - let cs, _, _ = sct in - let lib_name = cs.cs_name in - findlib_name_of_library_name lib_name - in - let rec add_children nm_lst (children: tree MapString.t) = - match nm_lst with - | (hd :: tl) -> - begin - let node = - try - add_node tl (MapString.find hd children) - with Not_found -> - (* New node *) - new_node tl - in - MapString.add hd node children - end - | [] -> - (* Should not have a nameless library. *) - assert false - and add_node tl node = - if tl = [] then - begin - match node with - | Node (None, children) -> - Node (Some sct, children) - | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> - (* TODO: allow to merge Package, i.e. - * archive(byte) = "foo.cma foo_init.cmo" - *) - let cs, _, _ = sct in - failwithf - (f_ "Library '%s' and '%s' have the same findlib name '%s'") - cs.cs_name cs'.cs_name fndlb_fullname - end - else - begin - match node with - | Leaf data -> - Node (Some data, add_children tl MapString.empty) - | Node (data_opt, children) -> - Node (data_opt, add_children tl children) - end - and new_node = - function - | [] -> - Leaf sct - | hd :: tl -> - Node (None, MapString.add hd (new_node tl) MapString.empty) - in - add_children (OASISString.nsplit fndlb_fullname '.') mp - in - - let unix_directory dn lib = - let directory = - match lib with - | `Library lib -> lib.lib_findlib_directory - | `Object obj -> obj.obj_findlib_directory - in - match dn, directory with - | None, None -> None - | None, Some dn | Some dn, None -> Some dn - | Some dn1, Some dn2 -> Some (OASISUnixPath.concat dn1 dn2) - in - - let rec group_of_tree dn mp = - MapString.fold - (fun nm node acc -> - let cur = - match node with - | Node (Some (cs, bs, lib), children) -> - let current_dn = unix_directory dn lib in - Package (nm, cs, bs, lib, current_dn, group_of_tree current_dn children) - | Node (None, children) -> - Container (nm, group_of_tree dn children) - | Leaf (cs, bs, lib) -> - let current_dn = unix_directory dn lib in - Package (nm, cs, bs, lib, current_dn, []) - in - cur :: acc) - mp [] - in - - let group_mp = - List.fold_left - (fun mp -> - function - | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp - | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp - | _ -> - mp) - MapString.empty - pkg.sections - in - - let groups = group_of_tree None group_mp in - - let library_name_of_findlib_name = - lazy begin - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty - end - in - let library_name_of_findlib_name fndlb_nm = - try - MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) - with Not_found -> - raise (FindlibPackageNotFound fndlb_nm) - in - - groups, - findlib_name_of_library_name, - library_name_of_findlib_name - - - let findlib_of_group = - function - | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _, _) -> fndlb_nm - - - let root_of_group grp = - let rec root_lib_aux = - (* We do a DFS in the group. *) - function - | Container (_, children) -> - List.fold_left - (fun res grp -> - if res = None then - root_lib_aux grp - else - res) - None - children - | Package (_, cs, bs, lib, _, _) -> - Some (cs, bs, lib) - in - match root_lib_aux grp with - | Some res -> - res - | None -> - failwithf - (f_ "Unable to determine root library of findlib library '%s'") - (findlib_of_group grp) - - -end - -module OASISFlag = struct -(* # 22 "src/oasis/OASISFlag.ml" *) - - -end - -module OASISPackage = struct -(* # 22 "src/oasis/OASISPackage.ml" *) - - -end - -module OASISSourceRepository = struct -(* # 22 "src/oasis/OASISSourceRepository.ml" *) - - -end - -module OASISTest = struct -(* # 22 "src/oasis/OASISTest.ml" *) - - -end - -module OASISDocument = struct -(* # 22 "src/oasis/OASISDocument.ml" *) - - -end - -module OASISExec = struct -(* # 22 "src/oasis/OASISExec.ml" *) - - - open OASISGettext - open OASISUtils - open OASISMessage - - - (* TODO: I don't like this quote, it is there because $(rm) foo expands to - * 'rm -f' foo... - *) - let run ~ctxt ?f_exit_code ?(quote=true) cmd args = - let cmd = - if quote then - if Sys.os_type = "Win32" then - if String.contains cmd ' ' then - (* Double the 1st double quote... win32... sigh *) - "\""^(Filename.quote cmd) - else - cmd - else - Filename.quote cmd - else - cmd - in - let cmdline = - String.concat " " (cmd :: args) - in - info ~ctxt (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> - failwithf - (f_ "Command '%s' terminated with error code %d") - cmdline i - | Some f, i -> - f i - - - let run_read_output ~ctxt ?f_exit_code cmd args = - let fn = - Filename.temp_file "oasis-" ".txt" - in - try - begin - let () = - run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) - in - let chn = - open_in fn - in - let routput = - ref [] - in - begin - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - end; - close_in chn; - Sys.remove fn; - List.rev !routput - end - with e -> - (try Sys.remove fn with _ -> ()); - raise e - - - let run_read_one_line ~ctxt ?f_exit_code cmd args = - match run_read_output ~ctxt ?f_exit_code cmd args with - | [fst] -> - fst - | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) -end - -module OASISFileUtil = struct -(* # 22 "src/oasis/OASISFileUtil.ml" *) - - - open OASISGettext - - - let file_exists_case fn = - let dirname = Filename.dirname fn in - let basename = Filename.basename fn in - if Sys.file_exists dirname then - if basename = Filename.current_dir_name then - true - else - List.mem - basename - (Array.to_list (Sys.readdir dirname)) - else - false - - - let find_file ?(case_sensitive=true) paths exts = - - (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a, b) - lst2) - lst1) - in - - let rec combined_paths lst = - match lst with - | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a, b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) - | [e] -> - e - | [] -> - [] - in - - let alternatives = - List.map - (fun (p, e) -> - if String.length e > 0 && e.[0] <> '.' then - p ^ "." ^ e - else - p ^ e) - ((combined_paths paths) * exts) - in - List.find (fun file -> - (if case_sensitive then - file_exists_case file - else - Sys.file_exists file) - && not (Sys.is_directory file) - ) alternatives - - - let which ~ctxt prg = - let path_sep = - match Sys.os_type with - | "Win32" -> - ';' - | _ -> - ':' - in - let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in - let exec_ext = - match Sys.os_type with - | "Win32" -> - "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) - | _ -> - [""] - in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext - - - (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when - * Sys.file_exists "src" = true - *) - let ln = - String.length dn - in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn - - - let q = Filename.quote - (**/**) - - - let cp ~ctxt ?(recurse=false) src tgt = - if recurse then - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] - | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] - else - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") - [q src; q tgt] - - - let mkdir ~ctxt tgt = - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") - [q tgt] - - - let rec mkdir_parent ~ctxt f tgt = - let tgt = - fix_dir tgt - in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent ~ctxt f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir ~ctxt tgt - end - end - - - let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end - - - let glob ~ctxt fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if file_exists_case fn then - [fn] - else - [] - end -end - - -# 3159 "setup.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = - let line = ref 1 in - let lexer st = - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - Genlex.make_lexer ["="] st_line - in - let rec read_file lxr mp = - match Stream.npeek 3 lxr with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; - read_file lxr (MapString.add nm value mp) - | [] -> mp - | _ -> - failwith - (Printf.sprintf "Malformed data file '%s' line %d" filename !line) - in - match stream with - | Some st -> read_file (lexer st) MapString.empty - | None -> - if Sys.file_exists filename then begin - let chn = open_in_bin filename in - let st = Stream.of_channel chn in - try - let mp = read_file (lexer st) MapString.empty in - close_in chn; mp - with e -> - close_in chn; raise e - end else if allow_empty then begin - MapString.empty - end else begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let rec var_expand str env = - let buff = Buffer.create ((String.length str) * 2) in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = var_expand (MapString.find name env) env - let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst -end - - -# 3239 "setup.ml" -module BaseContext = struct -(* # 22 "src/base/BaseContext.ml" *) - - (* TODO: get rid of this module. *) - open OASISContext - - - let args () = fst (fspecs ()) - - - let default = default - -end - -module BaseMessage = struct -(* # 22 "src/base/BaseMessage.ml" *) - - - (** Message to user, overrid for Base - @author Sylvain Le Gall - *) - open OASISMessage - open BaseContext - - - let debug fmt = debug ~ctxt:!default fmt - - - let info fmt = info ~ctxt:!default fmt - - - let warning fmt = warning ~ctxt:!default fmt - - - let error fmt = error ~ctxt:!default fmt - -end - -module BaseEnv = struct -(* # 22 "src/base/BaseEnv.ml" *) - - open OASISGettext - open OASISUtils - open OASISContext - open PropList - - - module MapString = BaseEnvLight.MapString - - - type origin_t = - | ODefault - | OGetEnv - | OFileLoad - | OCommandLine - - - type cli_handle_t = - | CLINone - | CLIAuto - | CLIWith - | CLIEnable - | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - - - type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } - - - let schema = Schema.create "environment" - - - (* Environment data *) - let env = Data.create () - - - (* Environment data from file *) - let env_from_file = ref MapString.empty - - - (* Lexer for var *) - let var_lxr = Genlex.make_lexer [] - - - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - OASISHostPath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - OASISHostPath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - - - and var_get name = - let vl = - try - Schema.get schema env name - with Unknown_field _ as e -> - begin - try - MapString.find name !env_from_file - with Not_found -> - raise e - end - in - var_expand vl - - - let var_choose ?printer ?name lst = - OASISExpr.choose - ?printer - ?name - var_get - lst - - - let var_protect vl = - let buff = - Buffer.create (String.length vl) - in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff - - - let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = - - let default = - [ - OFileLoad, (fun () -> MapString.find name !env_from_file); - ODefault, dflt; - OGetEnv, (fun () -> Sys.getenv name); - ] - in - - let extra = - { - hide = hide; - dump = dump; - cli = cli; - arg_help = arg_help; - group = group; - } - in - - (* Try to find a value that can be defined - *) - let var_get_low lst = - let errors, res = - List.fold_left - (fun (errors, res) (_, v) -> - if res = None then - begin - try - errors, Some (v ()) - with - | Not_found -> - errors, res - | Failure rsn -> - (rsn :: errors), res - | e -> - (Printexc.to_string e) :: errors, res - end - else - errors, res) - ([], None) - (List.sort - (fun (o1, _) (o2, _) -> - Pervasives.compare o2 o1) - lst) - in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) - in - - let help = - match short_desc with - | Some fs -> Some fs - | None -> None - in - - let var_get_lst = - FieldRO.create - ~schema - ~name - ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) - ~print:var_get_low - ~default - ~update:(fun ?context:_ x old_x -> x @ old_x) - ?help - extra - in - - fun () -> - var_expand (var_get_low (var_get_lst env)) - - - let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = - if Schema.mem schema name then - begin - (* TODO: look suspsicious, we want to memorize dflt not dflt () *) - Schema.set schema env ~context:ODefault name (dflt ()); - fun () -> var_get name - end - else - begin - var_define - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt - end - - - let var_ignore (_: unit -> string) = () - - - let print_hidden = - var_define - ~hide:true - ~dump:false - ~cli:CLIAuto - ~arg_help:"Print even non-printable variable. (debug)" - "print_hidden" - (fun () -> "false") - - - let var_all () = - List.rev - (Schema.fold - (fun acc nm def _ -> - if not def.hide || bool_of_string (print_hidden ()) then - nm :: acc - else - acc) - [] - schema) - - - let default_filename = in_srcdir "setup.data" - - - let load ~ctxt ?(allow_empty=false) ?(filename=default_filename) () = - let open OASISFileSystem in - env_from_file := - let repr_filename = ctxt.srcfs#string_of_filename filename in - if ctxt.srcfs#file_exists filename then begin - let buf = Buffer.create 13 in - defer_close - (ctxt.srcfs#open_in ~mode:binary_in filename) - (read_all buf); - defer_close - (ctxt.srcfs#open_in ~mode:binary_in filename) - (fun rdr -> - OASISMessage.info ~ctxt "Loading environment from %S." repr_filename; - BaseEnvLight.load ~allow_empty - ~filename:(repr_filename) - ~stream:(stream_of_reader rdr) - ()) - end else if allow_empty then begin - BaseEnvLight.MapString.empty - end else begin - failwith - (Printf.sprintf - (f_ "Unable to load environment, the file '%s' doesn't exist.") - repr_filename) - end - - - let unload () = - env_from_file := MapString.empty; - Data.clear env - - - let dump ~ctxt ?(filename=default_filename) () = - let open OASISFileSystem in - defer_close - (ctxt.OASISContext.srcfs#open_out ~mode:binary_out filename) - (fun wrtr -> - let buf = Buffer.create 63 in - let output nm value = - Buffer.add_string buf (Printf.sprintf "%s=%S\n" nm value) - in - let mp_todo = - (* Dump data from schema *) - Schema.fold - (fun mp_todo nm def _ -> - if def.dump then begin - try - output nm (Schema.get schema env nm) - with Not_set _ -> - () - end; - MapString.remove nm mp_todo) - !env_from_file - schema - in - (* Dump data defined outside of schema *) - MapString.iter output mp_todo; - wrtr#output buf) - - let print () = - let printable_vars = - Schema.fold - (fun acc nm def short_descr_opt -> - if not def.hide || bool_of_string (print_hidden ()) then - begin - try - let value = Schema.get schema env nm in - let txt = - match short_descr_opt with - | Some s -> s () - | None -> nm - in - (txt, value) :: acc - with Not_set _ -> - acc - end - else - acc) - [] - schema - in - let max_length = - List.fold_left max 0 - (List.rev_map String.length - (List.rev_map fst printable_vars)) - in - let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in - Printf.printf "\nConfiguration:\n"; - List.iter - (fun (name, value) -> - Printf.printf "%s: %s" name (dot_pad name); - if value = "" then - Printf.printf "\n" - else - Printf.printf " %s\n" value) - (List.rev printable_vars); - Printf.printf "\n%!" - - - let args () = - let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; - - ] - @ - List.flatten - (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in - - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in - - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in - - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in - - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in - - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - let dflt = - if default_value = " [true]" then - s_ " [default: enabled]" - else - s_ " [default: disabled]" - in - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp dflt; - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp dflt - ] - | CLIUser lst -> - lst - in - args :: acc) - [] - schema) -end - -module BaseArgExt = struct -(* # 22 "src/base/BaseArgExt.ml" *) - - - open OASISUtils - open OASISGettext - - - let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in - - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 -end - -module BaseCheck = struct -(* # 22 "src/base/BaseCheck.ml" *) - - - open BaseEnv - open BaseMessage - open OASISUtils - open OASISGettext - - - let prog_best prg prg_lst = - var_redefine - prg - (fun () -> - let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found) - - - let prog prg = - prog_best prg [prg] - - - let prog_opt prg = - prog_best prg [prg^".opt"; prg] - - - let ocamlfind = - prog "ocamlfind" - - - let version - var_prefix - cmp - fversion - () = - (* Really compare version provided *) - let var = - var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) - in - var_redefine - ~hide:true - var - (fun () -> - let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str) - () - - - let package_version pkg = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%v"; pkg] - - - let package ?version_comparator pkg () = - let var = - OASISUtils.varname_concat - "pkg_" - (OASISUtils.varname_of_string pkg) - in - let findlib_dir pkg = - let dir = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%d"; pkg] - in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir - in - let vl = - var_redefine - var - (fun () -> findlib_dir pkg) - () - in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl -end - -module BaseOCamlcConfig = struct -(* # 22 "src/base/BaseOCamlcConfig.ml" *) - - - open BaseEnv - open OASISUtils - open OASISGettext - - - module SMap = Map.Make(String) - - - let ocamlc = - BaseCheck.prog_opt "ocamlc" - - - let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) - *) - let rec split_field mp lst = - match lst with - | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else - ( - mp - ) - with Not_found -> - ( - mp - ) - in - split_field mp tl - | [] -> - mp - in - - let cache = - lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (OASISExec.run_read_output - ~ctxt:!BaseContext.default - (ocamlc ()) ["-config"])) - [])) - in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) - - - let var_define nm = - (* Extract data from ocamlc -config *) - let avlbl_config_get () = - Marshal.from_string - (ocamlc_config_map ()) - 0 - in - let chop_version_suffix s = - try - String.sub s 0 (String.index s '+') - with _ -> - s - in - - let nm_config, value_config = - match nm with - | "ocaml_version" -> - "version", chop_version_suffix - | _ -> nm, (fun x -> x) - in - var_redefine - nm - (fun () -> - try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value_config value - with Not_found -> - failwithf - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ())) - -end - -module BaseStandardVar = struct -(* # 22 "src/base/BaseStandardVar.ml" *) - - - open OASISGettext - open OASISTypes - open BaseCheck - open BaseEnv - - - let ocamlfind = BaseCheck.ocamlfind - let ocamlc = BaseOCamlcConfig.ocamlc - let ocamlopt = prog_opt "ocamlopt" - let ocamlbuild = prog "ocamlbuild" - - - (**/**) - let rpkg = - ref None - - - let pkg_get () = - match !rpkg with - | Some pkg -> pkg - | None -> failwith (s_ "OASIS Package is not set") - - - let var_cond = ref [] - - - let var_define_cond ~since_version f dflt = - let holder = ref (fun () -> dflt) in - let since_version = - OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) - in - var_cond := - (fun ver -> - if OASISVersion.comparator_apply ver since_version then - holder := f ()) :: !var_cond; - fun () -> !holder () - - - (**/**) - - - let pkg_name = - var_define - ~short_desc:(fun () -> s_ "Package name") - "pkg_name" - (fun () -> (pkg_get ()).name) - - - let pkg_version = - var_define - ~short_desc:(fun () -> s_ "Package version") - "pkg_version" - (fun () -> - (OASISVersion.string_of_version (pkg_get ()).version)) - - - let c = BaseOCamlcConfig.var_define - - - let os_type = c "os_type" - let system = c "system" - let architecture = c "architecture" - let ccomp_type = c "ccomp_type" - let ocaml_version = c "ocaml_version" - - - (* TODO: Check standard variable presence at runtime *) - - - let standard_library_default = c "standard_library_default" - let standard_library = c "standard_library" - let standard_runtime = c "standard_runtime" - let bytecomp_c_compiler = c "bytecomp_c_compiler" - let native_c_compiler = c "native_c_compiler" - let model = c "model" - let ext_obj = c "ext_obj" - let ext_asm = c "ext_asm" - let ext_lib = c "ext_lib" - let ext_dll = c "ext_dll" - let default_executable_name = c "default_executable_name" - let systhread_supported = c "systhread_supported" - - - let flexlink = - BaseCheck.prog "flexlink" - - - let flexdll_version = - var_define - ~short_desc:(fun () -> "FlexDLL version (Win32)") - "flexdll_version" - (fun () -> - let lst = - OASISExec.run_read_output ~ctxt:!BaseContext.default - (flexlink ()) ["-help"] - in - match lst with - | line :: _ -> - Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) - | [] -> - raise Not_found) - - - (**/**) - let p name hlp dflt = - var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt - - - let (/) a b = - if os_type () = Sys.os_type then - Filename.concat a b - else if os_type () = "Unix" || os_type () = "Cygwin" then - OASISUnixPath.concat a b - else - OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") - (os_type ()) - (**/**) - - - let prefix = - p "prefix" - (fun () -> s_ "Install architecture-independent files dir") - (fun () -> - match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local") - - - let exec_prefix = - p "exec_prefix" - (fun () -> s_ "Install architecture-dependent files in dir") - (fun () -> "$prefix") - - - let bindir = - p "bindir" - (fun () -> s_ "User executables") - (fun () -> "$exec_prefix"/"bin") - - - let sbindir = - p "sbindir" - (fun () -> s_ "System admin executables") - (fun () -> "$exec_prefix"/"sbin") - - - let libexecdir = - p "libexecdir" - (fun () -> s_ "Program executables") - (fun () -> "$exec_prefix"/"libexec") - - - let sysconfdir = - p "sysconfdir" - (fun () -> s_ "Read-only single-machine data") - (fun () -> "$prefix"/"etc") - - - let sharedstatedir = - p "sharedstatedir" - (fun () -> s_ "Modifiable architecture-independent data") - (fun () -> "$prefix"/"com") - - - let localstatedir = - p "localstatedir" - (fun () -> s_ "Modifiable single-machine data") - (fun () -> "$prefix"/"var") - - - let libdir = - p "libdir" - (fun () -> s_ "Object code libraries") - (fun () -> "$exec_prefix"/"lib") - - - let datarootdir = - p "datarootdir" - (fun () -> s_ "Read-only arch-independent data root") - (fun () -> "$prefix"/"share") - - - let datadir = - p "datadir" - (fun () -> s_ "Read-only architecture-independent data") - (fun () -> "$datarootdir") - - - let infodir = - p "infodir" - (fun () -> s_ "Info documentation") - (fun () -> "$datarootdir"/"info") - - - let localedir = - p "localedir" - (fun () -> s_ "Locale-dependent data") - (fun () -> "$datarootdir"/"locale") - - - let mandir = - p "mandir" - (fun () -> s_ "Man documentation") - (fun () -> "$datarootdir"/"man") - - - let docdir = - p "docdir" - (fun () -> s_ "Documentation root") - (fun () -> "$datarootdir"/"doc"/"$pkg_name") - - - let htmldir = - p "htmldir" - (fun () -> s_ "HTML documentation") - (fun () -> "$docdir") - - - let dvidir = - p "dvidir" - (fun () -> s_ "DVI documentation") - (fun () -> "$docdir") - - - let pdfdir = - p "pdfdir" - (fun () -> s_ "PDF documentation") - (fun () -> "$docdir") - - - let psdir = - p "psdir" - (fun () -> s_ "PS documentation") - (fun () -> "$docdir") - - - let destdir = - p "destdir" - (fun () -> s_ "Prepend a path when installing package") - (fun () -> - raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct")))) - - - let findlib_version = - var_define - "findlib_version" - (fun () -> - BaseCheck.package_version "findlib") - - - let is_native = - var_define - "is_native" - (fun () -> - try - let _s: string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s: string = - ocamlc () - in - "false") - - - let ext_program = - var_define - "suffix_program" - (fun () -> - match os_type () with - | "Win32" | "Cygwin" -> ".exe" - | _ -> "") - - - let rm = - var_define - ~short_desc:(fun () -> s_ "Remove a file.") - "rm" - (fun () -> - match os_type () with - | "Win32" -> "del" - | _ -> "rm -f") - - - let rmdir = - var_define - ~short_desc:(fun () -> s_ "Remove a directory.") - "rmdir" - (fun () -> - match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf") - - - let debug = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") - ~cli:CLIEnable - "debug" - (fun () -> "true") - - - let profile = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") - ~cli:CLIEnable - "profile" - (fun () -> "false") - - - let tests = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") - ~cli:CLIEnable - "tests" - (fun () -> "false")) - "true" - - - let docs = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> s_ "Create documentations") - ~cli:CLIEnable - "docs" - (fun () -> "true")) - "true" - - - let native_dynlink = - var_define - ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") - ~cli:CLINone - "native_dynlink" - (fun () -> - let res = - let ocaml_lt_312 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "3.12.0")) - in - let flexdll_lt_030 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (flexdll_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "0.30")) - in - let has_native_dynlink = - let ocamlfind = ocamlfind () in - try - let fn = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ocamlfind - ["query"; "-predicates"; "native"; "dynlink"; - "-format"; "%d/%a"] - in - Sys.file_exists fn - with _ -> - false - in - if not has_native_dynlink then - false - else if ocaml_lt_312 () then - false - else if (os_type () = "Win32" || os_type () = "Cygwin") - && flexdll_lt_030 () then - begin - BaseMessage.warning - (f_ ".cmxs generation disabled because FlexDLL needs to be \ - at least 0.30. Please upgrade FlexDLL from %s to 0.30.") - (flexdll_version ()); - false - end - else - true - in - string_of_bool res) - - - let init pkg = - rpkg := Some pkg; - List.iter (fun f -> f pkg.oasis_version) !var_cond - -end - -module BaseFileAB = struct -(* # 22 "src/base/BaseFileAB.ml" *) - - - open BaseEnv - open OASISGettext - open BaseMessage - open OASISContext - - - let to_filename fn = - if not (Filename.check_suffix fn ".ab") then - warning (f_ "File '%s' doesn't have '.ab' extension") fn; - OASISFileSystem.of_unix_filename (Filename.chop_extension fn) - - - let replace ~ctxt fn_lst = - let open OASISFileSystem in - let ibuf, obuf = Buffer.create 13, Buffer.create 13 in - List.iter - (fun fn -> - Buffer.clear ibuf; Buffer.clear obuf; - defer_close - (ctxt.srcfs#open_in (of_unix_filename fn)) - (read_all ibuf); - Buffer.add_string obuf (var_expand (Buffer.contents ibuf)); - defer_close - (ctxt.srcfs#open_out (to_filename fn)) - (fun wrtr -> wrtr#output obuf)) - fn_lst -end - -module BaseLog = struct -(* # 22 "src/base/BaseLog.ml" *) - - - open OASISUtils - open OASISContext - open OASISGettext - open OASISFileSystem - - - let default_filename = in_srcdir "setup.log" - - - let load ~ctxt () = - let module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - in - if ctxt.srcfs#file_exists default_filename then begin - defer_close - (ctxt.srcfs#open_in default_filename) - (fun rdr -> - let line = ref 1 in - let lxr = Genlex.make_lexer [] (stream_of_reader rdr) in - let rec read_aux (st, lst) = - match Stream.npeek 2 lxr with - | [Genlex.String e; Genlex.String d] -> - let t = e, d in - Stream.junk lxr; Stream.junk lxr; - if SetTupleString.mem t st then - read_aux (st, lst) - else - read_aux (SetTupleString.add t st, t :: lst) - | [] -> List.rev lst - | _ -> - failwithf - (f_ "Malformed log file '%s' at line %d") - (ctxt.srcfs#string_of_filename default_filename) - !line - in - read_aux (SetTupleString.empty, [])) - end else begin - [] - end - - - let register ~ctxt event data = - defer_close - (ctxt.srcfs#open_out - ~mode:[Open_append; Open_creat; Open_text] - ~perm:0o644 - default_filename) - (fun wrtr -> - let buf = Buffer.create 13 in - Printf.bprintf buf "%S %S\n" event data; - wrtr#output buf) - - - let unregister ~ctxt event data = - let lst = load ~ctxt () in - let buf = Buffer.create 13 in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - Printf.bprintf buf "%S %S\n" e d) - lst; - if Buffer.length buf > 0 then - defer_close - (ctxt.srcfs#open_out default_filename) - (fun wrtr -> wrtr#output buf) - else - ctxt.srcfs#remove default_filename - - - let filter ~ctxt events = - let st_events = SetString.of_list events in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ~ctxt ()) - - - let exists ~ctxt event data = - List.exists - (fun v -> (event, data) = v) - (load ~ctxt ()) -end - -module BaseBuilt = struct -(* # 22 "src/base/BaseBuilt.ml" *) - - - open OASISTypes - open OASISGettext - open BaseStandardVar - open BaseMessage - - - type t = - | BExec (* Executable *) - | BExecLib (* Library coming with executable *) - | BLib (* Library *) - | BObj (* Library *) - | BDoc (* Document *) - - - let to_log_event_file t nm = - "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BObj -> "obj" - | BDoc -> "doc")^ - "_"^nm - - - let to_log_event_done t nm = - "is_"^(to_log_event_file t nm) - - - let register ~ctxt t nm lst = - BaseLog.register ~ctxt (to_log_event_done t nm) "true"; - List.iter - (fun alt -> - let registered = - List.fold_left - (fun registered fn -> - if OASISFileUtil.file_exists_case fn then begin - BaseLog.register ~ctxt - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end else begin - registered - end) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - - let unregister ~ctxt t nm = - List.iter - (fun (e, d) -> BaseLog.unregister ~ctxt e d) - (BaseLog.filter ~ctxt [to_log_event_file t nm; to_log_event_done t nm]) - - - let fold ~ctxt t nm f acc = - List.fold_left - (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then begin - f acc fn - end else begin - warning - (f_ "File '%s' has been marked as built \ - for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> (f_ "executable %s") - | BLib -> (f_ "library %s") - | BObj -> (f_ "object %s") - | BDoc -> (f_ "documentation %s")) - nm); - acc - end) - acc - (BaseLog.filter ~ctxt [to_log_event_file t nm]) - - - let is_built ~ctxt t nm = - List.fold_left - (fun _ (_, d) -> try bool_of_string d with _ -> false) - false - (BaseLog.filter ~ctxt [to_log_event_done t nm]) - - - let of_executable ffn (cs, bs, exec) = - let unix_exec_is, unix_dll_opt = - OASISExecutable.unix_exec_is - (cs, bs, exec) - (fun () -> - bool_of_string - (is_native ())) - ext_dll - ext_program - in - let evs = - (BExec, cs.cs_name, [[ffn unix_exec_is]]) - :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) - in - evs, - unix_exec_is, - unix_dll_opt - - - let of_library ffn (cs, bs, lib) = - let unix_lst = - OASISLibrary.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - ~has_native_dynlink:(bool_of_string (native_dynlink ())) - ~ext_lib:(ext_lib ()) - ~ext_dll:(ext_dll ()) - (cs, bs, lib) - in - let evs = - [BLib, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - - - let of_object ffn (cs, bs, obj) = - let unix_lst = - OASISObject.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - (cs, bs, obj) - in - let evs = - [BObj, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - -end - -module BaseCustom = struct -(* # 22 "src/base/BaseCustom.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let run cmd args extra_args = - OASISExec.run ~ctxt:!BaseContext.default ~quote:false - (var_expand cmd) - (List.map - var_expand - (args @ (Array.to_list extra_args))) - - - let hook ?(failsafe=false) cstm f e = - let optional_command lst = - let printer = - function - | Some (cmd, args) -> String.concat " " (cmd :: args) - | None -> s_ "No command" - in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () - in - let res = - optional_command cstm.pre_command; - f e - in - optional_command cstm.post_command; - res -end - -module BaseDynVar = struct -(* # 22 "src/base/BaseDynVar.ml" *) - - - open OASISTypes - open OASISGettext - open BaseEnv - open BaseBuilt - - - let init ~ctxt pkg = - (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) - (* TODO: provide compile option for library libary_byte_args_VARNAME... *) - List.iter - (function - | Executable (cs, bs, _) -> - if var_choose bs.bs_build then - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - let fn_opt = - fold ~ctxt BExec cs.cs_name (fun _ fn -> Some fn) None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name))))) - - | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) - pkg.sections -end - -module BaseTest = struct -(* # 22 "src/base/BaseTest.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let test ~ctxt lst pkg extra_args = - - let one_test (failure, n) (test_plugin, cs, test) = - if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then - begin - let () = info (f_ "Running test '%s'") cs.cs_name in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = Sys.getcwd () in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd - - | None -> - fun () -> () - in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin ~ctxt pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end - end - else - begin - info (f_ "Skipping test '%s'") cs.cs_name; - (failure, n) - end - in - let failed, n = List.fold_left one_test (0.0, 0) lst in - let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in - let msg = - Printf.sprintf - (f_ "Tests had a %.2f%% failure rate") - (100. *. failure_percent) - in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg; - - (* Possible explanation why the tests where not run. *) - if OASISFeatures.package_test OASISFeatures.flag_tests pkg && - not (bool_of_string (BaseStandardVar.tests ())) && - lst <> [] then - BaseMessage.warning - "Tests are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-tests'" -end - -module BaseDoc = struct -(* # 22 "src/base/BaseDoc.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let doc ~ctxt lst pkg extra_args = - - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then - begin - info (f_ "Building documentation '%s'") cs.cs_name; - BaseCustom.hook - doc.doc_custom - (doc_plugin ~ctxt pkg (cs, doc)) - extra_args - end - in - List.iter one_doc lst; - - if OASISFeatures.package_test OASISFeatures.flag_docs pkg && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" -end - -module BaseSetup = struct -(* # 22 "src/base/BaseSetup.ml" *) - - open OASISContext - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - open OASISUtils - - - type std_args_fun = - ctxt:OASISContext.t -> package -> string array -> unit - - - type ('a, 'b) section_args_fun = - name * - (ctxt:OASISContext.t -> - package -> - (common_section * 'a) -> - string array -> - 'b) - - - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - - (* Associate a plugin function with data from package *) - let join_plugin_sections filter_map lst = - List.rev - (List.fold_left - (fun acc sct -> - match filter_map sct with - | Some e -> - e :: acc - | None -> - acc) - [] - lst) - - - (* Search for plugin data associated with a section name *) - let lookup_plugin_section plugin action nm lst = - try - List.assoc nm lst - with Not_found -> - failwithf - (f_ "Cannot find plugin %s matching section %s for %s action") - plugin - nm - action - - - let configure ~ctxt t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (fun () -> - (* Reload if preconf has changed it *) - begin - try - unload (); - load ~ctxt (); - with _ -> - () - end; - - (* Run plugin's configure *) - t.configure ~ctxt t.package args; - - (* Dump to allow postconf to change it *) - dump ~ctxt ()) - (); - - (* Reload environment *) - unload (); - load ~ctxt (); - - (* Save environment *) - print (); - - (* Replace data in file *) - BaseFileAB.replace ~ctxt t.package.files_ab - - - let build ~ctxt t args = - BaseCustom.hook - t.package.build_custom - (t.build ~ctxt t.package) - args - - - let doc ~ctxt t args = - BaseDoc.doc - ~ctxt - (join_plugin_sections - (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let test ~ctxt t args = - BaseTest.test - ~ctxt - (join_plugin_sections - (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let all ~ctxt t args = - let rno_doc = ref false in - let rno_test = ref false in - let arg_rest = ref [] in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: - (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; - - "--", - Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), - s_ "All arguments for configure."; - ] - (failwithf (f_ "Don't know what to do with '%s'")) - ""; - - info "Running configure step"; - configure ~ctxt t (Array.of_list (List.rev !arg_rest)); - - info "Running build step"; - build ~ctxt t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init ~ctxt t.package; - - if not !rno_doc then begin - info "Running doc step"; - doc ~ctxt t [||] - end else begin - info "Skipping doc step" - end; - if not !rno_test then begin - info "Running test step"; - test ~ctxt t [||] - end else begin - info "Skipping test step" - end - - - let install ~ctxt t args = - BaseCustom.hook t.package.install_custom (t.install ~ctxt t.package) args - - - let uninstall ~ctxt t args = - BaseCustom.hook t.package.uninstall_custom (t.uninstall ~ctxt t.package) args - - - let reinstall ~ctxt t args = - uninstall ~ctxt t args; - install ~ctxt t args - - - let clean, distclean = - let failsafe f a = - try - f a - with e -> - warning - (f_ "Action fail with error: %s") - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - in - - let generic_clean ~ctxt t cstm mains docs tests args = - BaseCustom.hook - ~failsafe:true - cstm - (fun () -> - (* Clean section *) - List.iter - (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun ~ctxt:_ _ _ _ -> () - in - failsafe (f ~ctxt t.package (cs, test)) args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun ~ctxt:_ _ _ _ -> () - in - failsafe (f ~ctxt t.package (cs, doc)) args - | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) - t.package.sections; - (* Clean whole package *) - List.iter (fun f -> failsafe (f ~ctxt t.package) args) mains) - () - in - - let clean ~ctxt t args = - generic_clean - ~ctxt - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean ~ctxt t args = - (* Call clean *) - clean ~ctxt t args; - - (* Call distclean code *) - generic_clean - ~ctxt - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args; - - (* Remove generated source files. *) - List.iter - (fun fn -> - if ctxt.srcfs#file_exists fn then begin - info (f_ "Remove '%s'") (ctxt.srcfs#string_of_filename fn); - ctxt.srcfs#remove fn - end) - ([BaseEnv.default_filename; BaseLog.default_filename] - @ (List.rev_map BaseFileAB.to_filename t.package.files_ab)) - in - - clean, distclean - - - let version ~ctxt:_ (t: t) _ = print_endline t.oasis_version - - - let update_setup_ml, no_update_setup_ml_cli = - let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") - - (* TODO: srcfs *) - let default_oasis_fn = "_oasis" - - - let update_setup_ml t = - let oasis_fn = - match t.oasis_fn with - | Some fn -> fn - | None -> default_oasis_fn - in - let oasis_exec = - match t.oasis_exec with - | Some fn -> fn - | None -> "oasis" - in - let ocaml = - Sys.executable_name - in - let setup_ml, args = - match Array.to_list Sys.argv with - | setup_ml :: args -> - setup_ml, args - | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") - in - let ocaml, setup_ml = - if Sys.executable_name = Sys.argv.(0) then - (* We are not running in standard mode, probably the script - * is precompiled. - *) - "ocaml", "setup.ml" - else - ocaml, setup_ml - in - let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in - let do_update () = - let oasis_exec_version = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | 1 -> - failwithf - (f_ "Executable '%s' is probably an old version \ - of oasis (< 0.3.0), please update to version \ - v%s.") - oasis_exec t.oasis_version - | 127 -> - failwithf - (f_ "Cannot find executable '%s', please install \ - oasis v%s.") - oasis_exec t.oasis_version - | n -> - failwithf - (f_ "Command '%s version' exited with code %d.") - oasis_exec n) - oasis_exec ["version"] - in - if OASISVersion.comparator_apply - (OASISVersion.version_of_string oasis_exec_version) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string t.oasis_version)) then - begin - (* We have a version >= for the executable oasis, proceed with - * update. - *) - (* TODO: delegate this check to 'oasis setup'. *) - if Sys.os_type = "Win32" then - failwithf - (f_ "It is not possible to update the running script \ - setup.ml on Windows. Please update setup.ml by \ - running '%s'.") - (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) - else - begin - OASISExec.run - ~ctxt:!BaseContext.default - ~f_exit_code: - (fun n -> - if n <> 0 then - failwithf - (f_ "Unable to update setup.ml using '%s', \ - please fix the problem and retry.") - oasis_exec) - oasis_exec ("setup" :: t.oasis_setup_args); - OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) - end - end - else - failwithf - (f_ "The version of '%s' (v%s) doesn't match the version of \ - oasis used to generate the %s file. Please install at \ - least oasis v%s.") - oasis_exec oasis_exec_version setup_ml t.oasis_version - in - - if !update_setup_ml then - begin - try - match t.oasis_digest with - | Some dgst -> - if Sys.file_exists oasis_fn && - dgst <> Digest.file default_oasis_fn then - begin - do_update (); - true - end - else - false - | None -> - false - with e -> - error - (f_ "Error when updating setup.ml. If you want to avoid this error, \ - you can bypass the update of %s by running '%s %s %s %s'") - setup_ml ocaml setup_ml no_update_setup_ml_cli - (String.concat " " args); - raise e - end - else - false - - - let setup t = - let catch_exn = ref true in - let act_ref = - ref (fun ~ctxt:_ _ -> - failwithf - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - - in - let extra_args_ref = ref [] in - let allow_empty_env_ref = ref false in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - try - let () = - Arg.parse - (Arg.align - ([ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ - (if t.setup_update then - [no_update_setup_ml_cli] - else - []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n") - in - - (* Instantiate the context. *) - let ctxt = !BaseContext.default in - - (* Build initial environment *) - load ~ctxt ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices))) - in - match hlp with - | Some hlp -> apply ~short_desc:(fun () -> hlp) () - | None -> apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init ~ctxt t.package; - - if not (t.setup_update && update_setup_ml t) then - !act_ref ~ctxt t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - - -end - -module BaseCompat = struct -(* # 22 "src/base/BaseCompat.ml" *) - - (** Compatibility layer to provide a stable API inside setup.ml. - This layer allows OASIS to change in between minor versions - (e.g. 0.4.6 -> 0.4.7) but still provides a stable API inside setup.ml. This - enables to write functions that manipulate setup_t inside setup.ml. See - deps.ml for an example. - - The module opened by default will depend on the version of the _oasis. E.g. - if we have "OASISFormat: 0.3", the module Compat_0_3 will be opened and - the function Compat_0_3 will be called. If setup.ml is generated with the - -nocompat, no module will be opened. - - @author Sylvain Le Gall - *) - - module Compat_0_4 = - struct - let rctxt = ref !BaseContext.default - - module BaseSetup = - struct - module Original = BaseSetup - - open OASISTypes - - type std_args_fun = package -> string array -> unit - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - let setup t = - let mk_std_args_fun f = - fun ~ctxt pkg args -> rctxt := ctxt; f pkg args - in - let mk_section_args_fun l = - List.map - (fun (nm, f) -> - nm, - (fun ~ctxt pkg sct args -> - rctxt := ctxt; - f pkg sct args)) - l - in - let t' = - { - Original. - configure = mk_std_args_fun t.configure; - build = mk_std_args_fun t.build; - doc = mk_section_args_fun t.doc; - test = mk_section_args_fun t.test; - install = mk_std_args_fun t.install; - uninstall = mk_std_args_fun t.uninstall; - clean = List.map mk_std_args_fun t.clean; - clean_doc = mk_section_args_fun t.clean_doc; - clean_test = mk_section_args_fun t.clean_test; - distclean = List.map mk_std_args_fun t.distclean; - distclean_doc = mk_section_args_fun t.distclean_doc; - distclean_test = mk_section_args_fun t.distclean_test; - - package = t.package; - oasis_fn = t.oasis_fn; - oasis_version = t.oasis_version; - oasis_digest = t.oasis_digest; - oasis_exec = t.oasis_exec; - oasis_setup_args = t.oasis_setup_args; - setup_update = t.setup_update; - } - in - Original.setup t' - - end - - let adapt_setup_t setup_t = - let module O = BaseSetup.Original in - let mk_std_args_fun f = fun pkg args -> f ~ctxt:!rctxt pkg args in - let mk_section_args_fun l = - List.map - (fun (nm, f) -> nm, (fun pkg sct args -> f ~ctxt:!rctxt pkg sct args)) - l - in - { - BaseSetup. - configure = mk_std_args_fun setup_t.O.configure; - build = mk_std_args_fun setup_t.O.build; - doc = mk_section_args_fun setup_t.O.doc; - test = mk_section_args_fun setup_t.O.test; - install = mk_std_args_fun setup_t.O.install; - uninstall = mk_std_args_fun setup_t.O.uninstall; - clean = List.map mk_std_args_fun setup_t.O.clean; - clean_doc = mk_section_args_fun setup_t.O.clean_doc; - clean_test = mk_section_args_fun setup_t.O.clean_test; - distclean = List.map mk_std_args_fun setup_t.O.distclean; - distclean_doc = mk_section_args_fun setup_t.O.distclean_doc; - distclean_test = mk_section_args_fun setup_t.O.distclean_test; - - package = setup_t.O.package; - oasis_fn = setup_t.O.oasis_fn; - oasis_version = setup_t.O.oasis_version; - oasis_digest = setup_t.O.oasis_digest; - oasis_exec = setup_t.O.oasis_exec; - oasis_setup_args = setup_t.O.oasis_setup_args; - setup_update = setup_t.O.setup_update; - } - end - - - module Compat_0_3 = - struct - include Compat_0_4 - end - -end - - -# 5662 "setup.ml" -module InternalConfigurePlugin = struct -(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) - - - (** Configure using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open OASISTypes - open OASISUtils - open OASISGettext - open BaseMessage - - - (** Configure build using provided series of check to be done - and then output corresponding file. - *) - let configure ~ctxt:_ pkg argv = - let var_ignore_eval var = let _s: string = var () in () in - let errors = ref SetString.empty in - let buff = Buffer.create 13 in - - let add_errors fmt = - Printf.kbprintf - (fun b -> - errors := SetString.add (Buffer.contents b) !errors; - Buffer.clear b) - buff - fmt - in - - let warn_exception e = - warning "%s" (Printexc.to_string e) - in - - (* Check tools *) - let check_tools lst = - List.iter - (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2; _}, - {bs_build = build; _}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - lst - in - - let build_checks sct bs = - if var_choose bs.bs_build then - begin - if bs.bs_compiled_object = Native then - begin - try - var_ignore_eval BaseStandardVar.ocamlopt - with e -> - warn_exception e; - add_errors - (f_ "Section %s requires native compilation") - (OASISSection.string_of_section sct) - end; - - (* Check tools *) - check_tools bs.bs_build_tools; - - (* Check depends *) - List.iter - (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2; _}, - {bs_build = build; _}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - bs.bs_build_depends - end - in - - (* Parse command line *) - BaseArgExt.parse argv (BaseEnv.args ()); - - (* OCaml version *) - begin - match pkg.ocaml_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Findlib version *) - begin - match pkg.findlib_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - (* Make sure the findlib version is fine for the OCaml compiler. *) - begin - let ocaml_ge4 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.ocaml_version ())) - (OASISVersion.version_of_string "4.0.0") >= 0 in - if ocaml_ge4 then - let findlib_lt132 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) - (OASISVersion.version_of_string "1.3.2") < 0 in - if findlib_lt132 then - add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" - end; - - (* FlexDLL *) - if BaseStandardVar.os_type () = "Win32" || - BaseStandardVar.os_type () = "Cygwin" then - begin - try - var_ignore_eval BaseStandardVar.flexlink - with e -> - warn_exception e; - add_errors (f_ "Cannot find 'flexlink'") - end; - - (* Check build depends *) - List.iter - (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) - pkg.sections; - - (* Check if we need native dynlink (presence of libraries that compile to - native) - *) - begin - let has_cmxa = - List.exists - (function - | Library (_, bs, _) -> - var_choose bs.bs_build && - (bs.bs_compiled_object = Native || - (bs.bs_compiled_object = Best && - bool_of_string (BaseStandardVar.is_native ()))) - | _ -> - false) - pkg.sections - in - if has_cmxa then - var_ignore_eval BaseStandardVar.native_dynlink - end; - - (* Check errors *) - if SetString.empty != !errors then - begin - List.iter - (fun e -> error "%s" e) - (SetString.elements !errors); - failwithf - (fn_ - "%d configuration error" - "%d configuration errors" - (SetString.cardinal !errors)) - (SetString.cardinal !errors) - end - - -end - -module InternalInstallPlugin = struct -(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) - - - (** Install using internal scheme - @author Sylvain Le Gall - *) - - - (* TODO: rewrite this module with OASISFileSystem. *) - - open BaseEnv - open BaseStandardVar - open BaseMessage - open OASISTypes - open OASISFindlib - open OASISGettext - open OASISUtils - - - let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) - let lib_hook = ref (fun (cs, bs, dn, lib) -> cs, bs, dn, lib, []) - let obj_hook = ref (fun (cs, bs, dn, obj) -> cs, bs, dn, obj, []) - let doc_hook = ref (fun (cs, doc) -> cs, doc) - - let install_file_ev = "install-file" - let install_dir_ev = "install-dir" - let install_findlib_ev = "install-findlib" - - - (* TODO: this can be more generic and used elsewhere. *) - let win32_max_command_line_length = 8000 - - - let split_install_command ocamlfind findlib_name meta files = - if Sys.os_type = "Win32" then - (* Arguments for the first command: *) - let first_args = ["install"; findlib_name; meta] in - (* Arguments for remaining commands: *) - let other_args = ["install"; findlib_name; "-add"] in - (* Extract as much files as possible from [files], [len] is - the current command line length: *) - let rec get_files len acc files = - match files with - | [] -> - (List.rev acc, []) - | file :: rest -> - let len = len + 1 + String.length file in - if len > win32_max_command_line_length then - (List.rev acc, files) - else - get_files len (file :: acc) rest - in - (* Split the command into several commands. *) - let rec split args files = - match files with - | [] -> - [] - | _ -> - (* Length of "ocamlfind install [META|-add]" *) - let len = - List.fold_left - (fun len arg -> - len + 1 (* for the space *) + String.length arg) - (String.length ocamlfind) - args - in - match get_files len [] files with - | ([], _) -> - failwith (s_ "Command line too long.") - | (firsts, others) -> - let cmd = args @ firsts in - (* Use -add for remaining commands: *) - let () = - let findlib_ge_132 = - OASISVersion.comparator_apply - (OASISVersion.version_of_string - (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string "1.3.2")) - in - if not findlib_ge_132 then - failwithf - (f_ "Installing the library %s require to use the \ - flag '-add' of ocamlfind because the command \ - line is too long. This flag is only available \ - for findlib 1.3.2. Please upgrade findlib from \ - %s to 1.3.2") - findlib_name (BaseStandardVar.findlib_version ()) - in - let cmds = split other_args others in - cmd :: cmds - in - (* The first command does not use -add: *) - split first_args files - else - ["install" :: findlib_name :: meta :: files] - - - let install = - - let in_destdir fn = - try - (* Practically speaking destdir is prepended at the beginning of the - target filename - *) - (destdir ())^fn - with PropList.Not_set _ -> - fn - in - - let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir = - let tgt_dir = - if prepend_destdir then in_destdir (envdir ()) else envdir () - in - let tgt_file = - Filename.concat - tgt_dir - (match tgt_fn with - | Some fn -> - fn - | None -> - Filename.basename src_file) - in - (* Create target directory if needed *) - OASISFileUtil.mkdir_parent - ~ctxt - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register ~ctxt install_dir_ev dn) - (Filename.dirname tgt_file); - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt src_file tgt_file; - BaseLog.register ~ctxt install_file_ev tgt_file - in - - (* Install the files for a library. *) - - let install_lib_files ~ctxt findlib_name files = - let findlib_dir = - let dn = - let findlib_destdir = - OASISExec.run_read_one_line ~ctxt (ocamlfind ()) - ["printconf" ; "destdir"] - in - Filename.concat findlib_destdir findlib_name - in - fun () -> dn - in - let () = - if not (OASISFileUtil.file_exists_case (findlib_dir ())) then - failwithf - (f_ "Directory '%s' doesn't exist for findlib library %s") - (findlib_dir ()) findlib_name - in - let f dir file = - let basename = Filename.basename file in - let tgt_fn = Filename.concat dir basename in - (* Destdir is already include in printconf. *) - install_file ~ctxt ~prepend_destdir:false ~tgt_fn file findlib_dir - in - List.iter (fun (dir, files) -> List.iter (f dir) files) files ; - in - - (* Install data into defined directory *) - let install_data ~ctxt srcdir lst tgtdir = - let tgtdir = - OASISHostPath.of_unix (var_expand tgtdir) - in - List.iter - (fun (src, tgt_opt) -> - let real_srcs = - OASISFileUtil.glob - ~ctxt:!BaseContext.default - (Filename.concat srcdir src) - in - if real_srcs = [] then - failwithf - (f_ "Wildcard '%s' doesn't match any files") - src; - List.iter - (fun fn -> - install_file ~ctxt - fn - (fun () -> - match tgt_opt with - | Some s -> - OASISHostPath.of_unix (var_expand s) - | None -> - tgtdir)) - real_srcs) - lst - in - - let make_fnames modul sufx = - List.fold_right - begin fun sufx accu -> - (OASISString.capitalize_ascii modul ^ sufx) :: - (OASISString.uncapitalize_ascii modul ^ sufx) :: - accu - end - sufx - [] - in - - (** Install all libraries *) - let install_libs ~ctxt pkg = - - let find_first_existing_files_in_path bs lst = - let path = OASISHostPath.of_unix bs.bs_path in - List.find - OASISFileUtil.file_exists_case - (List.map (Filename.concat path) lst) - in - - let files_of_modules new_files typ cs bs modules = - List.fold_left - (fun acc modul -> - begin - try - (* Add uncompiled header from the source tree *) - [find_first_existing_files_in_path - bs (make_fnames modul [".mli"; ".ml"])] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in %s %s") - typ modul cs.cs_name; - [] - end - @ - List.fold_left - (fun acc fn -> - try - find_first_existing_files_in_path bs [fn] :: acc - with Not_found -> - acc) - acc (make_fnames modul [".annot";".cmti";".cmt"])) - new_files - modules - in - - let files_of_build_section (f_data, new_files) typ cs bs = - let extra_files = - List.map - (fun fn -> - try - find_first_existing_files_in_path bs [fn] - with Not_found -> - failwithf - (f_ "Cannot find extra findlib file %S in %s %s ") - fn - typ - cs.cs_name) - bs.bs_findlib_extra_files - in - let f_data () = - (* Install data associated with the library *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - f_data, new_files @ extra_files - in - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, dn, lib_extra = !lib_hook data_lib in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BLib cs.cs_name then begin - (* Start with lib_extra *) - let new_files = lib_extra in - let new_files = - files_of_modules new_files "library" cs bs lib.lib_modules - in - let f_data, new_files = - files_of_build_section (f_data, new_files) "library" cs bs - in - let new_files = - (* Get generated files *) - BaseBuilt.fold - ~ctxt - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - new_files - in - let acc = (dn, new_files) :: acc in - - let f_data () = - (* Install data associated with the library *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end else begin - (f_data, acc) - end - and files_of_object (f_data, acc) data_obj = - let cs, bs, obj, dn, obj_extra = !obj_hook data_obj in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BObj cs.cs_name then begin - (* Start with obj_extra *) - let new_files = obj_extra in - let new_files = - files_of_modules new_files "object" cs bs obj.obj_modules - in - let f_data, new_files = - files_of_build_section (f_data, new_files) "object" cs bs - in - - let new_files = - (* Get generated files *) - BaseBuilt.fold - ~ctxt - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - new_files - in - let acc = (dn, new_files) :: acc in - - let f_data () = - (* Install data associated with the object *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat (datarootdir ()) pkg.name); - f_data () - in - (f_data, acc) - end else begin - (f_data, acc) - end - in - - (* Install one group of library *) - let install_group_lib grp = - (* Iterate through all group nodes *) - let rec install_group_lib_aux data_and_files grp = - let data_and_files, children = - match grp with - | Container (_, children) -> - data_and_files, children - | Package (_, cs, bs, `Library lib, dn, children) -> - files_of_library data_and_files (cs, bs, lib, dn), children - | Package (_, cs, bs, `Object obj, dn, children) -> - files_of_object data_and_files (cs, bs, obj, dn), children - in - List.fold_left - install_group_lib_aux - data_and_files - children - in - - (* Findlib name of the root library *) - let findlib_name = findlib_of_group grp in - - (* Determine root library *) - let root_lib = root_of_group grp in - - (* All files to install for this library *) - let f_data, files = install_group_lib_aux (ignore, []) grp in - - (* Really install, if there is something to install *) - if files = [] then begin - warning - (f_ "Nothing to install for findlib library '%s'") findlib_name - end else begin - let meta = - (* Search META file *) - let _, bs, _ = root_lib in - let res = Filename.concat bs.bs_path "META" in - if not (OASISFileUtil.file_exists_case res) then - failwithf - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - let files = - (* Make filename shorter to avoid hitting command max line length - * too early, esp. on Windows. - *) - (* TODO: move to OASISHostPath as make_relative. *) - let remove_prefix p n = - let plen = String.length p in - let nlen = String.length n in - if plen <= nlen && String.sub n 0 plen = p then begin - let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in - let cutpoint = - plen + - (if plen < nlen && n.[plen] = fn_sep then 1 else 0) - in - String.sub n cutpoint (nlen - cutpoint) - end else begin - n - end - in - List.map - (fun (dir, fn) -> - (dir, List.map (remove_prefix (Sys.getcwd ())) fn)) - files - in - let ocamlfind = ocamlfind () in - let nodir_files, dir_files = - List.fold_left - (fun (nodir, dir) (dn, lst) -> - match dn with - | Some dn -> nodir, (dn, lst) :: dir - | None -> lst @ nodir, dir) - ([], []) - (List.rev files) - in - info (f_ "Installing findlib library '%s'") findlib_name; - List.iter - (OASISExec.run ~ctxt ocamlfind) - (split_install_command ocamlfind findlib_name meta nodir_files); - install_lib_files ~ctxt findlib_name dir_files; - BaseLog.register ~ctxt install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); - in - - let group_libs, _, _ = findlib_mapping pkg in - - (* We install libraries in groups *) - List.iter install_group_lib group_libs - in - - let install_execs ~ctxt pkg = - let install_exec data_exec = - let cs, bs, _ = !exec_hook data_exec in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BExec cs.cs_name then begin - let exec_libdir () = Filename.concat (libdir ()) pkg.name in - BaseBuilt.fold - ~ctxt - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file ~ctxt - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - ~ctxt - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> install_file ~ctxt fn exec_libdir) - (); - install_data ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat (datarootdir ()) pkg.name) - end - in - List.iter - (function - | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) - | _ -> ()) - pkg.sections - in - - let install_docs ~ctxt pkg = - let install_doc data = - let cs, doc = !doc_hook data in - if var_choose doc.doc_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BDoc cs.cs_name then begin - let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in - BaseBuilt.fold - ~ctxt - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> install_file ~ctxt fn (fun () -> tgt_dir)) - (); - install_data ~ctxt - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end - in - List.iter - (function - | Doc (cs, doc) -> install_doc (cs, doc) - | _ -> ()) - pkg.sections - in - fun ~ctxt pkg _ -> - install_libs ~ctxt pkg; - install_execs ~ctxt pkg; - install_docs ~ctxt pkg - - - (* Uninstall already installed data *) - let uninstall ~ctxt _ _ = - let uninstall_aux (ev, data) = - if ev = install_file_ev then begin - if OASISFileUtil.file_exists_case data then begin - info (f_ "Removing file '%s'") data; - Sys.remove data - end else begin - warning (f_ "File '%s' doesn't exist anymore") data - end - end else if ev = install_dir_ev then begin - if Sys.file_exists data && Sys.is_directory data then begin - if Sys.readdir data = [||] then begin - info (f_ "Removing directory '%s'") data; - OASISFileUtil.rmdir ~ctxt data - end else begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat ", " (Array.to_list (Sys.readdir data))) - end - end else begin - warning (f_ "Directory '%s' doesn't exist anymore") data - end - end else if ev = install_findlib_ev then begin - info (f_ "Removing findlib library '%s'") data; - OASISExec.run ~ctxt (ocamlfind ()) ["remove"; data] - end else begin - failwithf (f_ "Unknown log event '%s'") ev; - end; - BaseLog.unregister ~ctxt ev data - in - (* We process event in reverse order *) - List.iter uninstall_aux - (List.rev - (BaseLog.filter ~ctxt [install_file_ev; install_dir_ev])); - List.iter uninstall_aux - (List.rev (BaseLog.filter ~ctxt [install_findlib_ev])) - -end - - -# 6465 "setup.ml" -module OCamlbuildCommon = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) - - - (** Functions common to OCamlbuild build and doc plugin - *) - - - open OASISGettext - open BaseEnv - open BaseStandardVar - open OASISTypes - - - type extra_args = string list - - - let ocamlbuild_clean_ev = "ocamlbuild-clean" - - - let ocamlbuildflags = - var_define - ~short_desc:(fun () -> "OCamlbuild additional flags") - "ocamlbuildflags" - (fun () -> "") - - - (** Fix special arguments depending on environment *) - let fix_args args extra_argv = - List.flatten - [ - if (os_type ()) = "Win32" then - [ - "-classic-display"; - "-no-log"; - "-no-links"; - ] - else - []; - - if OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser (OASISVersion.version_of_string "3.11.1")) then - [ - "-install-lib-dir"; - (Filename.concat (standard_library ()) "ocamlbuild") - ] - else - []; - - if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then - [ - "-byte-plugin" - ] - else - []; - args; - - if bool_of_string (debug ()) then - ["-tag"; "debug"] - else - []; - - if bool_of_string (tests ()) then - ["-tag"; "tests"] - else - []; - - if bool_of_string (profile ()) then - ["-tag"; "profile"] - else - []; - - OASISString.nsplit (ocamlbuildflags ()) ' '; - - Array.to_list extra_argv; - ] - - - (** Run 'ocamlbuild -clean' if not already done *) - let run_clean ~ctxt extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ~ctxt ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run ~ctxt (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ~ctxt ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ~ctxt ocamlbuild_clean_ev extra_cli - with _ -> ()) - end - - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild ~ctxt args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister ~ctxt e d) - (BaseLog.filter ~ctxt [ocamlbuild_clean_ev]) - - - (** Determine real build directory *) - let build_dir extra_argv = - let rec search_args dir = - function - | "-build-dir" :: dir :: tl -> - search_args dir tl - | _ :: tl -> - search_args dir tl - | [] -> - dir - in - search_args "_build" (fix_args [] extra_argv) - - -end - -module OCamlbuildPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) - - - (** Build using ocamlbuild - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISUtils - open OASISString - open BaseEnv - open OCamlbuildCommon - open BaseStandardVar - - - let cond_targets_hook = ref (fun lst -> lst) - - - let build ~ctxt extra_args pkg argv = - (* Return the filename in build directory *) - let in_build_dir fn = - Filename.concat - (build_dir argv) - fn - in - - (* Return the unix filename in host build directory *) - let in_build_dir_of_unix fn = - in_build_dir (OASISHostPath.of_unix fn) - in - - let cond_targets = - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_library - in_build_dir_of_unix - (cs, bs, lib) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ~what:".cma" fn - || ends_with ~what:".cmxs" fn - || ends_with ~what:".cmxa" fn - || ends_with ~what:(ext_lib ()) fn - || ends_with ~what:(ext_dll ()) fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for library %s") - cs.cs_name - end - - | Object (cs, bs, obj) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_object - in_build_dir_of_unix - (cs, bs, obj) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ~what:".cmo" fn - || ends_with ~what:".cmx" fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for object %s") - cs.cs_name - end - - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) - in - - let target ext = - let unix_tgt = - (OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.chop_extension - exec.exec_main_is))^ext - in - let evs = - (* Fix evs, we want to use the unix_tgt, without copying *) - List.map - (function - | BaseBuilt.BExec, nm, _ when nm = cs.cs_name -> - BaseBuilt.BExec, nm, - [[in_build_dir_of_unix unix_tgt]] - | ev -> - ev) - evs - in - evs, [unix_tgt] - in - - (* Add executable *) - let acc = - match bs.bs_compiled_object with - | Native -> - (target ".native") :: acc - | Best when bool_of_string (is_native ()) -> - (target ".native") :: acc - | Byte - | Best -> - (target ".byte") :: acc - in - acc - end - - | Library _ | Object _ | Executable _ | Test _ - | SrcRepo _ | Flag _ | Doc _ -> - acc) - [] - (* Keep the pkg.sections ordered *) - (List.rev pkg.sections); - in - - (* Check and register built files *) - let check_and_register (bt, bnm, lst) = - List.iter - (fun fns -> - if not (List.exists OASISFileUtil.file_exists_case fns) then - failwithf - (fn_ - "Expected built file %s doesn't exist." - "None of expected built files %s exists." - (List.length fns)) - (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) - lst; - (BaseBuilt.register ~ctxt bt bnm lst) - in - - (* Run the hook *) - let cond_targets = !cond_targets_hook cond_targets in - - (* Run a list of target... *) - run_ocamlbuild - ~ctxt - (List.flatten (List.map snd cond_targets) @ extra_args) - argv; - (* ... and register events *) - List.iter check_and_register (List.flatten (List.map fst cond_targets)) - - - let clean ~ctxt pkg extra_args = - run_clean ~ctxt extra_args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - -end - -module OCamlbuildDocPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) - - - (* Create documentation using ocamlbuild .odocl files - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OCamlbuildCommon - - - type run_t = - { - extra_args: string list; - run_path: unix_filename; - } - - - let doc_build ~ctxt run _ (cs, _) argv = - let index_html = - OASISUnixPath.make - [ - run.run_path; - cs.cs_name^".docdir"; - "index.html"; - ] - in - let tgt_dir = - OASISHostPath.make - [ - build_dir argv; - OASISHostPath.of_unix run.run_path; - cs.cs_name^".docdir"; - ] - in - run_ocamlbuild ~ctxt (index_html :: run.extra_args) argv; - List.iter - (fun glb -> - match OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb) with - | (_ :: _) as filenames -> - BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [filenames] - | [] -> ()) - ["*.html"; "*.css"] - - - let doc_clean ~ctxt _ _ (cs, _) argv = - run_clean ~ctxt argv; - BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name - - -end - - -# 6837 "setup.ml" -module CustomPlugin = struct -(* # 22 "src/plugins/custom/CustomPlugin.ml" *) - - - (** Generate custom configure/build/doc/test/install system - @author - *) - - - open BaseEnv - open OASISGettext - open OASISTypes - - type t = - { - cmd_main: command_line conditional; - cmd_clean: (command_line option) conditional; - cmd_distclean: (command_line option) conditional; - } - - - let run = BaseCustom.run - - - let main ~ctxt:_ t _ extra_args = - let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in - run cmd args extra_args - - - let clean ~ctxt:_ t _ extra_args = - match var_choose t.cmd_clean with - | Some (cmd, args) -> run cmd args extra_args - | _ -> () - - - let distclean ~ctxt:_ t _ extra_args = - match var_choose t.cmd_distclean with - | Some (cmd, args) -> run cmd args extra_args - | _ -> () - - - module Build = - struct - let main ~ctxt t pkg extra_args = - main ~ctxt t pkg extra_args; - List.iter - (fun sct -> - let evs = - match sct with - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - OASISHostPath.of_unix - (cs, bs, lib) - in - evs - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable - OASISHostPath.of_unix - (cs, bs, exec) - in - evs - end - | _ -> - [] - in - List.iter - (fun (bt, bnm, lst) -> BaseBuilt.register ~ctxt bt bnm lst) - evs) - pkg.sections - - let clean ~ctxt t pkg extra_args = - clean ~ctxt t pkg extra_args; - (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild - * considering moving this to BaseSetup? - *) - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - let distclean ~ctxt t pkg extra_args = distclean ~ctxt t pkg extra_args - end - - - module Test = - struct - let main ~ctxt t pkg (cs, _) extra_args = - try - main ~ctxt t pkg extra_args; - 0.0 - with Failure s -> - BaseMessage.warning - (f_ "Test '%s' fails: %s") - cs.cs_name - s; - 1.0 - - let clean ~ctxt t pkg _ extra_args = clean ~ctxt t pkg extra_args - - let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args - end - - - module Doc = - struct - let main ~ctxt t pkg (cs, _) extra_args = - main ~ctxt t pkg extra_args; - BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [] - - let clean ~ctxt t pkg (cs, _) extra_args = - clean ~ctxt t pkg extra_args; - BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name - - let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args - end - - -end - - -# 6969 "setup.ml" -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = - OCamlbuildPlugin.build - ["-use-ocamlfind"; "-menhir 'menhir --dump --explain' -j 0"]; - test = - [ - ("run", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["frogtest"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }); - ("all", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - doc = - [ - ("logtk", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = - [ - "-use-ocamlfind"; - "-docflags '-keep-code -colorize-code -short-functors -charset utf-8'" - ]; - run_path = "." - }); - ("logtk_parsers", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("logtk_arbitrary", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("libzipperposition", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }) - ]; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = - [ - ("run", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["frogtest"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }); - ("all", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - clean_doc = - [ - ("logtk", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = - [ - "-use-ocamlfind"; - "-docflags '-keep-code -colorize-code -short-functors -charset utf-8'" - ]; - run_path = "." - }); - ("logtk_parsers", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("logtk_arbitrary", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("libzipperposition", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }) - ]; - distclean = []; - distclean_test = - [ - ("run", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["frogtest"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }); - ("all", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - distclean_doc = []; - package = - { - oasis_version = "0.4"; - ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); - version = "1.4"; - license = - OASISLicense.DEP5License - (OASISLicense.DEP5Unit - { - OASISLicense.license = "BSD-3-clause"; - excption = None; - version = OASISLicense.NoVersion - }); - findlib_version = None; - alpha_features = ["compiled_setup_ml"; "ocamlbuild_more_args"]; - beta_features = []; - name = "zipperposition"; - license_file = Some "LICENSE"; - copyrights = []; - maintainers = []; - authors = ["Simon Cruanes"]; - homepage = Some "https://github.com/c-cube/zipperposition"; - bugreports = None; - synopsis = - "Superposition theorem prover, for first order logic with equality."; - description = - Some - [ - OASISText.Para - "Zipperposition is an experimental theorem prover based on superposition. It aims at being flexible and extensible while retaining decent performance (using indexing, for instance). It ships with a logic toolkit, designed primarily for first-order automated reasoning. It aims at providing basic types and algorithms (terms, unification, orderings, indexing, etc.) that can be factored out of several applications." - ]; - tags = []; - categories = []; - files_ab = ["src/prover/const.ml.ab"]; - sections = - [ - Flag - ({ - cs_name = "tools"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Build and install basic tools (CNF, etc.)"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Flag - ({ - cs_name = "bench"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = Some "Build and run benchmarks"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Flag - ({ - cs_name = "long_tests"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Test the prover against a set of problems"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Flag - ({ - cs_name = "parsers"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Build and install parsers (requires menhir)"; - flag_default = [(OASISExpr.EBool true, true)] - }); - Flag - ({ - cs_name = "solving"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some - "Build and install constraint solvers (requires \"msat\")"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Flag - ({ - cs_name = "zipperposition_prover"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Build and install Zipperposition"; - flag_default = [(OASISExpr.EBool true, true)] - }); - Flag - ({ - cs_name = "hornet_prover"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = Some "Build and install Hornet"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Flag - ({ - cs_name = "qcheck"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Build and install QCheck random generators"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Flag - ({ - cs_name = "demo"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Build and install demo programs"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Library - ({ - cs_name = "logtk"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/core/"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("zarith", None); - FindlibPackage ("unix", None); - FindlibPackage ("sequence", None); - FindlibPackage ("containers", None); - FindlibPackage ("containers.data", None); - FindlibPackage ("bytes", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = ["util_stubs.c"; "util_stubs.h"]; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = - [ - (OASISExpr.EBool true, - ["-Wextra"; "-Wno-unused-parameter"]) - ]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "InnerTerm"; - "Term"; - "Type"; - "Util"; - "STerm"; - "Interfaces"; - "DBEnv"; - "Position"; - "Var"; - "HVar"; - "Defined_pos"; - "Subst"; - "Signature"; - "Scoped"; - "Unif"; - "Unif_intf"; - "Unif_constr"; - "Unif_subst"; - "HO_unif"; - "TypeInference"; - "Options"; - "Comparison"; - "Precedence"; - "Builtin"; - "Ordering"; - "Skolem"; - "Cnf"; - "ID"; - "Head"; - "SLiteral"; - "Index"; - "Index_intf"; - "Dtree"; - "Fingerprint"; - "NPDtree"; - "Binder"; - "Congruence"; - "Congruence_intf"; - "Lambda"; - "FeatureVector"; - "FV_tree"; - "UntypedAST"; - "Ind_ty"; - "TypedSTerm"; - "Statement"; - "Flex_state"; - "Compute_prec"; - "Ordinal"; - "Polynomial"; - "Rewrite"; - "Test_prop"; - "Input_format"; - "Output_format"; - "Proof"; - "Multisets"; - "Literal"; - "Literals"; - "Int_lit"; - "Rat_lit"; - "Monome"; - "lib/Hashcons"; - "lib/ParseLocation"; - "lib/Multiset"; - "lib/LazyList"; - "lib/Hash"; - "lib/IArray"; - "lib/AllocCache"; - "lib/Multiset_intf"; - "lib/Signal"; - "lib/UnionFind" - ]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "logtk_proofs"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/proofs"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "logtk"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - ["LLProof"; "LLProof_conv"; "LLProof_check"; "LLTerm" - ]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = Some "logtk"; - lib_findlib_name = Some "proofs"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "logtk_parsers"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "parsers", true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "parsers", true) - ]; - bs_path = "src/parsers"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "logtk"]; - bs_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "menhir"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "Parse_tptp"; - "Lex_tptp"; - "Ast_tptp"; - "Util_tptp"; - "Trace_tstp"; - "Parse_zf"; - "Lex_zf"; - "Util_zf"; - "Util_tip"; - "Tip_ast"; - "Tip_parser"; - "Tip_lexer"; - "Util_dk"; - "Parse_dk"; - "Lex_dk"; - "Ast_dk"; - "Parsing_utils"; - "CallProver" - ]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = Some "logtk"; - lib_findlib_name = Some "parsers"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "logtk_solving"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "solving", true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "solving", true) - ]; - bs_path = "src/solving"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "logtk"; - FindlibPackage ("msat", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["Lpo"]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = Some "logtk"; - lib_findlib_name = Some "solving"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "logtk_arbitrary"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "qcheck", true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "qcheck", true) - ]; - bs_path = "src/arbitrary/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "logtk"; - FindlibPackage ("qcheck", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - ["ArTerm"; "ArForm"; "ArType"; "ArID"; "ArLiteral"]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = Some "logtk"; - lib_findlib_name = Some "arbitrary"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "libzipperposition"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "parsers", - OASISExpr.EFlag "zipperposition_prover"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "parsers", - OASISExpr.EFlag "zipperposition_prover"), - true) - ]; - bs_path = "src/prover/"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("containers", None); - FindlibPackage ("sequence", None); - FindlibPackage ("unix", None); - FindlibPackage ("zarith", None); - FindlibPackage ("msat", None); - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers"; - InternalLibrary "logtk_proofs" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "ClauseQueue"; - "Clause"; - "SClause"; - "Const"; - "Extensions"; - "Ctx"; - "ProofState"; - "Bool_clause"; - "Saturate"; - "Selection"; - "AC"; - "AC_intf"; - "SimplM"; - "Params"; - "Env"; - "Signals"; - "Classify_cst"; - "Ctx_intf"; - "Clause_intf"; - "Env_intf"; - "ProofState_intf"; - "BBox"; - "ClauseContext"; - "ClauseQueue_intf"; - "Bool_lit"; - "Bool_lit_intf"; - "Sat_solver"; - "Sat_solver_intf"; - "Trail"; - "Ind_cst"; - "Cover_set"; - "Cut_form"; - "Phases"; - "Phases_impl"; - "calculi/Avatar"; - "calculi/Avatar_intf"; - "calculi/Induction"; - "calculi/Induction_intf"; - "calculi/Superposition"; - "calculi/Superposition_intf"; - "calculi/Rewriting"; - "calculi/EnumTypes"; - "calculi/Arith_int"; - "calculi/Arith_rat"; - "calculi/Heuristics"; - "calculi/Ind_types"; - "calculi/Fool"; - "calculi/Higher_order" - ]; - lib_pack = true; - lib_internal_modules = ["lib/Simplex"]; - lib_findlib_parent = None; - lib_findlib_name = Some "libzipperposition"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Executable - ({ - cs_name = "zipperposition"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "parsers", - OASISExpr.EFlag "zipperposition_prover"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "parsers", - OASISExpr.EFlag "zipperposition_prover"), - true) - ]; - bs_path = "src/main/"; - bs_compiled_object = Native; - bs_build_depends = - [ - FindlibPackage ("containers", None); - FindlibPackage ("sequence", None); - FindlibPackage ("unix", None); - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers"; - InternalLibrary "libzipperposition" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "zipperposition.ml"}); - Executable - ({ - cs_name = "hornet"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "parsers", - OASISExpr.EFlag "hornet_prover"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "parsers", - OASISExpr.EFlag "hornet_prover"), - true) - ]; - bs_path = "src/hornet/"; - bs_compiled_object = Native; - bs_build_depends = - [ - FindlibPackage ("containers", None); - FindlibPackage ("sequence", None); - FindlibPackage ("unix", None); - FindlibPackage ("msat", None); - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "hornet.ml"}); - Doc - ({ - cs_name = "logtk"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EFlag "docs"), - true) - ]; - doc_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install_dir = "$docdir"; - doc_title = "Documentation for Logtk"; - doc_authors = []; - doc_abstract = Some "Main API documentation for Logtk."; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Doc - ({ - cs_name = "logtk_parsers"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EFlag "parsers")), - true) - ]; - doc_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EFlag "parsers"), - true) - ]; - doc_install_dir = "$docdir"; - doc_title = "Logtk_parsers documentation"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Doc - ({ - cs_name = "logtk_arbitrary"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EFlag "qcheck")), - true) - ]; - doc_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EFlag "qcheck"), - true) - ]; - doc_install_dir = "$docdir"; - doc_title = "Logtk_arbitrary documentation"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Doc - ({ - cs_name = "libzipperposition"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EFlag "docs"), - true) - ]; - doc_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install_dir = "$docdir"; - doc_title = "Libzipperpositio documentation"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Executable - ({ - cs_name = "run_bench"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "bench", - OASISExpr.EFlag "tests"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/bench/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "logtk"; - FindlibPackage ("benchmark", None); - FindlibPackage ("qcheck", None); - InternalLibrary "logtk_arbitrary" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "run_bench.ml"}); - Test - ({ - cs_name = "run"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - test_type = (`Test, "custom", Some "0.4"); - test_command = - [(OASISExpr.EBool true, ("make", ["frogtest"]))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "long_tests")), - true) - ]; - test_tools = [ExternalTool "ocamlbuild"] - }); - Executable - ({ - cs_name = "run_tests"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "qcheck"), - OASISExpr.EFlag "parsers"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers"; - FindlibPackage ("oUnit", None); - InternalLibrary "logtk_arbitrary"; - FindlibPackage ("qcheck", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "run_tests.ml"}); - Test - ({ - cs_name = "all"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - test_type = (`Test, "custom", Some "0.4"); - test_command = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "qcheck")), - true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "run_tests" - ] - }); - Executable - ({ - cs_name = "type_check"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_path = "src/tools/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "type_check.ml"}); - Executable - ({ - cs_name = "cnf_of"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_path = "src/tools/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "cnf_of.ml"}); - Executable - ({ - cs_name = "app_encode"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_path = "src/tools/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "app_encode.ml"}); - Executable - ({ - cs_name = "tptp_to_zf"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_path = "src/tools/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "tptp_to_zf.ml"}); - Executable - ({ - cs_name = "proof_check_tstp"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tools", - OASISExpr.EFlag "parsers"), - true) - ]; - bs_path = "src/tools/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "proof_check_tstp.ml" - }); - Executable - ({ - cs_name = "resolution1"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "parsers", - OASISExpr.EFlag "demo"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "src/demo/resolution"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "logtk"; - InternalLibrary "logtk_parsers"; - FindlibPackage ("sequence", None); - FindlibPackage ("containers", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "resolution1.ml"}); - SrcRepo - ({ - cs_name = "head"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - src_repo_type = Git; - src_repo_location = - "https://github.com/c-cube/zipperposition"; - src_repo_browser = - Some - "https://github.com/c-cube/zipperposition/tree/master/src"; - src_repo_module = None; - src_repo_branch = None; - src_repo_tag = None; - src_repo_subdir = None - }) - ]; - disable_oasis_section = []; - conf_type = (`Configure, "internal", Some "0.4"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - build_type = (`Build, "ocamlbuild", Some "0.4"); - build_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - install_type = (`Install, "internal", Some "0.4"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - plugins = - [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; - schema_data = PropList.Data.create (); - plugin_data = [] - }; - oasis_fn = Some "_oasis"; - oasis_version = "0.4.10"; - oasis_digest = Some "u[\236\180b\235\142J\167#\222Y0\nn\211"; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false - };; - -let setup () = BaseSetup.setup setup_t;; - -# 10104 "setup.ml" -let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t -open BaseCompat.Compat_0_4 -(* OASIS_STOP *) -let () = setup ();; diff --git a/src/.merlin b/src/.merlin deleted file mode 100644 index 2ba616962..000000000 --- a/src/.merlin +++ /dev/null @@ -1 +0,0 @@ -REC diff --git a/src/arbitrary/.merlin b/src/arbitrary/.merlin deleted file mode 100644 index 4d52c64f5..000000000 --- a/src/arbitrary/.merlin +++ /dev/null @@ -1,2 +0,0 @@ -REC -PKG qcheck diff --git a/src/arbitrary/jbuild b/src/arbitrary/jbuild new file mode 100644 index 000000000..681ec81f3 --- /dev/null +++ b/src/arbitrary/jbuild @@ -0,0 +1,19 @@ +; vim:ft=lisp: + +(jbuild_version 1) + +; main lib +(library + ((name logtk_arbitrary) + (public_name logtk.arbitrary) + (synopsis "random generators for logtk") + (optional) + (libraries (containers logtk qcheck)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -bin-annot + -unbox-closures -unbox-closures-factor 20)) + )) + + + + diff --git a/src/arbitrary/libzipperposition_arbitrary.mldylib b/src/arbitrary/libzipperposition_arbitrary.mldylib deleted file mode 100644 index 1c8e41b97..000000000 --- a/src/arbitrary/libzipperposition_arbitrary.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 298def4e8c287f0cce3d38a6f5fff1d8) -Libzipperposition_arbitrary -# OASIS_STOP diff --git a/src/arbitrary/libzipperposition_arbitrary.mllib b/src/arbitrary/libzipperposition_arbitrary.mllib deleted file mode 100644 index 1c8e41b97..000000000 --- a/src/arbitrary/libzipperposition_arbitrary.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 298def4e8c287f0cce3d38a6f5fff1d8) -Libzipperposition_arbitrary -# OASIS_STOP diff --git a/src/arbitrary/libzipperposition_arbitrary.mlpack b/src/arbitrary/libzipperposition_arbitrary.mlpack deleted file mode 100644 index 3fa5b2427..000000000 --- a/src/arbitrary/libzipperposition_arbitrary.mlpack +++ /dev/null @@ -1,7 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 14f13bce9725d53020afe37f8862185c) -ArTerm -ArForm -ArType -ArID -# OASIS_STOP diff --git a/src/arbitrary/logtk_arbitrary.mld b/src/arbitrary/logtk_arbitrary.mld new file mode 100644 index 000000000..a72a4ee22 --- /dev/null +++ b/src/arbitrary/logtk_arbitrary.mld @@ -0,0 +1,5 @@ + +Logtk_arbitrary contains random generators for terms, clauses, formulas. These +are to be used in property tests (see {b qcheck}) or perhaps benchmarks. + +{!modules: Logtk_arbitrary} diff --git a/src/arbitrary/logtk_arbitrary.mldylib b/src/arbitrary/logtk_arbitrary.mldylib deleted file mode 100644 index 64a36918b..000000000 --- a/src/arbitrary/logtk_arbitrary.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 6717047718c373231eb399c6e8880fbe) -Logtk_arbitrary -# OASIS_STOP diff --git a/src/arbitrary/logtk_arbitrary.mllib b/src/arbitrary/logtk_arbitrary.mllib deleted file mode 100644 index 64a36918b..000000000 --- a/src/arbitrary/logtk_arbitrary.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 6717047718c373231eb399c6e8880fbe) -Logtk_arbitrary -# OASIS_STOP diff --git a/src/arbitrary/logtk_arbitrary.mlpack b/src/arbitrary/logtk_arbitrary.mlpack deleted file mode 100644 index b4a873988..000000000 --- a/src/arbitrary/logtk_arbitrary.mlpack +++ /dev/null @@ -1,8 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: e63645d4c2285a512cc731e78b5484d3) -ArTerm -ArForm -ArType -ArID -ArLiteral -# OASIS_STOP diff --git a/src/base/liblogtk_stubs.clib b/src/base/liblogtk_stubs.clib deleted file mode 100644 index 5b5c99043..000000000 --- a/src/base/liblogtk_stubs.clib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 7ba715c437ed36100f01758f71aa8dda) -util_stubs.o -# OASIS_STOP diff --git a/src/core/lib/AllocCache.ml b/src/core/AllocCache.ml similarity index 100% rename from src/core/lib/AllocCache.ml rename to src/core/AllocCache.ml diff --git a/src/core/lib/AllocCache.mli b/src/core/AllocCache.mli similarity index 100% rename from src/core/lib/AllocCache.mli rename to src/core/AllocCache.mli diff --git a/src/core/Builtin.ml b/src/core/Builtin.ml index 27523bd61..e0bf901ad 100644 --- a/src/core/Builtin.ml +++ b/src/core/Builtin.ml @@ -58,6 +58,7 @@ type t = | Greater | Greatereq | Box_opaque (** hint not to open this formula *) + | Pseudo_de_bruijn of int (** magic to embed De Bruijn indices in normal terms *) type t_ = t @@ -114,6 +115,7 @@ let to_int_ = function | Box_opaque -> 60 | TyReal -> 70 | Real _ -> 71 + | Pseudo_de_bruijn _ -> 100 let compare a b = match a, b with | Int i, Int j -> Z.compare i j @@ -196,6 +198,7 @@ let to_string s = match s with | Greater -> ">" | Greatereq -> "≥" | Box_opaque -> "" + | Pseudo_de_bruijn i -> Printf.sprintf "db_%d" i let pp out s = Format.pp_print_string out (to_string s) @@ -359,6 +362,7 @@ module TPTP = struct | Greater -> "$greater" | Greatereq -> "$greatereq" | Box_opaque -> "$$box" + | Pseudo_de_bruijn i -> Printf.sprintf "$$db_%d" i let pp out b = CCFormat.string out (to_string b) @@ -693,6 +697,7 @@ module ZF = struct | Greater -> ">" | Greatereq -> ">=" | Box_opaque -> "" + | Pseudo_de_bruijn i -> Printf.sprintf "" i let pp out b = CCFormat.string out (to_string b) end diff --git a/src/core/Builtin.mli b/src/core/Builtin.mli index dc8a81daf..93f586cc3 100644 --- a/src/core/Builtin.mli +++ b/src/core/Builtin.mli @@ -64,6 +64,7 @@ type t = | Greater | Greatereq | Box_opaque (** hint not to open this formula *) + | Pseudo_de_bruijn of int (** magic to embed De Bruijn indices in normal terms *) include Interfaces.HASH with type t := t include Interfaces.ORD with type t := t diff --git a/src/core/Cnf.ml b/src/core/Cnf.ml index f093dffbe..169be2cb7 100644 --- a/src/core/Cnf.ml +++ b/src/core/Cnf.ml @@ -358,9 +358,9 @@ module Flatten = struct aux Pos_toplevel vars a >>= fun a -> aux Pos_toplevel vars b >|= fun b -> let f = T.Form.or_ - [ T.app_builtin ~ty:T.Ty.prop Builtin.Less [a; b]; - T.app_builtin ~ty:T.Ty.prop Builtin.Less [b; a]; - ] + [ T.app_builtin ~ty:T.Ty.prop Builtin.Less [a; b]; + T.app_builtin ~ty:T.Ty.prop Builtin.Less [b; a]; + ] in aux_maybe_define pos f | T.AppBuiltin (Builtin.Eq, [a;b]) when T.is_fun a || T.is_fun b -> (* turn [f = λx. t] into [∀x. f x=t] *) diff --git a/src/core/Compute_prec.ml b/src/core/Compute_prec.ml index 61b7ae476..a10481a39 100644 --- a/src/core/Compute_prec.ml +++ b/src/core/Compute_prec.ml @@ -65,7 +65,7 @@ let _add_custom_weights weights arg_coeff= if ID.name constant = name then List.tl values else arg_coeff constant) with - | Failure _ | Not_found -> failwith "Syntax error in custom weights" + | Failure _ | Not_found -> failwith "Syntax error in custom weights" ) (weights, arg_coeff) input_list let mk_precedence t seq = @@ -103,6 +103,6 @@ let () = , Arg.Set _alpha_precedence , " use pure alphabetical precedence" ; "--weights" - , Arg.Set_string _custom_weights - , " set weights, e.g. f=2,g=3,h=1, or weights and argument coefficients, e.g. f=2:3:4,g=3:2" + , Arg.Set_string _custom_weights + , " set weights, e.g. f=2,g=3,h=1, or weights and argument coefficients, e.g. f=2:3:4,g=3:2" ] diff --git a/src/core/Congruence.ml b/src/core/Congruence.ml index 352ef263a..f0b32280f 100644 --- a/src/core/Congruence.ml +++ b/src/core/Congruence.ml @@ -20,6 +20,8 @@ module type TERM = sig val update_subterms : t -> t list -> t (** Replace immediate subterms by the given list. This is used to test for equality *) + + val pp : t CCFormat.printer end module Make(T : TERM) = struct @@ -161,6 +163,18 @@ module Make(T : TERM) = struct let cc = add cc t1 in let cc = add cc t2 in T.equal (find_ cc t1) (find_ cc t2) + + let pp_debug out (cc:t) : unit = + let module Fmt = CCFormat in + let pp_parent out (t,l) = + Fmt.fprintf out "(@[parents@ :of %a@ (@[%a@])@])" + T.pp t (Util.pp_list ~sep:" " T.pp) l + and pp_next out (t,u) = + Fmt.fprintf out "(@[next@ :of %a@ :is %a@])" T.pp t T.pp u + in + Fmt.fprintf out "(@[cc@ :parent_tbl (@[%a@])@ :next_tbl (@[%a@])@])" + (Util.pp_seq pp_parent) (H.to_seq cc.parents) + (Util.pp_seq pp_next) (H.to_seq cc.next) end module FO = Make(struct @@ -169,6 +183,7 @@ module FO = Make(struct type t = T.t let equal = T.equal let hash = T.hash + let pp = T.pp let subterms t = match T.Classic.view t with | T.Classic.App (_, l) -> l diff --git a/src/core/Congruence.mli b/src/core/Congruence.mli index bdcf30fd0..be0846bb2 100644 --- a/src/core/Congruence.mli +++ b/src/core/Congruence.mli @@ -27,6 +27,8 @@ module type TERM = sig val update_subterms : t -> t list -> t (** Replace immediate subterms by the given list. This is used to test for equality *) + + val pp : t CCFormat.printer end module Make(T : TERM) : S with type term = T.t diff --git a/src/core/Congruence_intf.ml b/src/core/Congruence_intf.ml index 8e3bf4da8..ad9da29a1 100644 --- a/src/core/Congruence_intf.ml +++ b/src/core/Congruence_intf.ml @@ -40,4 +40,6 @@ module type S = sig val is_eq : t -> term -> term -> bool (** Returns true if the two terms are equal in the congruence. This updates the congruence, because the two terms need to be added. *) + + val pp_debug : t CCFormat.printer end diff --git a/src/core/DBEnv.ml b/src/core/DBEnv.ml index 83c953ea6..67b1d1d68 100644 --- a/src/core/DBEnv.ml +++ b/src/core/DBEnv.ml @@ -40,6 +40,7 @@ let rec pop_many env n = match n with | _ -> pop_many (pop env) (n-1) let find env n = + assert (n>=0); if n < env.size then List.nth env.stack n else None let find_exn env n = @@ -76,8 +77,8 @@ let filteri f db = let stack = CCList.foldi (fun acc i o -> match o with - | Some x when f i x -> Some x :: acc - | _ -> None :: acc) + | Some x when f i x -> Some x :: acc + | _ -> None :: acc) [] db.stack |> List.rev in diff --git a/src/core/FV_tree.ml b/src/core/FV_tree.ml index ebaf096b5..e17feb911 100644 --- a/src/core/FV_tree.ml +++ b/src/core/FV_tree.ml @@ -247,22 +247,22 @@ module Make(C: Index_intf.CLAUSE) = struct | TrieNode m, c -> begin try (* insert in subtrie *) - let subtrie = Feat_map.find c m in - let rebuild' subtrie = match subtrie with - | _ when empty_trie subtrie -> rebuild (TrieNode (Feat_map.remove c m)) - | _ -> rebuild (TrieNode (Feat_map.add c subtrie m)) - in - goto subtrie (i+1) rebuild' - with Not_found -> (* no subtrie found *) - let subtrie = - if i+1 = IArray.length fv - then TrieLeaf C_set.empty - else TrieNode Feat_map.empty - and rebuild' subtrie = match subtrie with - | _ when empty_trie subtrie -> rebuild (TrieNode (Feat_map.remove c m)) - | _ -> rebuild (TrieNode (Feat_map.add c subtrie m)) - in - goto subtrie (i+1) rebuild' + let subtrie = Feat_map.find c m in + let rebuild' subtrie = match subtrie with + | _ when empty_trie subtrie -> rebuild (TrieNode (Feat_map.remove c m)) + | _ -> rebuild (TrieNode (Feat_map.add c subtrie m)) + in + goto subtrie (i+1) rebuild' + with Not_found -> (* no subtrie found *) + let subtrie = + if i+1 = IArray.length fv + then TrieLeaf C_set.empty + else TrieNode Feat_map.empty + and rebuild' subtrie = match subtrie with + | _ when empty_trie subtrie -> rebuild (TrieNode (Feat_map.remove c m)) + | _ -> rebuild (TrieNode (Feat_map.add c subtrie m)) + in + goto subtrie (i+1) rebuild' end | TrieLeaf _, _ -> assert false (* wrong arity *) in diff --git a/src/core/Fingerprint.mli b/src/core/Fingerprint.mli index b02a55787..71ca10a3f 100644 --- a/src/core/Fingerprint.mli +++ b/src/core/Fingerprint.mli @@ -5,13 +5,13 @@ (** Fingerprint term indexing, based on the paper of the same name by S. Schulz. - + NOTE: less efficient, it seems, than {!NPDtree} *) type fingerprint_fun (** A fingerprint function is a list of positions. - + To compute the fingerprint of a term, we map each position to a feature; fingerprints can then be compared for potential unifiability/matching. diff --git a/src/core/HO_unif.ml b/src/core/HO_unif.ml index 7984bb803..5206f9dc6 100644 --- a/src/core/HO_unif.ml +++ b/src/core/HO_unif.ml @@ -77,11 +77,11 @@ let enum_prop ?(mode=`Full) ((v:Term.var), sc_v) ~offset : (Subst.t * penalty) l in CCList.filter_map (fun (o,penalty) -> match o with - | None -> None - | Some t -> - assert (T.DB.is_closed t); - let subst = Subst.FO.bind' Subst.empty (v,sc_v) (t,sc_v) in - Some (subst, penalty)) + | None -> None + | Some t -> + assert (T.DB.is_closed t); + let subst = Subst.FO.bind' Subst.empty (v,sc_v) (t,sc_v) in + Some (subst, penalty)) [ l_not, 2; l_and, 5; l_eq, 10; @@ -269,7 +269,7 @@ module U = struct where the [F] are fresh, and return the pair [arg_k (F1 x1…xn)…(Fm x1…xn) = t args] *) let proj = - Sequence.of_list all_ty_args |> Sequence.zip_i |> Sequence.zip + Sequence.of_list all_ty_args |> Util.seq_zipi |> Sequence.filter_map (fun (i,ty_arg_i) -> let ty_args_i, ty_ret_i = Type.open_fun ty_arg_i in @@ -499,7 +499,7 @@ module U = struct let subst = List.fold_left (fun subst p -> US.add_constr (delay_pair p sc) subst) - pb.subst pb.pairs + pb.subst pb.pairs in add_sol subst pb.penalty | T.App _, _ | _, T.App _ -> assert false (* heads *) @@ -565,11 +565,11 @@ module U = struct |> Sequence.of_queue |> Sequence.map (fun pb -> - let pairs, renaming = apply_subst pb.pairs pb.subst in - pairs, norm_subst st.offset0 st.sc pb.subst, pb.penalty, renaming) + let pairs, renaming = apply_subst pb.pairs pb.subst in + pairs, norm_subst st.offset0 st.sc pb.subst, pb.penalty, renaming) |> Sequence.to_rev_list in - List.rev_append sols1 sols2 + List.rev_append sols1 sols2 end let unif_pairs ?(fuel= !default_fuel) (pairs,sc) ~offset : _ list = diff --git a/src/core/lib/Hash.ml b/src/core/Hash.ml similarity index 100% rename from src/core/lib/Hash.ml rename to src/core/Hash.ml diff --git a/src/core/lib/Hash.mli b/src/core/Hash.mli similarity index 100% rename from src/core/lib/Hash.mli rename to src/core/Hash.mli diff --git a/src/core/lib/Hashcons.ml b/src/core/Hashcons.ml similarity index 100% rename from src/core/lib/Hashcons.ml rename to src/core/Hashcons.ml diff --git a/src/core/lib/Hashcons.mli b/src/core/Hashcons.mli similarity index 100% rename from src/core/lib/Hashcons.mli rename to src/core/Hashcons.mli diff --git a/src/core/Head.ml b/src/core/Head.ml old mode 100755 new mode 100644 index 292e79250..d0af40e05 --- a/src/core/Head.ml +++ b/src/core/Head.ml @@ -19,22 +19,22 @@ let pp out = function let term_to_head s = match T.view s with - | T.App (f,_) -> - begin match T.view f with - | T.Const fid -> Some (I fid) - | T.Var x -> Some (V x) - | _ -> None - end - | T.AppBuiltin (fid,_) -> Some (B fid) - | T.Const fid -> Some (I fid) - | T.Var x -> Some (V x) - | _ -> None + | T.App (f,_) -> + begin match T.view f with + | T.Const fid -> Some (I fid) + | T.Var x -> Some (V x) + | _ -> None + end + | T.AppBuiltin (fid,_) -> Some (B fid) + | T.Const fid -> Some (I fid) + | T.Var x -> Some (V x) + | _ -> None let term_to_args s = let ignore_ty_args = List.filter (fun u -> not (Type.is_tType (T.ty u))) in match T.view s with - | T.App (_,ss) -> ignore_ty_args ss - | T.AppBuiltin (_,ss) -> ignore_ty_args ss - | _ -> [] + | T.App (_,ss) -> ignore_ty_args ss + | T.AppBuiltin (_,ss) -> ignore_ty_args ss + | _ -> [] let to_string = CCFormat.to_string pp diff --git a/src/core/Head.mli b/src/core/Head.mli old mode 100755 new mode 100644 diff --git a/src/core/lib/IArray.ml b/src/core/IArray.ml similarity index 100% rename from src/core/lib/IArray.ml rename to src/core/IArray.ml diff --git a/src/core/lib/IArray.mli b/src/core/IArray.mli similarity index 100% rename from src/core/lib/IArray.mli rename to src/core/IArray.mli diff --git a/src/core/ID.ml b/src/core/ID.ml index 32d7811ed..7ba7efd32 100644 --- a/src/core/ID.ml +++ b/src/core/ID.ml @@ -110,6 +110,8 @@ type skolem_kind = K_normal | K_ind (* inductive *) exception Attr_skolem of skolem_kind * int +exception Attr_distinct + let as_infix = payload_find ~f:(function Attr_infix s->Some s | _ -> None) let is_infix id = as_infix id |> CCOpt.is_some let as_prefix = payload_find ~f:(function Attr_prefix s->Some s | _ -> None) @@ -132,10 +134,16 @@ let as_skolem id = let num_mandatory_args id = let n_option = payload_find id - ~f:(function + ~f:(function | Attr_skolem (_, n) -> Some n | _ -> None) in match n_option with - | Some n -> n - | None -> 0 + | Some n -> n + | None -> 0 + +let is_distinct_object id = + payload_pred id + ~f:(function + | Attr_distinct -> true + | _ -> false) diff --git a/src/core/ID.mli b/src/core/ID.mli index 1aefa79fd..ec933d57b 100644 --- a/src/core/ID.mli +++ b/src/core/ID.mli @@ -19,7 +19,6 @@ information about the identifier (e.g. special sugar notation, whether it's a skolem, etc.) - @since 1.0 *) @@ -87,6 +86,8 @@ type skolem_kind = K_normal | K_ind (* inductive *) exception Attr_skolem of skolem_kind * int +exception Attr_distinct + val as_infix : t -> string option val is_infix : t -> bool @@ -103,3 +104,6 @@ val as_skolem : t -> skolem_kind option val num_mandatory_args : t -> int (** number of mandatory arguments of a skolem constant or 0 otherwise *) + +val is_distinct_object : t -> bool +(** whether the identifier is a distinct object (as defined in TPTP syntax) *) diff --git a/src/core/InnerTerm.ml b/src/core/InnerTerm.ml index b959d873e..a06cdff12 100644 --- a/src/core/InnerTerm.ml +++ b/src/core/InnerTerm.ml @@ -260,7 +260,7 @@ module DB = struct | HasType ty -> _to_seq ~depth ty k end; match view t with - | DB v -> k v depth + | DB v -> k (v,depth) | Var _ | Const _ -> () | Bind (_, varty, t') -> @@ -276,15 +276,13 @@ module DB = struct let closed t = _to_seq ~depth:0 t - |> Sequence.map2 - (fun bvar depth -> bvar < depth) + |> Sequence.map (fun (bvar,depth) -> bvar < depth) |> Sequence.for_all _id (* check whether t contains the De Bruijn symbol n *) let contains t n = _to_seq ~depth:0 t - |> Sequence.map2 - (fun bvar depth -> bvar=n+depth) + |> Sequence.map (fun (bvar,depth) -> bvar=n+depth) |> Sequence.exists _id (* maps the term to another term, calling [on_binder acc t] @@ -558,7 +556,7 @@ module Pos = struct let fail_ t pos = Util.errorf ~where:"Term.Pos" "@[<2>invalid position `@[%a@]`@ in term `@[%a@]`@]" - P.pp pos debugf t + P.pp pos debugf t let rec at t pos = match view t, pos with | _, P.Type pos' -> @@ -708,6 +706,10 @@ let rec open_poly_fun ty = match view ty with let args, ret = open_fun ty in 0, args, ret +let rec expected_ty_vars ty = match view ty with + | Bind (Binder.ForallTy, _, ty') -> 1 + expected_ty_vars ty' + | _ -> 0 + let is_ground t = Sequence.is_empty (Seq.vars t) (** {3 Misc} *) diff --git a/src/core/InnerTerm.mli b/src/core/InnerTerm.mli index 2c92ccd26..d79cdb7d4 100644 --- a/src/core/InnerTerm.mli +++ b/src/core/InnerTerm.mli @@ -217,6 +217,9 @@ val open_poly_fun : t -> int * t list * t @return the return type, the number of type variables, and the list of all its arguments *) +val expected_ty_vars : t -> int +(** @return the number of type variables that a type requires. *) + val open_bind : Binder.t -> t -> t list * t val open_bind_fresh : Binder.t -> t -> t HVar.t list * t @@ -318,4 +321,3 @@ val pp_in : Output_format.t -> t CCFormat.printer (* TODO: functor for scoping operation (and inverse) between ScopedTerm and NamedTerm *) - diff --git a/src/core/Lambda.ml b/src/core/Lambda.ml index 3a49ac89f..4ee9a01bd 100644 --- a/src/core/Lambda.ml +++ b/src/core/Lambda.ml @@ -215,10 +215,10 @@ let snf t = let eta_expand t = Inner.eta_expand (t:T.t :> IT.t) |> T.of_term_unsafe - (*|> CCFun.tap (fun t' -> - if t != t' then Format.printf "@[eta_expand `%a`@ into `%a`@]@." T.pp t T.pp t')*) +(*|> CCFun.tap (fun t' -> + if t != t' then Format.printf "@[eta_expand `%a`@ into `%a`@]@." T.pp t T.pp t')*) let eta_reduce t = Inner.eta_reduce (t:T.t :> IT.t) |> T.of_term_unsafe - (*|> CCFun.tap (fun t' -> - if t != t' then Format.printf "@[eta_reduce `%a`@ into `%a`@]@." T.pp t T.pp t')*) +(*|> CCFun.tap (fun t' -> + if t != t' then Format.printf "@[eta_reduce `%a`@ into `%a`@]@." T.pp t T.pp t')*) diff --git a/src/core/lib/LazyList.ml b/src/core/LazyList.ml similarity index 100% rename from src/core/lib/LazyList.ml rename to src/core/LazyList.ml diff --git a/src/core/lib/LazyList.mli b/src/core/LazyList.mli similarity index 100% rename from src/core/lib/LazyList.mli rename to src/core/LazyList.mli diff --git a/src/core/Literal.ml b/src/core/Literal.ml index 22bf08c38..cb6e09e4b 100644 --- a/src/core/Literal.ml +++ b/src/core/Literal.ml @@ -203,8 +203,8 @@ let rec mk_lit a b sign = | T.AppBuiltin (Builtin.False, []), _ -> Prop (b, not sign) | _, T.AppBuiltin (Builtin.False, []) -> Prop (a, not sign) (* NOTE: keep negation for higher-order unification constraints - | T.AppBuiltin (Builtin.Not, [a']), _ -> mk_lit a' b (not sign) - | _, T.AppBuiltin (Builtin.Not, [b']) -> mk_lit a b' (not sign) + | T.AppBuiltin (Builtin.Not, [a']), _ -> mk_lit a' b (not sign) + | _, T.AppBuiltin (Builtin.Not, [b']) -> mk_lit a b' (not sign) *) | _ when has_num_ty a -> begin match mk_num_eq a b sign with @@ -1035,9 +1035,9 @@ module Conv = struct end end - let to_s_form ?(ctx=T.Conv.create()) ?hooks lit = + let to_s_form ?allow_free_db ?(ctx=T.Conv.create()) ?hooks lit = to_form ?hooks lit - |> SLiteral.map ~f:(T.Conv.to_simple_term ctx) + |> SLiteral.map ~f:(T.Conv.to_simple_term ?allow_free_db ctx) |> SLiteral.to_form end diff --git a/src/core/Literal.mli b/src/core/Literal.mli index 8675ea1c7..35875565a 100644 --- a/src/core/Literal.mli +++ b/src/core/Literal.mli @@ -154,7 +154,7 @@ val is_absurd_tags : t -> Proof.tag list (** if [is_absurd lit], return why *) val fold_terms : ?position:Position.t -> ?vars:bool -> ?ty_args:bool -> which:[<`Max|`All] -> - ?ord:Ordering.t -> + ?ord:Ordering.t -> subterms:bool -> t -> term Position.With.t Sequence.t @@ -276,7 +276,9 @@ module Conv : sig val to_form : ?hooks:hook_to list -> t -> term SLiteral.t - val to_s_form : ?ctx:Term.Conv.ctx -> ?hooks:hook_to list -> t -> TypedSTerm.Form.t + val to_s_form : + ?allow_free_db:bool -> ?ctx:Term.Conv.ctx -> ?hooks:hook_to list -> + t -> TypedSTerm.Form.t end (** {2 IO} *) diff --git a/src/core/Literals.ml b/src/core/Literals.ml index c43c3c92c..3cf85f0d4 100644 --- a/src/core/Literals.ml +++ b/src/core/Literals.ml @@ -132,7 +132,7 @@ let maxlits_l ~ord lits = Util.enter_prof prof_maxlits; let m = _to_multiset_with_idx lits in let max = MLI.max_seq (_compare_lit_with_idx ~ord) m - |> Sequence.map2 (fun x _ -> x) + |> Sequence.map fst |> Sequence.to_list in Util.exit_prof prof_maxlits; @@ -142,7 +142,7 @@ let maxlits ~ord lits = Util.enter_prof prof_maxlits; let m = _to_multiset_with_idx lits in let max = MLI.max_seq (_compare_lit_with_idx ~ord) m - |> Sequence.map2 (fun x _ -> snd x) + |> Sequence.map (fun (x,_) -> snd x) |> Sequence.to_list |> BV.of_list in @@ -251,9 +251,9 @@ module Conv = struct let to_forms ?hooks lits = Array.to_list (Array.map (Lit.Conv.to_form ?hooks) lits) - let to_s_form ?(ctx=T.Conv.create()) ?hooks lits = + let to_s_form ?allow_free_db ?(ctx=T.Conv.create()) ?hooks lits = Array.to_list lits - |> List.map (Literal.Conv.to_s_form ?hooks ~ctx) + |> List.map (Literal.Conv.to_s_form ?hooks ?allow_free_db ~ctx) |> TypedSTerm.Form.or_ end diff --git a/src/core/Literals.mli b/src/core/Literals.mli index 44290b1e2..d53335889 100644 --- a/src/core/Literals.mli +++ b/src/core/Literals.mli @@ -119,6 +119,7 @@ module Conv : sig (** To list of formulas *) val to_s_form : + ?allow_free_db:bool -> ?ctx:Term.Conv.ctx -> ?hooks:Literal.Conv.hook_to list -> t -> diff --git a/src/core/META b/src/core/META deleted file mode 100644 index ed31eb6b0..000000000 --- a/src/core/META +++ /dev/null @@ -1,60 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: e404fb6f07299c42c89a2c73a5ca8582) -version = "1.4" -description = -"Superposition theorem prover, for first order logic with equality." -requires = "zarith unix sequence containers containers.data bytes" -archive(byte) = "logtk.cma" -archive(byte, plugin) = "logtk.cma" -archive(native) = "logtk.cmxa" -archive(native, plugin) = "logtk.cmxs" -exists_if = "logtk.cma" -package "solving" ( - version = "1.4" - description = - "Superposition theorem prover, for first order logic with equality." - requires = "logtk msat" - archive(byte) = "logtk_solving.cma" - archive(byte, plugin) = "logtk_solving.cma" - archive(native) = "logtk_solving.cmxa" - archive(native, plugin) = "logtk_solving.cmxs" - exists_if = "logtk_solving.cma" -) - -package "proofs" ( - version = "1.4" - description = - "Superposition theorem prover, for first order logic with equality." - requires = "logtk" - archive(byte) = "logtk_proofs.cma" - archive(byte, plugin) = "logtk_proofs.cma" - archive(native) = "logtk_proofs.cmxa" - archive(native, plugin) = "logtk_proofs.cmxs" - exists_if = "logtk_proofs.cma" -) - -package "parsers" ( - version = "1.4" - description = - "Superposition theorem prover, for first order logic with equality." - requires = "logtk" - archive(byte) = "logtk_parsers.cma" - archive(byte, plugin) = "logtk_parsers.cma" - archive(native) = "logtk_parsers.cmxa" - archive(native, plugin) = "logtk_parsers.cmxs" - exists_if = "logtk_parsers.cma" -) - -package "arbitrary" ( - version = "1.4" - description = - "Superposition theorem prover, for first order logic with equality." - requires = "logtk qcheck" - archive(byte) = "logtk_arbitrary.cma" - archive(byte, plugin) = "logtk_arbitrary.cma" - archive(native) = "logtk_arbitrary.cmxa" - archive(native, plugin) = "logtk_arbitrary.cmxs" - exists_if = "logtk_arbitrary.cma" -) -# OASIS_STOP - diff --git a/src/core/Monome.ml b/src/core/Monome.ml index bac906a86..f4bcc3e4f 100644 --- a/src/core/Monome.ml +++ b/src/core/Monome.ml @@ -325,7 +325,7 @@ let fold_max ~ord f acc m = Seq.terms m |> MT.Seq.of_seq MT.empty |> MT.max_seq (Ordering.compare ord) - |> Sequence.map2 (fun t _ -> t) + |> Sequence.map fst |> T.Seq.add_set T.Set.empty in CCList.foldi @@ -732,11 +732,11 @@ let normalize (type a) (m:a t): a t = List.fold_left (fun acc (c,t) -> (* flatten this term into a full monome *) - try - let m = of_term_exn m.num t in - sum acc (product m c) - with NotLinear -> - add acc c t) + try + let m = of_term_exn m.num t in + sum acc (product m c) + with NotLinear -> + add acc c t) acc m.terms module Int = struct diff --git a/src/core/lib/Multiset.ml b/src/core/Multiset.ml similarity index 98% rename from src/core/lib/Multiset.ml rename to src/core/Multiset.ml index 60310d3f6..3655f09c8 100644 --- a/src/core/lib/Multiset.ml +++ b/src/core/Multiset.ml @@ -279,16 +279,17 @@ module Make(E : Map.OrderedType) = struct | Comparison.Incomparable -> acc) !m n in - k x n' + k (x, n') with Exit -> () done let max f m = - max_seq f m |> Sequence.fold2 add_coeff empty + max_seq f m + |> Sequence.fold (fun m (c,t) -> add_coeff m c t) empty let max_l f l = max_seq f (of_list l) - |> Sequence.fold2 (fun acc x _n -> x::acc) [] + |> Sequence.fold (fun acc (x,_) -> x::acc) [] let compare_partial_l f l1 l2 = compare_partial f (of_list l1) (of_list l2) diff --git a/src/core/lib/Multiset.mli b/src/core/Multiset.mli similarity index 100% rename from src/core/lib/Multiset.mli rename to src/core/Multiset.mli diff --git a/src/core/lib/Multiset_intf.ml b/src/core/Multiset_intf.ml similarity index 98% rename from src/core/lib/Multiset_intf.ml rename to src/core/Multiset_intf.ml index 9dc672d9b..f924a5c93 100644 --- a/src/core/lib/Multiset_intf.ml +++ b/src/core/Multiset_intf.ml @@ -140,7 +140,7 @@ module type S = sig val max : (elt -> elt -> Comparison.t) -> t -> t (** Maximal elements of the multiset, w.r.t the given ordering. *) - val max_seq : (elt -> elt -> Comparison.t) -> t -> (elt, Z.t) Sequence.t2 + val max_seq : (elt -> elt -> Comparison.t) -> t -> (elt * Z.t) Sequence.t (** Fold on maximal elements *) val max_l : (elt -> elt -> Comparison.t) -> elt list -> elt list diff --git a/src/core/Ordering.ml b/src/core/Ordering.ml old mode 100755 new mode 100644 index 2c107b6c5..d895f6745 --- a/src/core/Ordering.ml +++ b/src/core/Ordering.ml @@ -377,10 +377,10 @@ module LFHOKBO_arg_coeff : ORD = struct let app_weight head_weight coeff_multipliers args = args |> List.mapi (fun i s -> - begin match weight prec s, coeff_multipliers i with - | Some w, Some c -> Some (c w) - | _ -> None - end ) + begin match weight prec s, coeff_multipliers i with + | Some w, Some c -> Some (c w) + | _ -> None + end ) |> List.fold_left (fun w1 w2 -> begin match (w1, w2) with diff --git a/src/core/lib/ParseLocation.ml b/src/core/ParseLocation.ml similarity index 100% rename from src/core/lib/ParseLocation.ml rename to src/core/ParseLocation.ml diff --git a/src/core/lib/ParseLocation.mli b/src/core/ParseLocation.mli similarity index 100% rename from src/core/lib/ParseLocation.mli rename to src/core/ParseLocation.mli diff --git a/src/core/Polynomial.mli b/src/core/Polynomial.mli index 0184498b5..1369a5e65 100644 --- a/src/core/Polynomial.mli +++ b/src/core/Polynomial.mli @@ -39,12 +39,12 @@ module type S = sig val compare : t -> t -> int (** Compares two polynomials by comparing the coefficients for each monomial: - If all coefficients of p1 >= the corresponding coefficient in p2, - and one is even >, then return 1. - If all coefficients of p1 <= the corresponding coefficient in p2, - and one is even <, then return -1. - If the polynomials are equal, return 0. - If some coefficients are < and some are >, return 0. *) + If all coefficients of p1 >= the corresponding coefficient in p2, + and one is even >, then return 1. + If all coefficients of p1 <= the corresponding coefficient in p2, + and one is even <, then return -1. + If the polynomials are equal, return 0. + If some coefficients are < and some are >, return 0. *) val pp : Format.formatter -> t -> unit end diff --git a/src/core/Position.ml b/src/core/Position.ml index 963091552..c10bb2d07 100644 --- a/src/core/Position.ml +++ b/src/core/Position.ml @@ -87,9 +87,9 @@ let is_strict_prefix p1 p2 = not (equal p1 p2) && is_prefix p1 p2 module Map = struct include CCMap.Make(struct - type t = position - let compare = compare - end) + type t = position + let compare = compare + end) let prune_subsumed (m:_ t): _ t = filter diff --git a/src/core/Proof.ml b/src/core/Proof.ml index abe8c2e1a..156ec8f87 100644 --- a/src/core/Proof.ml +++ b/src/core/Proof.ml @@ -619,7 +619,7 @@ module S = struct List.iter (fun p' -> aux (Parent.proof p')) (Step.parents @@ step proof); - (* yield proof *) + (* yield proof *) k proof ) in diff --git a/src/core/Rewrite.ml b/src/core/Rewrite.ml index 7736d1446..ec2d66408 100644 --- a/src/core/Rewrite.ml +++ b/src/core/Rewrite.ml @@ -453,9 +453,9 @@ module Lit = struct begin match T.view t with | T.Const id -> Some id | T.App (f, _) -> - begin match T.view f with - | T.Const id -> Some id | _ -> assert false - end + begin match T.view f with + | T.Const id -> Some id | _ -> assert false + end | _ -> assert false end | Literal.Equation _ -> None diff --git a/src/core/Rewrite.mli b/src/core/Rewrite.mli index f2ea6713f..ce578d992 100644 --- a/src/core/Rewrite.mli +++ b/src/core/Rewrite.mli @@ -119,9 +119,9 @@ module Lit : sig scope_rules:Scoped.scope -> Literal.t Scoped.t -> (rule * Unif_subst.t * Proof.tag list) Sequence.t - (** [narrow_term rules lit] finds the set of rules [(l --> clauses) in rules] - and substitutions [sigma] such that [sigma(l) = sigma(lit)] - @param scope_rules used for rules (LEFT) *) + (** [narrow_term rules lit] finds the set of rules [(l --> clauses) in rules] + and substitutions [sigma] such that [sigma(l) = sigma(lit)] + @param scope_rules used for rules (LEFT) *) end (** {2 Rules in General} *) diff --git a/src/core/Scoped.ml b/src/core/Scoped.ml index a1ea665cc..99a9abe59 100644 --- a/src/core/Scoped.ml +++ b/src/core/Scoped.ml @@ -2,7 +2,7 @@ (* This file is free software, part of Logtk. See file "license" for more details. *) (** {1 Scoped Value} *) - + type scope = int type +'a t = 'a * scope diff --git a/src/core/Statement.ml b/src/core/Statement.ml index c147c4642..ae312cf1f 100644 --- a/src/core/Statement.ml +++ b/src/core/Statement.ml @@ -527,7 +527,11 @@ module TPTP = struct let pp ppf ppt ppty out st = let name = name st in let pp_decl out (id,ty) = - fpf out "tff(@[%s, type,@ %a :@ @[%a@]@])." name ID.pp_tstp id ppty ty + if ID.is_distinct_object id + then + fpf out "%% (omitted type declaration for distinct object %a.)" ID.pp_tstp id + else + fpf out "tff(@[%s, type,@ %a :@ @[%a@]@])." name ID.pp_tstp id ppty ty and pp_quant_vars out = function | [] -> () | l -> diff --git a/src/core/Subst.ml b/src/core/Subst.ml index 40bdf9452..ca77dc9fe 100644 --- a/src/core/Subst.ml +++ b/src/core/Subst.ml @@ -45,6 +45,12 @@ module Renaming = struct r.n <- r.n + 1; r.map <- M.add var v' r.map; v' + + (* rename variable (after specializing its type if needed) *) + let rename_with_type renaming (v,sc_v) new_ty = + let v' = rename renaming (v,sc_v) in + HVar.cast v' ~ty:new_ty + end (* map from scoped variables, to scoped terms *) @@ -103,9 +109,9 @@ let update let[@inline] remove subst v = M.remove v subst -let restrict_scope subst sc = M.filter (fun (_,sc_v) _ -> sc=sc_v) subst +let filter_scope subst sc = M.filter (fun (_,sc_v) _ -> sc=sc_v) subst -let append s1 s2 = +let merge s1 s2 = M.merge (fun v b1 b2 -> match b1, b2 with | None, _ -> b2 @@ -230,19 +236,18 @@ let[@inline] apply_aux subst ~f_rename t = | T.Var v -> (* the most interesting cases! switch depending on whether [t] is bound by [subst] or not *) - begin - try - let term' = find_exn subst (v,sc_t) in + begin match find_exn subst (v,sc_t) with + | term' -> (* NOTE: if [t'] is not closed, we assume that it is always replaced in a context where variables are properly bound. Typically, that means only in rewriting. *) (* also apply [subst] to [t'] *) aux term' - with Not_found -> + | exception Not_found -> (* rename the variable using [f_rename] *) - let v = f_rename (v,sc_t) ty' in - T.var v + let v' = f_rename (v,sc_t) ty' in + T.var v' end | T.Bind (s, varty, sub_t) -> let varty' = aux (varty,sc_t) in @@ -267,22 +272,11 @@ let[@inline] apply_aux subst ~f_rename t = in aux t -(* variable not bound by [subst], rename it - (after specializing its type if needed) *) -let f_rename_sn renaming (v,sc_v) new_ty = - let v = HVar.cast v ~ty:new_ty in - Renaming.rename renaming (v,sc_v) - +(* Apply substitution to a term and rename variables not bound by [subst]*) let apply renaming subst t = if is_empty subst && Renaming.is_none renaming then fst t else ( - (* variable not bound by [subst], rename it - (after specializing its type if needed) *) - let[@inline] f_rename renaming (v,sc_v) new_ty = - let v = HVar.cast v ~ty:new_ty in - Renaming.rename renaming (v,sc_v) - in - apply_aux subst ~f_rename:(f_rename renaming) t + apply_aux subst ~f_rename:(Renaming.rename_with_type renaming) t ) (** {2 Specializations} *) @@ -401,14 +395,14 @@ module Projection = struct ) else l) [] p.subst - let as_inst ~ctx (sp:t) (vars:_ HVar.t list) : (_,_) Var.Subst.t = + let as_inst ?allow_free_db ~ctx (sp:t) (vars:_ HVar.t list) : (_,_) Var.Subst.t = List.map (fun v -> let t_v = Term.var v in let t = FO.apply (renaming sp) (subst sp) ((t_v,scope sp)) in - Term.Conv.var_to_simple_var ctx v, Term.Conv.to_simple_term ctx t) + Term.Conv.var_to_simple_var ctx v, Term.Conv.to_simple_term ?allow_free_db ctx t) vars |> Var.Subst.of_list @@ -418,4 +412,3 @@ module Projection = struct let pp out (p:t) : unit = Format.fprintf out "%a[%d]" pp p.subst p.scope end - diff --git a/src/core/Subst.mli b/src/core/Subst.mli index 8fe7f6ba2..edf2a68d8 100644 --- a/src/core/Subst.mli +++ b/src/core/Subst.mli @@ -82,13 +82,14 @@ val update : t -> var Scoped.t -> term Scoped.t -> t It is {b important} that the bound term is De-Bruijn-closed (assert). @raise InconsistentBinding if [v] is not yet bound in the same context. *) -val append : t -> t -> t -(** [append s1 s2] is the substitution that maps [t] to [s2 (s1 t)]. *) +val merge : t -> t -> t +(** [merge s1 s2] is the substitution that maps [t] to [(s1 t)] or to [(s2 t)]. + @raise InconsistentBinding if the substitutions disagree. *) val remove : t -> var Scoped.t -> t (** Remove the given binding. No other variable should depend on it... *) -val restrict_scope : t -> Scoped.scope -> t +val filter_scope : t -> Scoped.scope -> t (** Only keep bindings from this scope *) (** {2 Set operations} *) @@ -212,6 +213,7 @@ module Projection : sig in terms of the codomain are bound in the renaming *) val as_inst : + ?allow_free_db:bool -> ctx:Term.Conv.ctx -> t -> Type.t HVar.t list -> diff --git a/src/core/Term.ml b/src/core/Term.ml index a7d51ece0..a6050d922 100644 --- a/src/core/Term.ml +++ b/src/core/Term.ml @@ -777,35 +777,38 @@ module Conv = struct try Some (of_simple_term_exn ctx t) with Type.Conv.Error _ -> None - let to_simple_term ?(env=DBEnv.empty) ctx t = + let to_simple_term ?(allow_free_db=false) ?(env=DBEnv.empty) ctx t = let module ST = TypedSTerm in let n = ref 0 in - let rec to_simple_term env t = + let rec aux_t env t = match view t with | Var i -> ST.var (aux_var i) | DB i -> - begin - try ST.var (DBEnv.find_exn env i) - with Failure _ -> + begin match DBEnv.find env i with + | Some v -> ST.var v + | None when allow_free_db -> + (* encode DB index *) + ST.builtin ~ty:(aux_ty @@ ty t) (Builtin.Pseudo_de_bruijn i) + | None -> Util.errorf ~where:"Term" "cannot find `Y%d`@ @[:in [%a]@]" i (DBEnv.pp Var.pp) env end | Const id -> ST.const ~ty:(aux_ty (ty t)) id | App (f,l) -> ST.app ~ty:(aux_ty (ty t)) - (to_simple_term env f) (List.map (to_simple_term env) l) + (aux_t env f) (List.map (aux_t env) l) | AppBuiltin (b,l) -> ST.app_builtin ~ty:(aux_ty (ty t)) - b (List.map (to_simple_term env) l) + b (List.map (aux_t env) l) | Fun (ty_arg, body) -> let v = Var.makef ~ty:(aux_ty ty_arg) "v_%d" (CCRef.incr_then_get n) in - let body = to_simple_term (DBEnv.push env v) body in + let body = aux_t (DBEnv.push env v) body in ST.bind Binder.Lambda ~ty:(aux_ty (ty t)) v body and aux_var v = Type.Conv.var_to_simple_var ~prefix:"X" ctx v and aux_ty ty = Type.Conv.to_simple_term ~env ctx ty in - to_simple_term env t + aux_t env t end let rebuild_rec t = diff --git a/src/core/Term.mli b/src/core/Term.mli index 37ba9d63c..18f71e35b 100644 --- a/src/core/Term.mli +++ b/src/core/Term.mli @@ -377,6 +377,7 @@ module Conv : sig val of_simple_term : ctx -> TypedSTerm.t -> t option val of_simple_term_exn : ctx -> TypedSTerm.t -> t (** @raise Type.Conv.Error on failure *) val to_simple_term : + ?allow_free_db:bool -> ?env:TypedSTerm.t Var.t DBEnv.t -> ctx -> t -> diff --git a/src/core/Type.ml b/src/core/Type.ml index f17a93144..12a8beda7 100644 --- a/src/core/Type.ml +++ b/src/core/Type.ml @@ -186,9 +186,7 @@ let rec expected_args ty = match view ty with | Forall ty' -> expected_args ty' | DB _ | Var _ | Builtin _ | App _ -> [] -let rec expected_ty_vars ty = match view ty with - | Forall ty' -> 1 + expected_ty_vars ty' - | _ -> 0 +let expected_ty_vars t = T.expected_ty_vars t let needs_args ty = expected_ty_vars ty>0 || expected_args ty<>[] @@ -245,6 +243,9 @@ let apply ty0 args0 = | T.Bind (Binder.ForallTy, _, ty'), arg :: args' -> let arg = T.DB.eval env arg in aux ty' args' (DBEnv.push env arg) + | T.DB _, _ -> + let ty = T.DB.eval env ty in + aux ty args env | _ -> err_applyf_ "@[<2>Type.apply:@ expected quantified or function type,@ but got @[%a@]" diff --git a/src/core/TypeInference.ml b/src/core/TypeInference.ml index 43c4858be..a8afc182e 100644 --- a/src/core/TypeInference.ml +++ b/src/core/TypeInference.ml @@ -36,9 +36,9 @@ let error_on_incomplete_match_ = ref false let () = Options.add_opts [ "--require-exhaustive-matches", Arg.Set error_on_incomplete_match_, - " fail if pattern matches are not exhaustive"; + " fail if pattern matches are not exhaustive"; "--no-require-exhautive-matches", Arg.Clear error_on_incomplete_match_, - " accept non-exhaustive pattern matches"; + " accept non-exhaustive pattern matches"; ] (* error-raising function *) @@ -276,6 +276,10 @@ module Ctx = struct | l -> Fmt.fprintf out " (did you mean any of [@[%a@]]?)" (Util.pp_list Fmt.string) l + (* Does the identifier represent a (TPTP) distinct object? *) + let is_distinct_ s = + String.length s > 2 && s.[0] = '"' && s.[String.length s-1] = '"' + let get_id_ ?loc ~arity ctx name = try match Hashtbl.find ctx.env name with | `ID (id, ty) -> id, ty @@ -291,6 +295,7 @@ module Ctx = struct name pp_names (find_close_names ctx name) T.pp ty; end; let id = ID.make name in + if is_distinct_ name then ID.set_payload id ID.Attr_distinct; Hashtbl.add ctx.env name (`ID (id, ty)); ctx.new_types <- (id, ty) :: ctx.new_types; id, ty @@ -1138,4 +1143,3 @@ let infer_statements (infer_statements_exn ?def_as_rewrite ?on_var ?on_undef ?on_shadow ?ctx ?file ~implicit_ty_args seq) with e -> Err.of_exn_trace e - diff --git a/src/core/TypedSTerm.ml b/src/core/TypedSTerm.ml index 877d42da2..05e2a10cc 100644 --- a/src/core/TypedSTerm.ml +++ b/src/core/TypedSTerm.ml @@ -121,57 +121,57 @@ let rec compare t1 t2 = let h2 = hash t2 in if h1<>h2 then CCInt.compare h1 h2 (* compare by hash, first *) else match view t1, view t2 with - | Var s1, Var s2 -> Var.compare s1 s2 - | Const s1, Const s2 -> ID.compare s1 s2 - | App (s1,l1), App (s2, l2) -> - CCOrd.( - compare s1 s2 - (CCOrd.list compare, l1, l2) - ) - | Bind (s1, v1, t1), Bind (s2, v2, t2) -> - CCOrd.( - Binder.compare s1 s2 - (compare, v1, v2) - (compare, t1, t2) - ) - | AppBuiltin (b1,l1), AppBuiltin (b2,l2) -> - CCOrd.( - Builtin.compare b1 b2 - (CCOrd.list compare, l1, l2) - ) - | Multiset l1, Multiset l2 -> - let l1 = List.sort compare l1 and l2 = List.sort compare l2 in - CCOrd.list compare l1 l2 - | Record (l1, rest1), Record (l2, rest2) -> - CCOrd.( - CCOpt.compare compare rest1 rest2 - (cmp_fields, l1, l2) - ) - | Meta (id1,_,_), Meta (id2,_,_) -> Var.compare id1 id2 - | Ite (a1,b1,c1), Ite (a2,b2,c2) -> - CCList.compare compare [a1;b1;c1] [a2;b2;c2] - | Let (l1,t1), Let (l2,t2) -> - CCOrd.( compare t1 t2 - (list (pair Var.compare compare), l1, l2)) - | Match (u1,l1), Match (u2,l2) -> - let cmp_branch (c1,vars1,rhs1) (c2,vars2,rhs2) = - CCOrd.(ID.compare c1.cstor_id c2.cstor_id - (list compare, c1.cstor_args, c2.cstor_args) - (list Var.compare, vars1,vars2) - (compare,rhs1,rhs2)) - in - CCOrd.( compare u1 u2 (list cmp_branch,l1,l2)) - | Var _, _ - | Const _, _ - | App _, _ - | Bind _, _ - | Ite _, _ - | Let _, _ - | Match _, _ - | Multiset _, _ - | AppBuiltin _, _ - | Meta _, _ - | Record _, _ -> to_int_ t1.term - to_int_ t2.term + | Var s1, Var s2 -> Var.compare s1 s2 + | Const s1, Const s2 -> ID.compare s1 s2 + | App (s1,l1), App (s2, l2) -> + CCOrd.( + compare s1 s2 + (CCOrd.list compare, l1, l2) + ) + | Bind (s1, v1, t1), Bind (s2, v2, t2) -> + CCOrd.( + Binder.compare s1 s2 + (compare, v1, v2) + (compare, t1, t2) + ) + | AppBuiltin (b1,l1), AppBuiltin (b2,l2) -> + CCOrd.( + Builtin.compare b1 b2 + (CCOrd.list compare, l1, l2) + ) + | Multiset l1, Multiset l2 -> + let l1 = List.sort compare l1 and l2 = List.sort compare l2 in + CCOrd.list compare l1 l2 + | Record (l1, rest1), Record (l2, rest2) -> + CCOrd.( + CCOpt.compare compare rest1 rest2 + (cmp_fields, l1, l2) + ) + | Meta (id1,_,_), Meta (id2,_,_) -> Var.compare id1 id2 + | Ite (a1,b1,c1), Ite (a2,b2,c2) -> + CCList.compare compare [a1;b1;c1] [a2;b2;c2] + | Let (l1,t1), Let (l2,t2) -> + CCOrd.( compare t1 t2 + (list (pair Var.compare compare), l1, l2)) + | Match (u1,l1), Match (u2,l2) -> + let cmp_branch (c1,vars1,rhs1) (c2,vars2,rhs2) = + CCOrd.(ID.compare c1.cstor_id c2.cstor_id + (list compare, c1.cstor_args, c2.cstor_args) + (list Var.compare, vars1,vars2) + (compare,rhs1,rhs2)) + in + CCOrd.( compare u1 u2 (list cmp_branch,l1,l2)) + | Var _, _ + | Const _, _ + | App _, _ + | Bind _, _ + | Ite _, _ + | Let _, _ + | Match _, _ + | Multiset _, _ + | AppBuiltin _, _ + | Meta _, _ + | Record _, _ -> to_int_ t1.term - to_int_ t2.term and cmp_field x y = CCOrd.pair String.compare compare x y and cmp_fields x y = CCOrd.list cmp_field x y @@ -1036,8 +1036,13 @@ end exception UnifyFailure of string * (term * term) list * location option let pp_stack out l = + let pp_ty out = function + | None -> () + | Some ty -> Format.fprintf out ":%a" pp ty + in let pp_frame out (t1,t2) = - Format.fprintf out "@[unifying `@[%a@]` and `@[%a@]`@]" pp t1 pp t2 + Format.fprintf out "@[unifying `@[%a@,%a@]` and `@[%a@,%a@]`@]" + pp t1 pp_ty (ty t1) pp t2 pp_ty (ty t2) in Format.fprintf out "@[%a@]" (Util.pp_list pp_frame) l diff --git a/src/core/Unif.ml b/src/core/Unif.ml index c04ddd4d6..4ce5486d2 100644 --- a/src/core/Unif.ml +++ b/src/core/Unif.ml @@ -214,7 +214,27 @@ module Inner = struct begin match T.view t with | T.Var v -> begin match Subst.find (US.subst subst) (v,sc_t) with - | Some (u,sc_u) -> aux sc_u subst u + | Some (u,sc_u) -> + if sc_t = scope + then + (* Variable is already in [scope] *) + let subst, u' = aux sc_u subst u in + let subst = US.update subst (v,scope) (u', scope) in + subst, T.var v + else if T.is_var u && sc_u = scope + then + (* We already have a corresponging variable in [scope]. Use that one.*) + subst, u + else ( + (* Create a corresponding variable v' in [scope]. *) + let v' = HVar.fresh ~ty () in + (* Recursive call on u, giving u' *) + let subst, u' = aux sc_u subst u in + (* Modify the substitution from v -> u into v -> v', v' -> u' *) + let subst = US.update subst (v,sc_t) (T.var v', scope) in + let subst = US.bind subst (v',scope) (u', scope) in + subst, T.var v' + ) | None -> if sc_t = scope then subst, T.var (HVar.cast ~ty v) @@ -360,7 +380,7 @@ module Inner = struct let restrict_fun1 : unif_subst -> ty:T.t -> to_:T.t DBEnv.t -> scope:Scoped.scope -> - (_ HVar.t * T.t list) -> unif_subst + (_ HVar.t * T.t list) -> unif_subst = fun subst ~ty ~to_:subset ~scope (v,args) -> assert (not (US.mem subst (v,scope))); (* only keep bound args *) @@ -392,7 +412,7 @@ module Inner = struct [λall_vars. H (l1 ∩ l2)] *) let restrict_fun2 : unif_subst -> ty_ret:T.t -> bvars:B_vars.t -> scope:Scoped.scope -> - _ -> _ -> unif_subst + _ -> _ -> unif_subst = fun subst ~ty_ret ~bvars ~scope (v1,l1) (v2,l2) -> assert (not (HVar.equal T.equal v1 v2)); (* non-trivial *) assert (not (US.mem subst (v1,scope))); @@ -416,10 +436,10 @@ module Inner = struct let n = List.length l in let args = List.map - (fun a -> - let i = CCList.find_idx (T.equal a) l |> CCOpt.get_exn |> fst in - T.bvar ~ty:(T.ty_exn a) (n-i-1)) - inter + (fun a -> + let i = CCList.find_idx (T.equal a) l |> CCOpt.get_exn |> fst in + T.bvar ~ty:(T.ty_exn a) (n-i-1)) + inter in let body = T.app ~ty:ty_ret (T.var f) args in T.fun_l (List.map T.ty_exn l) body @@ -480,6 +500,7 @@ module Inner = struct (*Format.printf "(@[unif_rec@ :t1 `%a`@ :t2 `%a`@ :op %a@ :subst @[%a@]@ :bvars %a@])@." (Scoped.pp T.pp) (t1,sc1) (Scoped.pp T.pp) (t2,sc2) pp_op op US.pp subst B_vars.pp bvars;*) + assert (not (T.is_a_type t1 && Type.is_forall (Type.of_term_unsafe t1))); begin match view1, view2 with | _ when sc1=sc2 && T.equal t1 t2 -> subst (* the terms are equal under any substitution *) @@ -648,8 +669,8 @@ module Inner = struct in unif_rec ~op ~root:false ~bvars:(B_vars.make - (DBEnv.push_l_rev bvars.B_vars.left new_vars1) - (DBEnv.push_l_rev bvars.B_vars.right new_vars2)) + (DBEnv.push_l_rev bvars.B_vars.left new_vars1) + (DBEnv.push_l_rev bvars.B_vars.right new_vars2)) subst (f1,scope) (f2,scope) | T.Bind (Binder.Lambda, _, _), _ -> (* [λx. t = u] becomes [t = u x] *) @@ -658,8 +679,8 @@ module Inner = struct let n = List.length new_vars in unif_rec ~op ~root ~bvars:(B_vars.make - (DBEnv.push_l_rev bvars.B_vars.left new_vars) - (DBEnv.push_l_rev bvars.B_vars.right new_vars)) + (DBEnv.push_l_rev bvars.B_vars.left new_vars) + (DBEnv.push_l_rev bvars.B_vars.right new_vars)) subst (f1,scope) (T.app ~ty:(T.ty_exn f1) @@ -672,8 +693,8 @@ module Inner = struct let n = List.length new_vars in unif_rec ~op ~root ~bvars:(B_vars.make - (DBEnv.push_l_rev bvars.B_vars.left new_vars) - (DBEnv.push_l_rev bvars.B_vars.right new_vars)) + (DBEnv.push_l_rev bvars.B_vars.left new_vars) + (DBEnv.push_l_rev bvars.B_vars.right new_vars)) subst (T.app ~ty:(T.ty_exn f2) (T.DB.shift n t1) @@ -720,9 +741,13 @@ module Inner = struct ) else if l2<>[] then ( (* λfree-HO: unify with currying, "from the right" *) let l1, l2 = pair_lists_right f1 l1 f2 l2 in + (* Variables do not take type arguments. So we can fail early if `hd l2` + does take type arguments. This avoids errors with the debug output. *) + assert (T.expected_ty_vars (HVar.ty v1) = 0); + if T.expected_ty_vars (T.ty_exn (List.hd l2)) != 0 then fail(); unif_list ~op ~bvars subst l1 scope l2 scope ) else fail() - | T.Const _, T.Var _ -> + | T.Const _, T.Var v2 -> (*Format.printf "(@[unif_ho.flex_rigid@ `@[:f2 %a :l2 %a@]`@ :t1 `%a`@ :subst %a@ :bvars %a@])@." (Scoped.pp T.pp) (f2,scope) (CCFormat.Dump.list T.pp) l2 @@ -737,6 +762,10 @@ module Inner = struct ) else if l1<>[] then ( (* λfree-HO: unify with currying, "from the right" *) let l1, l2 = pair_lists_right f1 l1 f2 l2 in + (* Variables do not take type arguments. So we can fail early if `hd l1` + does take type arguments. This avoids errors with the debug output. *) + assert (T.expected_ty_vars (HVar.ty v2) = 0); + if T.expected_ty_vars (T.ty_exn (List.hd l1)) != 0 then fail(); unif_list ~op ~bvars subst l1 scope l2 scope ) else fail() | T.Var v1, T.Var v2 diff --git a/src/core/Unif_subst.ml b/src/core/Unif_subst.ml index 2e2253940..5c7c6274d 100644 --- a/src/core/Unif_subst.ml +++ b/src/core/Unif_subst.ml @@ -34,6 +34,7 @@ let of_subst s = make s [] let tags (s:t) : _ list = CCList.flat_map Unif_constr.tags (constr_l s) let bind t v u = {t with subst=Subst.bind t.subst v u} +let update t v u = {t with subst=Subst.update t.subst v u} let mem t v = Subst.mem t.subst v let deref t v = Subst.deref t.subst v diff --git a/src/core/Unif_subst.mli b/src/core/Unif_subst.mli index a840ec8b2..832bacf7d 100644 --- a/src/core/Unif_subst.mli +++ b/src/core/Unif_subst.mli @@ -46,6 +46,8 @@ val deref : t -> term Scoped.t -> term Scoped.t val bind : t -> var Scoped.t -> term Scoped.t -> t +val update : t -> var Scoped.t -> term Scoped.t -> t + val mem : t -> var Scoped.t -> bool module FO : sig diff --git a/src/core/lib/UnionFind.ml b/src/core/UnionFind.ml similarity index 100% rename from src/core/lib/UnionFind.ml rename to src/core/UnionFind.ml diff --git a/src/core/lib/UnionFind.mli b/src/core/UnionFind.mli similarity index 100% rename from src/core/lib/UnionFind.mli rename to src/core/UnionFind.mli diff --git a/src/core/Util.ml b/src/core/Util.ml index dc6ec0225..b144b7533 100644 --- a/src/core/Util.ml +++ b/src/core/Util.ml @@ -361,7 +361,7 @@ let pp_list0 ?(sep=" ") pp_x out = function let tstp_needs_escaping s = assert (s<>""); s.[0] = '_' || - CCString.exists (function '#' | '$' | '+' | '-' -> true | _ -> false) s + CCString.exists (function ' ' | '#' | '$' | '+' | '-' | '/' -> true | _ -> false) s let pp_str_tstp out s = CCFormat.string out (if tstp_needs_escaping s then "'" ^ String.escaped s ^ "'" else s) @@ -404,6 +404,10 @@ let seq_map_l ~f l = in aux l +let seq_zipi seq k = + let i = ref 0 in + seq (fun x -> k (!i, x); incr i) + let invalid_argf msg = Fmt.ksprintf msg ~f:invalid_arg let failwithf msg = Fmt.ksprintf msg ~f:failwith diff --git a/src/core/Util.mli b/src/core/Util.mli index ad82b3931..beafeb277 100644 --- a/src/core/Util.mli +++ b/src/core/Util.mli @@ -187,6 +187,7 @@ val take_drop_while : ('a -> bool) -> 'a list -> 'a list * 'a list val map_product : f:('a -> 'b list list) -> 'a list -> 'b list list val seq_map_l : f:('a -> 'b list) -> 'a list -> 'b list Sequence.t +val seq_zipi : 'a Sequence.t -> (int * 'a) Sequence.t val invalid_argf: ('a, Format.formatter, unit, 'b) format4 -> 'a val failwithf : ('a, Format.formatter, unit, 'b) format4 -> 'a diff --git a/src/core/jbuild b/src/core/jbuild new file mode 100644 index 000000000..45d98689a --- /dev/null +++ b/src/core/jbuild @@ -0,0 +1,18 @@ +; vim:ft=lisp: + +(jbuild_version 1) + +; main lib +(library + ((name logtk) + (public_name logtk) + (synopsis "core data structures and algorithms for Logtk") + (libraries (containers containers.data sequence zarith unix)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -bin-annot + -unbox-closures -unbox-closures-factor 20)) + (c_names (util_stubs)) + (c_flags (-Wextra -Wno-unused-parameter)) + )) + + diff --git a/src/core/liblibzipperposition_stubs.clib b/src/core/liblibzipperposition_stubs.clib deleted file mode 100644 index 5b5c99043..000000000 --- a/src/core/liblibzipperposition_stubs.clib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 7ba715c437ed36100f01758f71aa8dda) -util_stubs.o -# OASIS_STOP diff --git a/src/core/liblogtk_stubs.clib b/src/core/liblogtk_stubs.clib deleted file mode 100644 index 5b5c99043..000000000 --- a/src/core/liblogtk_stubs.clib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 7ba715c437ed36100f01758f71aa8dda) -util_stubs.o -# OASIS_STOP diff --git a/src/core/libzipperposition.mldylib b/src/core/libzipperposition.mldylib deleted file mode 100644 index b1c6f1371..000000000 --- a/src/core/libzipperposition.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 588fb5f222ac7d91454195051b1c7249) -Libzipperposition -# OASIS_STOP diff --git a/src/core/libzipperposition.mllib b/src/core/libzipperposition.mllib deleted file mode 100644 index b1c6f1371..000000000 --- a/src/core/libzipperposition.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 588fb5f222ac7d91454195051b1c7249) -Libzipperposition -# OASIS_STOP diff --git a/src/core/libzipperposition.mlpack b/src/core/libzipperposition.mlpack deleted file mode 100644 index 78864e0a1..000000000 --- a/src/core/libzipperposition.mlpack +++ /dev/null @@ -1,49 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 215a833b4907acf01732d8918d2660eb) -InnerTerm -FOTerm -Type -Util -STerm -Interfaces -DBEnv -Position -Var -HVar -Substs -Unif -Signature -Scoped -Unif_intf -TypeInference -Options -Comparison -Precedence -Builtin -Ordering -Skolem -Cnf -ID -IDOrBuiltin -SLiteral -Index -Index_intf -Dtree -Fingerprint -NPDtree -Binder -Congruence -FeatureVector -UntypedAST -Ind_ty -TypedSTerm -Statement -StatementSrc -lib/Hashcons -lib/ParseLocation -lib/Multiset -lib/LazyList -lib/IArray -lib/AllocCache -lib/Multiset_intf -# OASIS_STOP diff --git a/src/core/logtk.mld b/src/core/logtk.mld new file mode 100644 index 000000000..0cc1356a1 --- /dev/null +++ b/src/core/logtk.mld @@ -0,0 +1,5 @@ + +This is the API documentation for Logtk (the library for terms, formulas, +literals, unification, type inference, etc.), + +{!modules: Logtk } diff --git a/src/core/logtk.mldylib b/src/core/logtk.mldylib deleted file mode 100644 index 114bbbb1d..000000000 --- a/src/core/logtk.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3d92770ae9ec204db85a5429cb42b5bc) -Logtk -# OASIS_STOP diff --git a/src/core/logtk.mllib b/src/core/logtk.mllib deleted file mode 100644 index 114bbbb1d..000000000 --- a/src/core/logtk.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3d92770ae9ec204db85a5429cb42b5bc) -Logtk -# OASIS_STOP diff --git a/src/core/logtk.mlpack b/src/core/logtk.mlpack deleted file mode 100644 index 4c04ced12..000000000 --- a/src/core/logtk.mlpack +++ /dev/null @@ -1,73 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 34fa01a343c7c65712ca3bc4a9c43388) -InnerTerm -Term -Type -Util -STerm -Interfaces -DBEnv -Position -Var -HVar -Defined_pos -Subst -Signature -Scoped -Unif -Unif_intf -Unif_constr -Unif_subst -HO_unif -TypeInference -Options -Comparison -Precedence -Builtin -Ordering -Skolem -Cnf -ID -Head -SLiteral -Index -Index_intf -Dtree -Fingerprint -NPDtree -Binder -Congruence -Congruence_intf -Lambda -FeatureVector -FV_tree -UntypedAST -Ind_ty -TypedSTerm -Statement -Flex_state -Compute_prec -Ordinal -Polynomial -Rewrite -Test_prop -Input_format -Output_format -Proof -Multisets -Literal -Literals -Int_lit -Rat_lit -Monome -lib/Hashcons -lib/ParseLocation -lib/Multiset -lib/LazyList -lib/Hash -lib/IArray -lib/AllocCache -lib/Multiset_intf -lib/Signal -lib/UnionFind -# OASIS_STOP diff --git a/src/core/lib/signal.ml b/src/core/signal.ml similarity index 100% rename from src/core/lib/signal.ml rename to src/core/signal.ml diff --git a/src/core/lib/signal.mli b/src/core/signal.mli similarity index 100% rename from src/core/lib/signal.mli rename to src/core/signal.mli diff --git a/src/demo/resolution/.merlin b/src/demo/resolution/.merlin deleted file mode 100644 index 2ba616962..000000000 --- a/src/demo/resolution/.merlin +++ /dev/null @@ -1 +0,0 @@ -REC diff --git a/src/demo/resolution/jbuild b/src/demo/resolution/jbuild new file mode 100644 index 000000000..9992cf6c3 --- /dev/null +++ b/src/demo/resolution/jbuild @@ -0,0 +1,13 @@ + +; vim:ft=lisp: + +(jbuild_version 1) + +(executable + ((name resolution1) + (libraries (logtk logtk.parsers containers sequence)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -color always + -unbox-closures -unbox-closures-factor 20)) + )) + diff --git a/src/hornet/Bool_lit.ml b/src/hornet/Bool_lit.ml deleted file mode 100644 index 7b3962c00..000000000 --- a/src/hornet/Bool_lit.ml +++ /dev/null @@ -1,124 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -open Logtk -open Hornet_types - -module FI = Msat.Formula_intf -module Fmt = CCFormat -module C = Clause - -module Int_map = Util.Int_map - -(** {2 Basics} *) - -type atom = Hornet_types.bool_atom -type proof = Hornet_types.proof -type t = Hornet_types.bool_lit -type view = Hornet_types.bool_atom - -let atom t = t.bl_atom -let sign t = t.bl_sign -let view t = t.bl_atom -let neg = Hornet_types_util.neg_bool_lit -let to_int = Hornet_types_util.int_of_bool_lit - -let norm (t:t): t * FI.negated = - if t.bl_sign - then t, FI.Same_sign - else neg t, FI.Negated - -let equal = Hornet_types_util.equal_bool_lit -let hash = Hornet_types_util.hash_bool_lit -let compare = Hornet_types_util.compare_bool_lit -let pp = Hornet_types_util.pp_bool_lit -let to_string = Fmt.to_string pp -let print = pp - -(** {2 Constructors} *) - -type state = { - mutable count: int; (* for fresh counters *) - box_tbl : atom C.Tbl_mod_alpha.t; - (* map [clause -> atom] modulo alpha, for components *) - ground_tbl: atom Lit.Tbl.t; - (* map [ground positive lit -> atom] *) -} - -let create_state() : state = { - count=1; - box_tbl=C.Tbl_mod_alpha.create 64; - ground_tbl=Lit.Tbl.create 64; -} - -let make_ bl_sign bl_atom : t = {bl_atom; bl_sign} - -(* stateless *) -let dummy = make_ true (A_fresh 0) - -let of_atom ?(sign=true) a = make_ sign a - -let fresh_atom_id_ state: int = - let n = state.count in - state.count <- n+1; - n - -let fresh state = - make_ true (A_fresh (fresh_atom_id_ state)) - -(* unit ground literal. *) -let ground state (lit:Lit.t): t = - assert (Lit.is_ground lit); - let atom = - try Lit.Tbl.find state.ground_tbl lit - with Not_found -> - let atom = - A_ground { - bool_ground_lit=lit; - bool_ground_id=fresh_atom_id_ state; - bool_ground_instance_of=[]; - } - in - Lit.Tbl.add state.ground_tbl lit atom; - atom - in - make_ true atom - -let box_clause state c = - (* make a [Clause c] literal *) - let a = - try C.Tbl_mod_alpha.find state.box_tbl c - with Not_found -> - let a = A_box_clause { - bool_box_clause=c; - bool_box_id=fresh_atom_id_ state; - bool_box_depends=[]; - } - in - C.Tbl_mod_alpha.add state.box_tbl c a; - a - in - make_ true a - -(** {2 Boolean Clauses} *) - -type bool_clause = t list - -let equal_clause = CCList.equal equal -let hash_clause = Hash.list hash -let pp_clause = Hornet_types_util.pp_bool_clause - -(** {2 Boolean Trails} *) - -type bool_trail = Hornet_types.bool_trail - -let pp_trail = Hornet_types_util.pp_bool_trail - -(** {2 Containers} *) - -module As_key = struct - type t = bool_lit - let equal = equal - let hash = hash -end -module Tbl = CCHashtbl.Make(As_key) diff --git a/src/hornet/Bool_lit.mli b/src/hornet/Bool_lit.mli deleted file mode 100644 index cd1e8b5bb..000000000 --- a/src/hornet/Bool_lit.mli +++ /dev/null @@ -1,58 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Bool Literals} *) - -(** The goal is to encapsulate objects into boolean literals that can be - handled by the SAT solver *) - -open Hornet_types - -(** {2 Basics} *) - -type atom = Hornet_types.bool_atom -type t = Hornet_types.bool_lit -type proof = Hornet_types.proof -type view = Hornet_types.bool_atom - -include Msat.Formula_intf.S with type t := t and type proof := proof - -val view : t -> view -val atom : t -> atom -val sign : t -> bool -val to_int : t -> int - -include Interfaces.PRINT with type t := t -include Interfaces.HASH with type t := t -include Interfaces.ORD with type t := t - -(** {2 Constructors} *) - -type state -(** A mutable state that is used to allocate fresh literals *) - -val create_state: unit -> state - -val of_atom : ?sign:bool -> atom -> t - -val fresh : state -> t -val box_clause : state -> clause -> t -val ground : state -> lit -> t - -(** {2 Boolean Clauses} *) - -type bool_clause = t list - -val equal_clause : bool_clause -> bool_clause -> bool -val hash_clause : bool_clause -> int -val pp_clause : bool_clause CCFormat.printer - -(** {2 Boolean Trails} *) - -type bool_trail = Hornet_types.bool_trail - -val pp_trail : bool_trail CCFormat.printer - -(** {2 Containers} *) - -module Tbl : CCHashtbl.S with type key = t diff --git a/src/hornet/Classify_cst.ml b/src/hornet/Classify_cst.ml deleted file mode 100644 index 5f1840fd7..000000000 --- a/src/hornet/Classify_cst.ml +++ /dev/null @@ -1,72 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Classification of Constants} *) - -open Logtk - -type res = - | Ty of Ind_ty.t - | Cstor of Ind_ty.constructor * Ind_ty.t - (* | Inductive_cst of Ind_cst.cst option *) - | Projector of ID.t (** projector of some constructor (id: type) *) - | DefinedCst of int (** (recursive) definition of given stratification level *) - | Other - -let classify id = - let rec aux = function - | [] -> Other - | p :: tail -> - begin match p id with - | None -> aux tail - | Some x -> x - end - in - let (|>>) p f id = match p id with | None -> None | Some x -> Some (f x) in - aux - [ (Ind_ty.as_constructor |>> fun (c,t) -> Cstor (c,t)); - (Ind_ty.as_inductive_ty |>> fun x -> Ty x); - (Ind_ty.as_projector |>> fun p -> Projector (Ind_ty.projector_id p)); - (Rewrite.as_defined_cst |>> fun cst -> - DefinedCst (Rewrite.Defined_cst.level cst)); - ] - -let pp_res out = function - | Ty _ -> Format.fprintf out "ind_ty" - | Cstor (_, ity) -> Format.fprintf out "cstor of %a" Ind_ty.pp ity - | Projector id -> Format.fprintf out "projector_%a" ID.pp id - | DefinedCst lev -> Format.fprintf out "defined (level %d)" lev - | Other -> CCFormat.string out "other" - -let pp_signature out sigma = - let pp_pair out (id,ty) = - Format.fprintf out "(@[%a : %a (%a)@])" ID.pp id Type.pp ty pp_res (classify id) - in - Format.fprintf out - "{@[%a@]}" (Util.pp_list ~sep:"," pp_pair) (Signature.to_list sigma) - -let prec_constr_ a b = - let to_int_ = function - | Ty _ -> 0 - | DefinedCst _ -> 5 (* try to make defined smaller, so that constraints are pure *) - | Projector _ -> 10 - | Cstor _ -> 20 - | Other -> 40 - in - let c_a = classify a in - let c_b = classify b in - match c_a, c_b with - | Ty _, Ty _ - | Cstor _, Cstor _ - | Projector _, Projector _ - | Other, Other -> 0 - | DefinedCst l1, DefinedCst l2 -> - (* bigger level means defined later *) - CCInt.compare l1 l2 - | Ty _, _ - | Cstor _, _ - | Projector _, _ - | DefinedCst _, _ - | Other, _ -> CCInt.compare (to_int_ c_a) (to_int_ c_b) - -let prec_constr = Precedence.Constr.make prec_constr_ diff --git a/src/hornet/Classify_cst.mli b/src/hornet/Classify_cst.mli deleted file mode 100644 index 2949cd697..000000000 --- a/src/hornet/Classify_cst.mli +++ /dev/null @@ -1,27 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Classification of Constants} *) - -open Logtk - -type res = - | Ty of Ind_ty.t - | Cstor of Ind_ty.constructor * Ind_ty.t - (* | Inductive_cst of Ind_cst.cst option *) - | Projector of ID.t (** projector of some constructor (id: type) *) - | DefinedCst of int (** (recursive) definition of given stratification level *) - | Other - -val classify : ID.t -> res -(** [classify id] returns the role [id] plays in inductive reasoning *) - -val pp_res : res CCFormat.printer - -val pp_signature : Signature.t CCFormat.printer -(** Print classification of signature *) - -val prec_constr : [`partial] Precedence.Constr.t -(** Partial order on [ID.t], with: - regular > constant > sub_constant > cstor *) - diff --git a/src/hornet/Clause.ml b/src/hornet/Clause.ml deleted file mode 100644 index 82b75247f..000000000 --- a/src/hornet/Clause.ml +++ /dev/null @@ -1,229 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 General representation of Clauses} *) - -open Logtk - -module BV = CCBV -module Fmt = CCFormat -module PW = Position.With -module S = Subst -module T = Term - -open Hornet_types - -type t = Hornet_types.clause -type clause = t - -type idx = Hornet_types.clause_idx - -(** {2 Basics} *) - -let lits c = c.c_lits -let proof c = c.c_proof -let constr c = c.c_constr -let trail c = c.c_trail -let depth c = c.c_depth - -let dismatch_constr c = c.c_constr.constr_dismatch - -let equal = Hornet_types_util.equal_clause -let hash = Hornet_types_util.hash_clause -let compare = Hornet_types_util.compare_clause -let pp = Hornet_types_util.pp_clause -let to_string = Fmt.to_string pp - -(* comparison function that makes the positif literal smaller, then - favors other literals by heuristic *) -let compare_lits_for_horn_ (l1:Lit.t) (l2:Lit.t) : int = - let sign1 = Lit.sign l1 in - let sign2 = Lit.sign l2 in - (* make positive lit smaller *) - if sign1<>sign2 - then if sign1 then (assert (not sign2); -1) - else (assert sign2; 1) - else ( - let n_vars1 = Lit.vars_set l1 |> List.length in - let n_vars2 = Lit.vars_set l2 |> List.length in - CCOrd.( int n_vars1 n_vars2 (int, Lit.weight l1, Lit.weight l2) ) - ) - -let kind_of_lits ~trail ~constr (c_lits:Lit.t IArray.t) proof: c_kind = - (* positive literals *) - let pos = - IArray.to_seqi c_lits - |> Sequence.filter (fun (_,lit) -> Lit.sign lit) - |> Sequence.to_rev_list - in - let mk_body arr = - Array.sort compare_lits_for_horn_ arr; (* sort body in some order *) - IArray.of_array_unsafe arr - and mk_horn head body = - lazy ( - Horn_clause.make head body proof - ~constr ~trail ~unordered_depth:0 ~label:[]) - in - begin match pos with - | [] -> - (* negative clause: actually a horn clause with head [false] *) - let head = Lit.false_ in - let body = - Array.init (IArray.length c_lits) (fun i->Lit.neg (IArray.get c_lits i)) - |> mk_body - in - let hc = mk_horn head body in - C_horn hc - | [i,_] -> - let head = IArray.get c_lits i in - let body = - Array.init (IArray.length c_lits-1) - (fun j -> - let lit = - if j mk_body - in - let hc = mk_horn head body in - C_horn hc - | _ -> C_general - end - -(** How to build a clause from a ['a] and other parameters *) -type 'a builder = - trail:bool_trail -> - constr:c_constraint -> - depth:int -> - 'a -> - proof -> - t - -(* Smart constructor: might sort the literals for Horn clauses. - The conclusion comes first, then the remaining ones with some heuristic - ordering. *) -let make_ = - let n_ = ref 0 in - fun c_trail c_depth c_constr c_kind c_lits c_proof -> - let c_id = CCRef.incr_then_get n_ in - { c_id; c_depth; c_constr; c_trail; - c_select=None; c_grounding=None; c_lits; c_kind; c_proof } - -let make ~trail ~constr ~depth c_lits proof: t = - let c_kind = kind_of_lits ~trail ~constr c_lits proof in - make_ trail depth constr c_kind c_lits proof - -let make_l ~trail ~constr ~depth lits proof : t = - make ~trail ~constr ~depth (IArray.of_list lits) proof - -let hash_mod_alpha c : int = - IArray.hash_comm Lit.hash_mod_alpha c.c_lits - -let select c = c.c_select - -let select_exn c = match select c with - | Some s -> s - | None -> - Util.errorf ~where:"clause.select_exn" "clause `%a`@ has no selected lit" pp c - -let set_select c (s:select_lit): unit = match c.c_select with - | Some _ -> Util.errorf ~where:"clause.set_select" "literal already selected" - | None -> c.c_select <- Some s - -let clear_select c = match c.c_select with - | Some _ -> c.c_select <- None - | None -> - Util.errorf ~where:"clause.clear_select" "no literal currently selected in@ %a" pp c - -let grounding c = c.c_grounding - -let grounding_exn c = match c.c_grounding with - | Some g -> g - | None -> - Util.errorf ~where:"clause.grounding_exn" "no grounding for@ %a" pp c - -let set_grounding c g = match c.c_grounding with - | None -> c.c_grounding <- Some g - | Some _ -> - Util.errorf ~where:"clause.set_grounding" "`%a`@ already grounded" pp c - -let is_empty c = IArray.length c.c_lits = 0 - -let lits_seq c = IArray.to_seqi c.c_lits - -let vars_seq c = - IArray.to_seq c.c_lits - |> Sequence.flat_map Lit.vars_seq - -let vars_l c = vars_seq c |> T.VarSet.of_seq |> T.VarSet.to_list - -(** {2 Classification} *) - -(** Some clauses are Horn, some are unit equations, some are unit, - and the others are general *) - -type kind = - | Horn of horn_clause - | General - -let classify (c:t): kind = match c.c_kind with - | C_horn c -> Horn (Lazy.force c) - | C_general -> General - -let is_horn c = match c.c_kind with - | C_horn _ -> true - | C_general -> false - -let is_ground c : bool = - IArray.for_all Lit.is_ground (lits c) - -let is_unit_ground c : bool = - IArray.length c.c_lits = 1 && Lit.is_ground (IArray.get (lits c) 0) - -(** {2 Utils} *) - -let of_slit_l ~stmt lits : t = - let conv_slit = function - | SLiteral.True -> Lit.true_ - | SLiteral.False -> Lit.false_ - | SLiteral.Atom (t,b) -> Lit.atom ~sign:b t - | SLiteral.Eq (s,t) -> Lit.eq s t - | SLiteral.Neq (s,t) -> Lit.eq ~sign:false s t - in - let lits = List.map conv_slit lits in - let proof = Proof.from_stmt stmt in - make_l ~constr:Constraint.empty ~trail:H_trail.empty ~depth:0 lits proof - -let is_trivial c = - IArray.exists Lit.is_trivial c.c_lits || - begin - IArray.to_seqi c.c_lits - |> Sequence.exists - (fun (i,lit) -> - IArray.to_seqi c.c_lits - |> Sequence.exists (fun (j,lit') -> i - constr:c_constraint -> - depth:int -> - 'a -> - proof -> - t - -val make : Lit.t IArray.t builder -val make_l : Lit.t list builder - -val proof : t -> proof -val lits : t -> Lit.t IArray.t -val trail : t -> bool_trail -val constr : t -> c_constraint -val depth : t -> int - -val dismatch_constr : t -> Dismatching_constr.t list - -val set_select : t -> select_lit -> unit -val clear_select : t -> unit -val select : t -> select_lit option -val select_exn : t -> select_lit - -val grounding : t -> bool_lit IArray.t option -val grounding_exn : t -> bool_lit IArray.t -val set_grounding : t -> bool_lit IArray.t -> unit - -val is_empty : t -> bool - -include Interfaces.ORD with type t := t -include Interfaces.HASH with type t := t -include Interfaces.PRINT with type t := t - -val hash_mod_alpha : t -> int - -(** The index of a literal in the clause *) - -val lits_seq : t -> (idx * Lit.t) Sequence.t - -val vars_seq : t -> Type.t HVar.t Sequence.t - -val vars_l : t -> Type.t HVar.t list - -(** {2 Classification} *) - -(** Some clauses are Horn, some are unit equations, some are unit, - and the others are general *) - -type kind = - | Horn of horn_clause - | General - -val classify : t -> kind - -val is_ground : t -> bool -val is_unit_ground : t -> bool -val is_horn : t -> bool - -(** {2 Utils} *) - -val of_slit_l : - stmt:Statement.clause_t -> - Term.t SLiteral.t list -> - t -(** Conversion from some clause in the given statement *) - -val is_trivial : t -> bool -(** Is the clause trivial? *) - -val add_dismatch_constr : t -> Dismatching_constr.t -> unit -(** Add a dismatching constraint to the clause - @raise Util.Error if the clause is Horn (not splitted then) *) - -(** {2 Unif} *) - -val variant : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t - -val equal_mod_alpha : t -> t -> bool - -module Tbl_mod_alpha : CCHashtbl.S with type key = clause diff --git a/src/hornet/Constraint.ml b/src/hornet/Constraint.ml deleted file mode 100644 index 4c1d399b4..000000000 --- a/src/hornet/Constraint.ml +++ /dev/null @@ -1,69 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Constraint for a Clause} *) - -open Logtk -open Hornet_types - -type t = c_constraint - -let empty : t = { - constr_dismatch=[]; -} - -let pp = Hornet_types_util.pp_constraint -let to_string = CCFormat.to_string pp - -let is_trivial (c:t): bool = - List.for_all Dismatching_constr.is_trivial c.constr_dismatch - -let is_absurd (c:t): bool = - List.exists Dismatching_constr.is_absurd c.constr_dismatch - -let is_absurd_with subst (c,sc): bool = - List.exists - (fun d -> Dismatching_constr.is_absurd_with subst (d,sc)) - c.constr_dismatch - -let add_dismatch (d:Dismatching_constr.t) (c:t): t = - if Dismatching_constr.is_empty d - then c - else ( - let constr_dismatch = - CCList.sorted_insert ~uniq:true ~cmp:Dismatching_constr.compare - d c.constr_dismatch; - in - { constr_dismatch; } - ) - -let of_list (l:Dismatching_constr.t list): t = - let constr_dismatch = CCList.sort_uniq ~cmp:Dismatching_constr.compare l in - { constr_dismatch; } - -let apply_subst ~renaming subst (c,sc): t = - c.constr_dismatch - |> CCList.filter_map - (fun d -> - let d' = Dismatching_constr.apply_subst ~renaming subst (d,sc) in - if Dismatching_constr.is_empty d' then None else Some d') - |> of_list - -let variant ~subst (c1,sc1)(c2,sc2): Subst.t Sequence.t = - Unif.unif_list_com subst - (c1.constr_dismatch,sc1)(c2.constr_dismatch,sc2) - ~op:(fun subst a b -> Dismatching_constr.variant ~subst a b) - -let matching ?(subst=Subst.empty) (c1,sc1)(c2,sc2): Subst.t Sequence.t = - Unif.unif_list_com subst - (c1.constr_dismatch,sc1)(c2.constr_dismatch,sc2) - ~op:(fun subst a b -> Dismatching_constr.matching ~subst a b) - -let subsumes ?subst a b: bool = - not (Sequence.is_empty (matching ?subst a b)) - -let combine (a:t)(b:t): t = - { constr_dismatch = - CCList.sorted_merge_uniq ~cmp:Dismatching_constr.compare - a.constr_dismatch b.constr_dismatch; - } diff --git a/src/hornet/Constraint.mli b/src/hornet/Constraint.mli deleted file mode 100644 index 6531b98c9..000000000 --- a/src/hornet/Constraint.mli +++ /dev/null @@ -1,55 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Constraint for a Clause} *) - -open Logtk -open Hornet_types - -type t = c_constraint - -val empty : t - -val is_trivial : t -> bool -(** Anything is a solution *) - -val is_absurd: t -> bool -(** No solution *) - -val is_absurd_with: Subst.t -> t Scoped.t -> bool -(** No solution compatible with this subst *) - -val add_dismatch : Dismatching_constr.t -> t -> t -(** Add another dismatching constraint to this *) - -val combine : t -> t -> t -(** Conjunction of two constraints *) - -val apply_subst : - renaming:Subst.Renaming.t -> - Subst.t -> - t Scoped.t -> - t - -val variant : - subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t -(** Substitution that make these two constraints the same *) - -val matching : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t -(** Substitution that make these the first constraint imply the second *) - -val subsumes : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - bool -(** Substitution that make these the first constraint imply the second *) - -include Interfaces.PRINT with type t := t diff --git a/src/hornet/Dismatching_constr.ml b/src/hornet/Dismatching_constr.ml deleted file mode 100644 index cff164831..000000000 --- a/src/hornet/Dismatching_constr.ml +++ /dev/null @@ -1,239 +0,0 @@ - - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Dismatching Constraint} *) - -open Logtk - -module T = Term -module Fmt = CCFormat -module BV = CCBV - -type term = Term.t - -type constr = term * term - -let prof_is_absurd = Util.mk_profiler "dismatch.is_absurd" -let prof_is_trivial = Util.mk_profiler "dismatching.is_trivial" - -type t = - | Empty (** totally trivial *) - | Pairs of pairs - -and pairs = { - pairs: (term * term) list; - absurd: bool lazy_t; -} - -(* TODO: simplification of constraints so that LHS terms are always - variables? - - if [has_solution_ c] and the solution is unique (matching), - then the solution is itself a constraint [x1…xn (@[%a@])@ ⋪ (@[%a@])@])" - (Util.pp_list T.pp) lhs_l (Util.pp_list T.pp) rhs_l - -(* given [t1…tn, u1…un], find a substitution [σ] extending [subst] - such that [forall i. t_i = u_iσ]. *) -let match_rhs_to_lhs ~subst (l,sc) = - let sc_rhs = ~-1 in - assert (sc> ~-1); - assert (Subst.codomain subst - |> Sequence.map Scoped.scope |> Sequence.for_all (fun s->s>sc_rhs)); - try - List.fold_left - (fun subst (t,u) -> Unif.FO.matching ~subst ~pattern:(u,sc_rhs) (t,sc)) - subst l - |> CCOpt.return - with Unif.Fail -> None - -(* absurd if there is a substitution σ such that [forall. t false - | Some subst -> - Util.debugf 5 "(@[constr_is_absurd %a@ :subst %a@])" - (fun k->k pp_pairs l Subst.pp subst); - true - end - -let is_absurd = function - | Empty -> false - | Pairs {absurd=lazy b; _} -> b - -let cmp_pair = CCOrd.pair T.compare T.compare - -let make_simpl_ l = - if List.exists is_trivial_pair l - then Empty - else begin match l with - | [] -> Empty - | _ -> - Pairs { - pairs=CCList.sort_uniq ~cmp:cmp_pair l; - absurd=lazy (is_absurd_ l); - } - end - -let compare (c1:t)(c2:t): int = match c1, c2 with - | Empty, Empty -> 0 - | Empty, Pairs _ -> -1 - | Pairs _, Empty -> 1 - | Pairs {pairs=l1;_}, Pairs {pairs=l2;_} -> - CCList.compare cmp_pair l1 l2 - -let empty = Empty - -let is_empty = function - | Empty -> true - | Pairs _ -> false - -let make = make_simpl_ - -let combine c1 c2 : t = match c1, c2 with - | Empty, c - | c, Empty -> c - | Pairs {pairs=l1;_}, Pairs {pairs=l2;_} -> - (* must rename variables in right-hand side pairs, so that there is - no collision between [c1] and [c2]. *) - let renaming = Subst.Renaming.create () in - let l1 = - List.map (fun (t,u) -> t, Subst.FO.apply ~renaming Subst.empty (u,0)) l1 - and l2 = - List.map (fun (t,u) -> t, Subst.FO.apply ~renaming Subst.empty (u,1)) l2 - in - make (List.rev_append l1 l2) - -(* apply substitution. The RHS of each pair is left untouched *) -let apply_subst ~renaming subst (c, sc_l) : t = match c with - | Empty -> Empty - | Pairs {pairs=l; _} -> - List.map - (fun (t,u) -> - let t = Subst.FO.apply ~renaming subst (t, sc_l) in - t, u) - l - |> make - -let is_trivial_ = function - | Empty -> true - | Pairs {pairs=l;_} -> - (* try to unify all pairs. No mgu -> no ground matching either. *) - try - let _ = - List.fold_left - (fun subst (t,u) -> Unif.FO.unification ~subst (t,0) (u,1)) - Subst.empty l - in - false - with Unif.Fail -> - true - -let is_trivial d = Util.with_prof prof_is_trivial is_trivial_ d - -let pp out (c:t): unit = match c with - | Empty -> () - | Pairs {pairs=[t,u];_} -> Fmt.fprintf out "(@[<2>%a@ ⋪ %a@])" T.pp t T.pp u - | Pairs {pairs=l; _} -> pp_pairs out l - -let to_string = Fmt.to_string pp - -let is_absurd_with_ subst (c,sc): bool = match c with - | Empty -> false - | Pairs {pairs=l;_} -> - begin match match_rhs_to_lhs ~subst (l,sc) with - | None -> false - | Some subst -> - Util.debugf 5 "(@[constr_is_absurd %a@ :subst %a@])" - (fun k->k pp c Subst.pp subst); - true - end - -let is_absurd_with subst x = - Util.with_prof prof_is_absurd (is_absurd_with_ subst) x - -let vars_seq = function - | Empty -> Sequence.empty - | Pairs {pairs=l; _} -> - Sequence.of_list l - |> Sequence.map fst - |> Sequence.flat_map T.Seq.vars - -let vars_l (t:t): _ list = - vars_seq t - |> Sequence.to_rev_list - |> CCList.sort_uniq ~cmp:(HVar.compare Type.compare) - -(* find the substitutions making [a1] and [a2] the same constraint *) -let variants_arr_ subst a1 sc1 a2 sc2 : _ Sequence.t = - (* perform simultaneous unification of LHS terms pairwise, - and RHS terms pairwise. *) - Unif.unif_array_com - (subst,Subst.empty) - (a1,sc1) - (a2,sc2) - ~op:(fun (subst,subst_rhs) ((t1,u1),sc1) ((t2,u2),sc2) -> - try - let subst = Unif.FO.variant ~subst (t1,sc1) (t2,sc2) in - let subst_rhs = Unif.FO.variant ~subst:subst_rhs (u1,0)(u2,1) in - Sequence.return (subst,subst_rhs) - with Unif.Fail -> - Sequence.empty) - |> Sequence.map fst (* drop the internal substitution *) - -let variant ?(subst=Subst.empty) (c1,sc1)(c2,sc2) : Subst.t Sequence.t = - begin match c1, c2 with - | Empty, Empty -> Sequence.return subst - | Empty, Pairs _ - | Pairs _, Empty -> Sequence.empty - | Pairs {pairs=l1;_}, Pairs {pairs=l2;_} -> - variants_arr_ subst (Array.of_list l1) sc1 (Array.of_list l2) sc2 - end - -(* try to match pairwise [t1,u1] and [t2,u2] such that: - [subst(t1)=t2], and there is [subst_rhs] s.t. [subst_rhs(u2)=u1] - (that way, [t1,u1] covers all the terms covered by [t2,u2] *) -let subsumes_arr_ subst a1 sc1 a2 sc2 : _ Sequence.t = - Unif.unif_array_com - (subst,Subst.empty) - (a1,sc1) - (a2,sc2) - ~op:(fun (subst,subst_rhs) ((t1,u1),sc1) ((t2,u2),sc2) -> - try - let subst = Unif.FO.matching ~subst ~pattern:(t1,sc1) (t2,sc2) in - let subst_rhs = Unif.FO.matching ~subst:subst_rhs ~pattern:(u2,1)(u1,0) in - Sequence.return (subst,subst_rhs) - with Unif.Fail -> - Sequence.empty) - |> Sequence.map fst (* drop the internal substitution *) - -let matching ?(subst=Subst.empty) (c1,sc1)(c2,sc2) : Subst.t Sequence.t = - begin match c1, c2 with - | Empty, _ -> Sequence.return subst - | Pairs _, Empty -> - Sequence.empty (* not finitary, would need to make [c1] trivial *) - | Pairs {pairs=l1;_}, Pairs {pairs=l2;_} -> - subsumes_arr_ subst (Array.of_list l1) sc1 (Array.of_list l2) sc2 - end - -let are_variant a b = - not (variant (a,0) (b,0) |> Sequence.is_empty) diff --git a/src/hornet/Dismatching_constr.mli b/src/hornet/Dismatching_constr.mli deleted file mode 100644 index d5c36e9b8..000000000 --- a/src/hornet/Dismatching_constr.mli +++ /dev/null @@ -1,77 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Dismatching Constraint} *) - -(** A constraint that specifies that a list of terms [t1, …, tn] - must not match patterns [u1, …, un]. - Variables in the [u_i] live in a distinct scope than variables - in the [t_i]. *) - -open Logtk - -type term = Term.t - -type t - -val empty : t -(** Trivial constraint *) - -val is_empty : t -> bool -(** Is the constraint empty? *) - -val make : (term * term) list -> t -(** [make [t_1,u_1; …; t_n,u_n]] - makes a dismatching constraint that is satisfied for every - ground substitution [sigma] such that at least one [t_i\sigma] does not - match the pattern [u_i]. *) - -val combine : t -> t -> t -(** Conjunction of the two constraints. - {!empty} is neutral for this operation. *) - -val apply_subst : - renaming:Subst.Renaming.t -> - Subst.t -> - t Scoped.t -> - t -(** Apply a substitution [sigma] to the constraints. The constraint - might become trivial as a result. *) - -val is_trivial : t -> bool -(** Is the constraint trivially satisfied? (i.e. always true). - That happens, for instance, for constraints such as [f x /< g y] *) - -val is_absurd : t -> bool -(** Is the constraint never satisfied? (i.e. necessarily false). - That happens if all RHS match their LHS already - (will still hold for every instance). *) - -val is_absurd_with: Subst.t -> t Scoped.t -> bool -(** No solution compatible with this subst *) - -include Interfaces.ORD with type t := t -include Interfaces.PRINT with type t := t - -val vars_seq : t -> Type.t HVar.t Sequence.t - -val vars_l : t -> Type.t HVar.t list - -val variant : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t -(** Find substitutions for which these two constraints are variant *) - -val matching : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t -(** Find substitutions for which the first constraint subsumes - the second one. - It means that every instance accepted by the second will be an - instance accepted by the first. *) - -val are_variant : t -> t -> bool diff --git a/src/hornet/Event.ml b/src/hornet/Event.ml deleted file mode 100644 index ebeb26eb5..000000000 --- a/src/hornet/Event.ml +++ /dev/null @@ -1,9 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -open Hornet_types - -type t = event - -let pp = Hornet_types_util.pp_event -let to_string = CCFormat.to_string pp diff --git a/src/hornet/Event.mli b/src/hornet/Event.mli deleted file mode 100644 index 8d39b218b..000000000 --- a/src/hornet/Event.mli +++ /dev/null @@ -1,6 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -type t = Hornet_types.event - -include Interfaces.PRINT with type t := t diff --git a/src/hornet/H_trail.ml b/src/hornet/H_trail.ml deleted file mode 100644 index ea1a8193a..000000000 --- a/src/hornet/H_trail.ml +++ /dev/null @@ -1,43 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Boolean Trail} *) - -open Hornet_types - -type t = bool_trail - -let cmp_blit = Hornet_types_util.compare_bool_lit -let equal_blit = Hornet_types_util.equal_bool_lit -let neg_blit = Hornet_types_util.neg_bool_lit -let cmp_ (lazy a)(lazy b) = cmp_blit a b -let is_empty = function [] -> true | _::_ -> false - -let empty = [] - -let make l = CCList.sort_uniq ~cmp:cmp_ l - -let merge l1 l2 = - CCList.sorted_merge_uniq ~cmp:cmp_ l1 l2 - -let exists f l = List.exists (fun (lazy blit) -> f blit) l -let to_list = List.map Lazy.force -let of_list = List.map Lazy.from_val - -let subsumes = Hornet_types_util.subsumes_bool_trail - -(* absurd if it contains [a] and [not a] *) -let is_absurd l = - List.exists - (fun (lazy a) -> - List.exists (fun (lazy b) -> equal_blit a (neg_blit b)) l) - l - -let pp = Hornet_types_util.pp_bool_trail -let pp_opt = Hornet_types_util.pp_bool_trail_opt -let to_string = CCFormat.to_string pp -let equal = Hornet_types_util.equal_bool_trail - -let bool_lits (t:t): bool_lit Sequence.t = - Sequence.of_list t - |> Sequence.map Lazy.force diff --git a/src/hornet/H_trail.mli b/src/hornet/H_trail.mli deleted file mode 100644 index d742917cd..000000000 --- a/src/hornet/H_trail.mli +++ /dev/null @@ -1,34 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Boolean Trail} *) - -open Hornet_types - -type t = bool_trail - -val empty : t - -val is_empty : t -> bool - -val make : bool_lit lazy_t list -> t - -val merge : t -> t -> t - -val is_absurd : t -> bool - -val subsumes : t -> t -> bool -(** [subsumes a b] means that [a] is a subset of [b] *) - -val exists : (bool_lit -> bool) -> t -> bool - -val to_list : t -> bool_lit list - -val of_list : bool_lit list -> t - -include Interfaces.PRINT with type t := t -include Interfaces.EQ with type t := t - -val pp_opt : t CCFormat.printer - -val bool_lits : t -> bool_lit Sequence.t diff --git a/src/hornet/Horn_clause.ml b/src/hornet/Horn_clause.ml deleted file mode 100644 index 728780930..000000000 --- a/src/hornet/Horn_clause.ml +++ /dev/null @@ -1,445 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Horn Clause} *) - -open Logtk -open Hornet_types - -module Fmt = CCFormat -module Pos = Position -module PW = Position.With -module BV = CCBV - -type t = Hornet_types.horn_clause -type horn_clause = t - -(** {2 Basics} *) - - -(* Some clauses are added and removed several times. We keep a - cycle counter to distinguish clauses dead at time n (which can - be alive at time n+1), from clauses dead at time n+1, that will - not be active anymore until cycle n+2. *) -let cycle : int ref = ref 0 - -let equal a b = a.hc_id = b.hc_id -let hash a = Hash.int a.hc_id -let compare a b = CCInt.compare a.hc_id b.hc_id - -let pp = Hornet_types_util.pp_hclause -let to_string = Fmt.to_string pp - -let head c = c.hc_head -let body c = c.hc_body -let proof c = c.hc_proof -let trail c = c.hc_trail -let label c = c.hc_label -let constr c = c.hc_constr -let unordered_depth c = c.hc_unordered_depth -let status c = c.hc_status - -let set_status c new_st new_cycle = - let old_st, old_cycle = c.hc_status in - assert (old_cycle <= new_cycle); - begin match old_st, new_st with - | HC_dead, HC_alive when old_cycle < new_cycle -> - () (* only fine for new cycle *) - | HC_alive, HC_dead - | HC_dead, HC_dead -> () - | _ -> - Util.errorf - ~where:"HC.set_status" - "for `@[%a@]`,@ wrong change@ @[<2>`%a`[time %d]@ -> `%a`[time %d]@]" - pp c - Hornet_types_util.pp_hc_status old_st old_cycle - Hornet_types_util.pp_hc_status new_st new_cycle - end; - c.hc_status <- (new_st,new_cycle); - () - -(* register the clause in each of its trail's boolean literal - and labelled clause. - That way, when the literal is backtracked, the clause can be removed *) -let register_ (c:t): unit = - let old_st, old_cycle = c.hc_status in - begin match old_st with - | HC_alive -> () - | HC_dead when old_cycle = !cycle -> () (* up-to-date *) - | HC_dead -> - assert (old_cycle < !cycle); - (* clause is now alive again, with new cycle *) - set_status c HC_alive !cycle; - (* register to trail *) - List.iter - (fun (lazy b_lit) -> match b_lit.bl_atom with - | A_box_clause r -> - r.bool_box_depends <- c :: r.bool_box_depends - | A_fresh _ - | A_ground _ -> ()) - c.hc_trail; - (* register to labelled clauses *) - List.iter - (fun lc -> - lc.lc_sel.select_depends <- c :: lc.lc_sel.select_depends) - c.hc_label; - end - -let make = - let n_ = ref 0 in - fun ~trail ~constr ~unordered_depth ~label head body proof -> - let hc_id = !n_ in - incr n_; - let c = { - hc_id; - hc_head=head; - hc_unordered_depth=unordered_depth; - hc_body=body; - hc_proof=proof; - hc_trail=trail; - hc_constr=constr; - hc_label=label; - hc_status=(HC_dead,~-1); - } in - register_ c; (* register right now *) - c - -let body_seq c = IArray.to_seq (body c) -let body_l c = IArray.to_list (body c) - -let body_len c = IArray.length (body c) - -let body0 c = - if IArray.length (body c) = 0 - then None - else Some (IArray.get (body c) 0) - -let body0_exn c = match body0 c with - | Some c -> c - | None -> - Util.errorf ~where:"Horn_clause.body0_exn" "empty body in `@[%a@]`" pp c - -let body_get c n = - if n < 0 || n >= IArray.length (body c) then ( - Util.errorf ~where:"Horn.body_get" "%d in `@[%a@]`" n pp c; - ); - IArray.get (body c) n - -let body_tail c = - let n = IArray.length (body c) in - if n = 0 then Util.errorf ~where:"Horn_clause.body_tail" "empty body `@[%a@]`" pp c; - IArray.init (n-1) (fun i -> IArray.get (body c) (i+1)) - -let head_pos c = PW.make (head c) Pos.(head stop) -let body_pos n c = PW.make (body_get c n) Pos.(arg n @@ body @@ stop) -let body0_pos = body_pos 0 - -(** {2 Helpers} *) - -let is_trivial c = - let res = - Lit.is_trivial (head c) || - IArray.exists Lit.is_absurd (body c) || - H_trail.is_absurd (trail c) || - Constraint.is_absurd (constr c) || - Label.has_no_ground_instance (label c) - in - if res then ( - Util.debugf 5 "(@[<2>is_trivial %a@])" (fun k->k pp c); - ); - res - -(* NOTE: some constraints will have to be solved all at once - to obtain an actual substitution *) -let constr_are_sat (c:c_constraint): bool = not (Constraint.is_absurd c) - -let is_absurd c = - Lit.is_absurd (head c) && - body_len c = 0 && - not (H_trail.is_absurd (trail c)) && - not (Label.has_no_ground_instance (label c)) && - constr_are_sat (constr c) - -let is_ground c = - Lit.is_ground (head c) && - IArray.for_all Lit.is_ground (body c) - -let is_unit_pos c = - not (Lit.is_absurd (head c)) && - IArray.length (body c) = 0 - -let vars_seq = Hornet_types_util.vars_of_hclause - -let to_lits (c:t): Index_intf.lits = - Sequence.cons - (head c) - (body c |> IArray.to_seq |> Sequence.map Lit.neg) - |> Sequence.map Lit.to_slit - -let labels (c:t): Index_intf.labels = - trail c - |> H_trail.bool_lits - |> Sequence.map Hornet_types_util.int_of_bool_lit - |> Util.Int_set.of_seq - -(** {2 Life Cycle} *) - -(* start a new cycle, so that dead clause can be alive again *) -let start_new_cycle () : unit = - incr cycle; - Util.debugf 4 "@[<2>start_new_cycle (%d)@]" (fun k->k !cycle); - () - -let current_cycle () = !cycle - -(* is the clause dead right now? *) -let is_dead (c:t): bool = match status c with - | HC_alive, _ -> false - | HC_dead, n -> assert (n >= 0); true - -let is_alive c = not (is_dead c) - -let make_alive_again (c:t): unit = - begin match status c with - | HC_alive, _ -> () - | HC_dead, n -> - assert (n - (* the clause dies now *) - Util.debugf 5 "@[<2>remove clause@ %a,@ now dead@]" - (fun k->k pp c); - set_status c HC_dead !cycle; - | HC_dead, _ -> () - end - -(** {2 Unification} *) - -let prof_variant = Util.mk_profiler "hornet.horn_clause_variant" -let prof_subsume = Util.mk_profiler "horn_clause.horn_clause_subsume" -let stat_subsume_call = Util.mk_stat "horn_clause.calls_subsume" -let stat_subsume_success = Util.mk_stat "horn_clause.subsume_success" - -let variant_ subst (c1,sc1) (c2,sc2) : Subst.t Sequence.t = - let variant_constr subst (c1,sc1)(c2,sc2) = - Constraint.variant ~subst (c1,sc1) (c2,sc2) - in - let { - hc_unordered_depth=_; - hc_body=a1; - hc_head=h1; - hc_constr=c1; - hc_trail=tr1; - hc_id=id1; - hc_status=_; - hc_label=lab1; - hc_proof=_; - } = c1 - and { - hc_unordered_depth=_; - hc_body=a2; - hc_head=h2; - hc_constr=c2; - hc_trail=tr2; - hc_id=id2; - hc_label=lab2; - hc_status=_; - hc_proof=_; - } = c2 in - if id1=id2 then Sequence.return subst - else if Hornet_types_util.equal_bool_trail tr1 tr2 then ( - Lit.variant ~subst (h1,sc1)(h2,sc2) - |> Sequence.flat_map - (fun subst -> - Unif.unif_array_com subst - (IArray.to_array_unsafe a1,sc1) - (IArray.to_array_unsafe a2,sc2) - ~op:(fun subst x y -> Lit.variant ~subst x y)) - |> Sequence.flat_map - (fun subst -> variant_constr subst (c1,sc1)(c2,sc2)) - |> Sequence.flat_map - (fun subst -> Label.variant ~subst (lab1,sc1)(lab2,sc2)) - ) else Sequence.empty - -let variant ?(subst=Subst.empty) a b k = - Util.with_prof prof_variant (fun k -> variant_ subst a b k) k - -module Subsume_ = struct - (* can [c1] reasonable subsume [c2]? *) - let precheck (c1:t) (c2:t): bool = - (* check that every literal in a matches at least one literal in b *) - let all_lits_match () = - Lit.subsumes_pred (head c1) (head c2) && - IArray.for_all - (fun lita -> - IArray.exists (fun litb -> Lit.subsumes_pred lita litb) (body c2)) - (body c1) - (* check that every labelled clause of c1 is present in c2 *) - and all_label_clauses_present () = - Label.to_seq (label c1) - |> Sequence.for_all - (fun lc -> - Sequence.exists - (Labelled_clause.same_clause lc) - (label c2 |> Label.to_seq)) - in - IArray.length (body c1) <= IArray.length (body c2) && - Hornet_types_util.subsumes_bool_trail (trail c1) (trail c2) && - all_lits_match () && - all_label_clauses_present () - - (* Compare literals by subsumption difficulty - (see "towards efficient subsumption", Tammet). - We sort by increasing order, so non-ground, deep, heavy literals are - smaller (thus tested early) *) - let compare_literals_subsumption lita litb = - CCOrd.( - (* ground literal is bigger *) - bool (Lit.is_ground lita) (Lit.is_ground litb) - (* deep literal is smaller *) - (map Lit.depth (opp int), lita, litb) - (* heavy literal is smaller *) - (map Lit.weight (opp int), lita, litb) - ) - - let variant_constr_ subst (c1,sc1)(c2,sc2) = - Constraint.variant ~subst (c1,sc1) (c2,sc2) - - (* Check whether [a] subsumes [b], and if it does, return the - corresponding substitution *) - let subsumes_with subst (a,sc_a) (b,sc_b) yield: unit = - (* sort a copy of [a] by decreasing difficulty *) - let a = IArray.to_array_copy a in - let b = IArray.to_array_unsafe b in (* no modification *) - Array.sort compare_literals_subsumption a; - let bv = BV.empty () in - (* try to subsumes literals of b whose index are not in bv, with [subst] *) - let rec try_permutations i subst = - if i = Array.length a - then yield subst - else ( - let lita = a.(i) in - find_matched lita i subst 0 - ) - (* find literals of b that are not in bv and that are matched by lita *) - and find_matched lita i subst j = - if j = Array.length b then () - (* if litb is already matched, continue *) - else if BV.get bv j then find_matched lita i subst (j+1) - else ( - let litb = b.(j) in - BV.set bv j; - (* match lita and litb, then flag litb as used, and try with next literal of a *) - let n_subst = ref 0 in - Lit.subsumes ~subst (lita, sc_a) (litb, sc_b) - (fun subst' -> - incr n_subst; - try_permutations (i+1) subst'); - BV.reset bv j; - (* some variable of lita occur in a[j+1...], try another literal of b *) - if !n_subst > 0 && not (check_vars lita (i+1)) - then () (* no backtracking for litb *) - else find_matched lita i subst (j+1) - ) - (* does some literal in a[j...] contain a variable in l or r? *) - and check_vars lit j = - let vars = Lit.vars_list lit in - vars <> [] && - begin - try - for k = j to Array.length a - 1 do - if List.exists (fun v -> Lit.var_occurs ~var:v a.(k)) vars - then raise Exit - done; - false - with Exit -> true - end - in - try_permutations 0 subst - - let subsume_ subst (c1,sc1) (c2,sc2) : Subst.t Sequence.t = - let { - hc_unordered_depth=_; - hc_body=a1; - hc_head=h1; - hc_constr=cstr1; - hc_trail=_; - hc_id=id1; - hc_status=_; - hc_label=lab1; - hc_proof=_; - } = c1 - and { - hc_unordered_depth=_; - hc_body=a2; - hc_head=h2; - hc_constr=cstr2; - hc_trail=_; - hc_id=id2; - hc_label=lab2; - hc_status=_; - hc_proof=_; - } = c2 in - Util.incr_stat stat_subsume_call; - if id1=id2 then Sequence.return subst - else if precheck c1 c2 then ( - Lit.subsumes ~subst (h1,sc1)(h2,sc2) - |> Sequence.flat_map - (fun subst -> - subsumes_with subst (a1,sc1) (a2,sc2)) - |> Sequence.flat_map - (fun subst -> variant_constr_ subst (cstr1,sc1)(cstr2,sc2)) - |> Sequence.flat_map - (fun subst -> Label.subsumes ~subst (lab1,sc1)(lab2,sc2)) - |> Sequence.map - (fun subst -> Util.incr_stat stat_subsume_success; subst) - ) else Sequence.empty -end - -let subsumes ?(subst=Subst.empty) a b k = - Util.with_prof prof_subsume (fun k -> Subsume_.subsume_ subst a b k) k - -let subsumes_pred c1 c2 = - not (subsumes (c1,0)(c2,1) |> Sequence.is_empty) - -let equal_mod_alpha (c1:t) (c2:t) : bool = - not (variant (c1,0)(c2,1) |> Sequence.is_empty) - -let hash_mod_alpha c: int = - Hash.combine5 42 - (Lit.hash_mod_alpha (head c)) - (IArray.hash_comm Lit.hash_mod_alpha (body c)) - (Hash.list_comm - (fun (lazy b_lit) -> Hornet_types_util.hash_bool_lit b_lit) - (trail c)) - (Label.hash_mod_alpha (label c)) - -(** {2 Containers} *) - -module As_key = struct - type t = horn_clause - let equal = equal - let hash = hash - let compare = compare -end -module Tbl = CCHashtbl.Make(As_key) -module Set = CCSet.Make(As_key) - -module Tbl_mod_alpha = CCHashtbl.Make(struct - type t = horn_clause - let equal = equal_mod_alpha - let hash = hash_mod_alpha - end) - -(** {2 Pairing with Position} *) - -module With_pos = struct - type t = horn_clause Position.With.t - let compare = PW.compare compare - let pp = PW.pp pp - let to_string = Fmt.to_string pp -end diff --git a/src/hornet/Horn_clause.mli b/src/hornet/Horn_clause.mli deleted file mode 100644 index 6c2533061..000000000 --- a/src/hornet/Horn_clause.mli +++ /dev/null @@ -1,163 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Horn Clause} *) - -(** These clauses are typically used for non-ground reasoning based on - Horn-Superposition (with a bound on termination-threatening inferences). - - We consider that a negative clause, [not p1 ∨ … ∨ not pn], - is actually the Horn clause [p1 ∧ … ∧ pn => ⊥]. -*) - -open Logtk -open Hornet_types - -type t = horn_clause -type horn_clause = t - -(** {2 Basics} *) - -val make : - trail:bool_trail -> - constr:c_constraint -> - unordered_depth:int -> - label:label -> - Lit.t -> - Lit.t IArray.t -> - proof -> - t -(** Make a Horn Clause *) - -val head : t -> Lit.t - -val body : t -> Lit.t IArray.t - -val constr : t -> c_constraint -(** The constraints attached to this clause *) - -val trail : t -> bool_trail - -val label : t -> label - -val proof : t -> proof -(** Proof of the clause *) - -val unordered_depth : t -> int -(** The number of unordered inference steps required to prove this clause *) - -val status : t -> horn_clause_status * int -(** status + cycle count *) - -val set_status : t -> horn_clause_status -> int -> unit -(** change the status - @raise Util.Error if the change is not following the order - [Dead (n-1) -> Alive n -> Dead n] *) - -val body_seq : t -> Lit.t Sequence.t -(** Sequence of body elements *) - -val body_l : t -> Lit.t list - -val body_len : t -> int -(** Number of literals in the body. - Invariant: always > 0 *) - -val body0 : t -> Lit.t option -(** Get the first body literal *) - -val body0_exn : t -> Lit.t -(** Get the first body literal - @raise Util.Error if the body is empty *) - -val body_get : t -> int -> Lit.t -(** Get the [n]-th body literal. - @raise Util.Error if [n] is not within [0... body_len c - 1] *) - -val body_tail : t -> Lit.t IArray.t -(** All the body except literal 0. - @raise Util.Error if the body is empty *) - -val head_pos : t -> Lit.t Position.With.t - -val body0_pos : t -> Lit.t Position.With.t - -val body_pos : int -> t -> Lit.t Position.With.t - -(** {2 Helpers} *) - -val is_ground : t -> bool - -val is_trivial : t -> bool - -val is_absurd : t -> bool - -val is_unit_pos : t -> bool - -include Index_intf.CLAUSE with type t := t - -(** {2 Life Cycle} *) - -(** A given clause can be alive, then dead, then alive again, … as many - times as needed (typically because it comes from the splitting of - a full clause, and depends on the boolean model). - - To become alive again after being dead, the "cycle" counter needs - to be increased, signalling that the boolean model might have changed. *) - -val current_cycle : unit -> int - -val start_new_cycle : unit -> unit - -val make_alive_again : t -> unit -(** The clause is dead or alive with an old cycle; we make it alive again - because the boolean trail has changed *) - -val is_alive : t -> bool - -val is_dead : t -> bool - -val kill : t -> unit - -(** {2 Unification} *) - -val variant : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t - -val subsumes : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t -(** Find substitution(s) that makes the first clause - subsume the second one *) - -val subsumes_pred : t -> t -> bool -(** Does the first clause subsume the second? *) - -val hash_mod_alpha : t -> int - -val equal_mod_alpha : t -> t -> bool - -(** {2 Containers} *) - -include Interfaces.PRINT with type t := t -include Interfaces.HASH with type t := t -include Interfaces.ORD with type t := t - -module Tbl : CCHashtbl.S with type key = t -module Set : CCSet.S with type elt = t - -module Tbl_mod_alpha : CCHashtbl.S with type key = t -(** table that uses {!equal_mod_alpha} and {!hash_mod_alpha} *) - -(** {2 Pairing with Position} *) - -module With_pos : sig - type t = horn_clause Position.With.t - include Interfaces.ORD with type t := t - include Interfaces.PRINT with type t := t -end diff --git a/src/hornet/Horn_superposition.ml b/src/hornet/Horn_superposition.ml deleted file mode 100644 index 1c72f066f..000000000 --- a/src/hornet/Horn_superposition.ml +++ /dev/null @@ -1,1226 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(* {1 Superposition on Horn Clauses} *) - -open Logtk - -module T = Term -module C = Clause -module HC = Horn_clause -module P = Position -module Fmt = CCFormat - -open Hornet_types - -let section = Util.Section.make "horn_sup" - -module Make : State.THEORY_FUN = functor(Ctx : State_intf.CONTEXT) -> struct - module Ctx = Ctx - - (* index term->clause *) - module CP_idx = NPDtree.MakeTerm(HC.With_pos) - - module FV_idx = FV_tree.Make(HC) - - let name = "horn_superposition" - - (* a simplification rule *) - type 'a rule_simp = 'a -> 'a option - - (* a simplification rule yielding multiple clauses *) - type 'a rule_simp_n = 'a -> 'a list option - - (* simplification that simplifies a list of clauses from the active set, - removes them, and returns their new version *) - type 'a rule_back_simp = 'a -> 'a list - - (* an inference rule *) - type 'a rule_infer = 'a -> 'a list - - (* real depth limit for saturation is [n * depth_limit] *) - let depth_limit_coeff : int = 2 - - module Depth_limit : sig - val set : int -> unit (** Set the limit on derivations *) - val get : unit -> int (** Set the limit on derivations *) - end = struct - let limit_ : int ref = ref 1 - let set i = assert (i>0); limit_ := depth_limit_coeff * i - let get () = !limit_ - end - - (** {2 Clause Sets} *) - - type idx_elt = term * HC.With_pos.t - - type relevant_pos = - | Head of idx_elt list * idx_elt list (* active, passive *) - | Body0 of idx_elt list (* passive res, passive sup *) - - let positions_body c : _ Sequence.t = - assert (HC.body_len c > 0); - Lit.passive_terms - ~pos:P.(body @@ arg 0 @@ stop) - Ctx.ord (HC.body0_exn c) - - let relevant_pos (c:HC.t): relevant_pos = - if HC.body_len c = 0 - then ( - (* unit clause: both active and passive *) - let head = HC.head c in - let active = - Lit.active_terms ~pos:P.(head stop) Ctx.ord head - |> Sequence.map (fun (t,pos) -> t, (c,pos)) - |> Sequence.to_rev_list - and passive = - Lit.passive_terms ~pos:P.(head stop) Ctx.ord head - |> Sequence.map (fun (t,pos) -> t, (c,pos)) - |> Sequence.to_rev_list - in - Head (active, passive) - ) else ( - (* horn: only passive *) - let passive = - positions_body c - |> Sequence.map (fun (t,pos) -> t, (c,pos)) - |> Sequence.to_rev_list - in - Body0 passive - ) - - (* positive unit clauses *) - module Active_set : sig - val add : HC.t -> unit - - val mem : HC.t -> bool - - val is_subsumed : HC.t -> bool - (** Return [true] if the clause is subsumed by the set *) - - val find_subsuming : HC.t -> HC.Set.t - (** Find all clauses subsumed by this given clause *) - - val remove : HC.t -> unit - - val size: unit -> int - - (* index on the head equation sides of positive unit clauses - (active res/paramodulation) *) - val idx_heads : unit -> CP_idx.t - - (* index on subterms of the first body lit of non-unit clauses, - and on the head of unit clauses - (passive res/paramodulation) *) - val idx_sup_into : unit -> CP_idx.t - end = struct - let tbl : unit HC.Tbl.t = HC.Tbl.create 512 - let size () = HC.Tbl.length tbl - - let idx_heads_ : CP_idx.t ref = ref (CP_idx.empty ()) - let idx_sup_into_ : CP_idx.t ref = ref (CP_idx.empty ()) - let idx_fv_ : FV_idx.t ref = ref (FV_idx.empty ()) - - let idx_heads () = !idx_heads_ - let idx_sup_into () = !idx_sup_into_ - - let add c = - if not (HC.Tbl.mem tbl c) then ( - HC.Tbl.add tbl c (); - idx_fv_ := FV_idx.add !idx_fv_ c; - begin match relevant_pos c with - | Head (active, subs) -> - idx_heads_ := CP_idx.add_list !idx_heads_ active; - idx_sup_into_ := CP_idx.add_list !idx_sup_into_ subs - | Body0 subs -> - idx_sup_into_ := CP_idx.add_list !idx_sup_into_ subs - end - ) - - let mem c = HC.Tbl.mem tbl c - - let remove c = - if HC.Tbl.mem tbl c then ( - HC.Tbl.remove tbl c; - idx_fv_ := FV_idx.remove !idx_fv_ c; - begin match relevant_pos c with - | Head (active, subs) -> - idx_heads_ := CP_idx.remove_list !idx_heads_ active; - idx_sup_into_ := CP_idx.remove_list !idx_sup_into_ subs - | Body0 subs -> - idx_sup_into_ := CP_idx.remove_list !idx_sup_into_ subs - end - ) - - let is_subsumed (c:HC.t): bool = - FV_idx.retrieve_subsuming_c !idx_fv_ c - |> Sequence.exists - (fun c' -> HC.subsumes_pred c' c) - - let find_subsuming (c:HC.t): HC.Set.t = - let set = - FV_idx.retrieve_subsumed_c !idx_fv_ c - |> Sequence.filter - (fun c' -> HC.subsumes_pred c c') - |> HC.Set.of_seq - in - set - end - - let kill_clauses (l:HC.t list): unit = - List.iter - (fun c -> - if HC.is_alive c then ( - HC.kill c; - assert (HC.is_dead c); - Active_set.remove c; (* if it's active, not any more *) - )) - l - - let remove_all_box (r:bool_box_clause): unit = - let l = r.bool_box_depends in - r.bool_box_depends <- []; - kill_clauses l - - let remove_all_select (r:select_lit): unit = - let l = r.select_depends in - r.select_depends <- []; - kill_clauses l - - module Passive_set : sig - val add : HC.t -> unit - val add_seq : HC.t Sequence.t -> unit - val update_depth_limit: unit -> unit - val has_too_deep_clauses: unit -> bool (** are there clauses frozen b.c. of their depth? *) - val next : unit -> HC.t option - end = struct - (* heuristic weights for selecting clauses *) - module W = struct - type t = HC.t -> int - - (* weighted combination *) - let combine (ws:(t * int) list): t = - assert (ws <> []); - assert (List.for_all (fun (_,c) -> c > 0) ws); - fun c -> - List.fold_left - (fun sum (w,coeff) -> sum + coeff * w c) - 0 ws - - let all_terms c: term Sequence.t = - (Sequence.append (Lit.seq_terms (HC.head c)) - (HC.body c |> IArray.to_seq |> Sequence.flat_map Lit.seq_terms)) - - let weight_lits (c:HC.t): int = - all_terms c - |> Sequence.map T.weight - |> Sequence.fold (+) 0 - - let depth_lits (c:HC.t): int = - all_terms c - |> Sequence.map T.depth - |> Sequence.max - |> CCOpt.get_or ~default:0 - - let depth_ty (c:HC.t): int = - all_terms c - |> Sequence.flat_map T.Seq.subterms - |> Sequence.map Term.ty - |> Sequence.map Type.depth - |> Sequence.max ?lt:None - |> CCOpt.get_or ~default:0 - - let num_vars_lits (c:HC.t): int = - all_terms c - |> Sequence.flat_map T.Seq.vars - |> Sequence.length - - let unordered_depth = HC.unordered_depth - - let favor_ground: t = fun c -> if HC.is_ground c then 0 else 10 - - let favor_pos_unit: t = fun c -> if HC.is_unit_pos c then 0 else 10 - end - - (* "weight" of a clause. - favor small clauses with shallow, ground terms *) - let weight : W.t = - W.combine - [ W.depth_ty, 5; - W.weight_lits, 2; - W.depth_lits, 2; - W.num_vars_lits, 3; - W.favor_ground, 1; - W.unordered_depth, 1; - W.favor_pos_unit, 5; - ] - - (* priority queue *) - module H = CCHeap.Make(struct - type t = (int * HC.t) - let leq (i1, c1) (i2, c2): bool = - i1 < i2 || (i1 = i2 && HC.compare c1 c2 <= 0) - end) - - let prof_passive = Util.mk_profiler "hornet.passive_set" - let stat_passive_add = Util.mk_stat "hornet.passive_add" - - (* queue of clauses to process (passive) *) - let q_ : H.t ref = ref H.empty - - (* queue for clauses that are deeper than the current limit *) - let too_deep_ : H.t ref = ref H.empty - - let has_too_deep_clauses () = not (H.is_empty !too_deep_) - - let add_ c = - if HC.is_dead c then () (* useless *) - else if Active_set.mem c then () (* already active *) - else ( - let depth = HC.unordered_depth c in - if depth < Depth_limit.get () then ( - Util.debugf ~section 3 "@[<2>add `%a`@ to passive set@]" - (fun k->k HC.pp c); - Util.incr_stat stat_passive_add; - q_ := H.add !q_ (weight c,c) - ) else ( - too_deep_ := H.add !too_deep_ (depth,c); - ) - ) - - let add c = Util.with_prof prof_passive add_ c - - let add_seq = Sequence.iter add - - (* new depth limit -> some clauses become active *) - let update_depth_limit () = - let d = Depth_limit.get() in - let rec aux q = match H.take q with - | Some (new_q, (d_c,c)) when d_c < d -> - (* [c] becomes passive *) - add c; - aux new_q - | Some _ | None -> q - in - too_deep_ := aux !too_deep_ - - (* find the next alive clause *) - let rec next () = match H.take !q_ with - | None -> None - | Some (new_q, (_,c)) -> - q_ := new_q; - if HC.is_dead c - then next() (* discard dead clause *) - else Some c - end - - (** {2 Superposition} *) - module Sup : sig - val rule_infer_active : HC.t rule_infer - val rule_infer_passive : HC.t rule_infer - val rule_eq_resolution : HC.t rule_infer - val rule_destr_eq_resolution : HC.t rule_simp - val rule_demod : HC.t rule_simp - val rule_back_demod : HC.t rule_back_simp - end = struct - let stat_infer = Util.mk_stat "hornet.steps_sup_infer" - let stat_eq_res = Util.mk_stat "hornet.steps_eq_res" - let stat_destr_eq_res = Util.mk_stat "hornet.steps_destr_res" - let stat_demod_call = Util.mk_stat "hornet.calls_demod" - let stat_demod_step = Util.mk_stat "hornet.steps_demod" - let stat_back_demod_step = Util.mk_stat "hornet.steps_back_demod" - let prof_infer_active = Util.mk_profiler "hornet.sup_active" - let prof_infer_passive = Util.mk_profiler "hornet.sup_passive" - let prof_eq_res = Util.mk_profiler "hornet.eq_res" - let prof_demod = Util.mk_profiler "hornet.demod" - let prof_back_demod = Util.mk_profiler "hornet.back_demod" - - (* do the inference, if it is needed *) - let do_sup_inference (sup:hc_superposition_step): HC.t option = - let c, sc_active = sup.hc_sup_active in - assert (HC.body_len c=0); - assert (not (T.is_var sup.hc_sup_rewritten)); - let c', sc_passive = sup.hc_sup_passive in - assert (HC.is_alive c); - assert (HC.is_alive c'); - let subst = sup.hc_sup_subst in - let renaming = Subst.Renaming.createed () in - let s = sup.hc_sup_s in - let s' = Subst.FO.apply ~renaming subst (s,sc_active) in - let t' = Subst.FO.apply ~renaming subst (sup.hc_sup_t,sc_active) in - (* passive lit and equation *) - let passive_lit, passive_lit_pos = match sup.hc_sup_passive_pos with - | P.Body (P.Arg (0, p)) -> HC.body0_exn c', p - | P.Head p -> HC.head c', p - | _ -> assert false - in - let u', v' = match Lit.get_eqn passive_lit passive_lit_pos with - | Some (u, v, sign) -> - assert sign; - Subst.FO.apply ~renaming subst (u,sc_passive), - Subst.FO.apply ~renaming subst (v,sc_passive) - | _ -> assert false - in - (* check ordering on [s>t] and [u>v], with possibility of non-decreasing - inference at the cost of a depth increase *) - let cmp_s_t = Ordering.compare Ctx.ord s' t' in - let cmp_u_v = Ordering.compare Ctx.ord u' v' in - let ord_ok = match cmp_s_t, cmp_u_v with - | Comparison.Gt, (Comparison.Gt | Comparison.Eq) -> true - | Comparison.Lt, _ - | _, Comparison.Lt -> false (* ill-ordered *) - | Comparison.Eq, _ -> false (* trivial *) - | Comparison.Incomparable, (Comparison.Gt | Comparison.Eq) - | Comparison.Gt, Comparison.Incomparable -> true - | Comparison.Incomparable, Comparison.Incomparable -> true (* ouch. *) - in - let unordered_depth () = - (* malus applied to this particular inference. an inference is - safe if: - - [s'] is ground, [t'] too, [s'>t'], passive clause is unit or ground - *) - let step = - if (T.is_ground s' && - cmp_s_t = Comparison.Gt && - (assert (T.is_ground t'); true) && - (HC.is_ground c' || HC.is_unit_pos c')) - then 0 - else 1 - in - HC.unordered_depth c + HC.unordered_depth c' + step - in - (* check for some trivial inference: using [s=t] to rewrite [s=t] *) - let will_be_trivial () = - HC.body_len c' = 0 && - Lit.equal (HC.head c) (HC.head c') && - T.equal s' u' && T.equal t' v' - in - (* if all conditions met, do the inference *) - if ord_ok && not (will_be_trivial ()) - then ( - (* inference is a go *) - let new_head = Lit.apply_subst ~renaming subst (HC.head c',sc_passive) in - let new_body = - HC.body c' - |> IArray.map_arr - (fun lit -> Lit.apply_subst ~renaming subst (lit,sc_passive)) - in - let new_head, new_body = match sup.hc_sup_passive_pos with - | P.Head pos' -> - Lit.Pos.replace new_head ~at:pos' ~by:t', - IArray.of_array_unsafe new_body - | P.Body (P.Arg (0,pos')) -> - new_body.(0) <- Lit.Pos.replace new_body.(0) ~at:pos' ~by:t'; - new_head, IArray.of_array_unsafe new_body - | _ -> assert false - in - let constr = - Constraint.combine - (Constraint.apply_subst ~renaming subst (HC.constr c,sc_active)) - (Constraint.apply_subst ~renaming subst (HC.constr c',sc_passive)) - and trail = - H_trail.merge (HC.trail c) (HC.trail c') - and label = - Label.merge - (Label.apply_subst ~renaming subst (HC.label c,sc_active)) - (Label.apply_subst ~renaming subst (HC.label c',sc_passive)) - in - let unordered_depth = unordered_depth() in - let new_c = - HC.make ~unordered_depth ~constr ~trail ~label - new_head new_body (Proof.hc_sup sup) - in - Util.incr_stat stat_infer; - Util.debugf ~section 4 - "(@[superposition_step@ :yields %a@ :params %a@ :depth %d@])" - (fun k->k HC.pp new_c Hornet_types_util.pp_hc_sup sup unordered_depth); - Some new_c - ) else None - - (* perform active superposition rewriting [s] into [t] *) - let active_sup (c:HC.t) (pos_s:P.t) (s:T.t) (t:T.t): HC.t list = - let idx = Active_set.idx_sup_into () in - let sc_active = 0 in - let sc_passive = 1 in - CP_idx.retrieve_unifiables (idx,sc_passive) (s,sc_active) - |> Sequence.filter_map - (fun (u_p,c'_with_pos,subst) -> - let c', pos' = c'_with_pos in - let sup = { - hc_sup_active=(c,sc_active); - hc_sup_passive=(c',sc_passive); - hc_sup_s=s; - hc_sup_t=t; - hc_sup_subst=subst; - hc_sup_rewritten=u_p; - hc_sup_active_pos=pos_s; - hc_sup_passive_pos=pos'; - } in - do_sup_inference sup) - |> Sequence.to_rev_list - - (* try to use this clause to rewrite other clauses *) - let rule_infer_active_ (c:HC.t) : _ list = - if HC.body_len c = 0 then ( - begin match HC.head c with - | Lit.Atom (t, true) -> - active_sup c P.(head @@ left @@ stop) t T.true_ - | Lit.Eq (s, t, true) -> - begin match Ordering.compare Ctx.ord s t with - | Comparison.Gt -> active_sup c P.(head @@ left @@ stop) s t - | Comparison.Lt -> active_sup c P.(head @@ right @@ stop) t s - | Comparison.Eq -> [] - | Comparison.Incomparable -> - List.rev_append - (active_sup c P.(head @@ left @@ stop) s t) - (active_sup c P.(head @@ right @@ stop) t s) - end - | Lit.Atom (_,false) | Lit.Eq (_,_,false) -> assert false - | Lit.Bool _ -> [] - end - ) else [] - - let passive_sup (c:HC.t): _ list = - let idx = Active_set.idx_heads () in - let sc_active = 0 in - let sc_passive = 1 in - (* all position that can be rewritten *) - let pos_seq =match relevant_pos c with - | Head (_,subs) | Body0 subs -> subs - in - Sequence.of_list pos_seq - |> Sequence.flat_map - (fun (rewritten,(_,pos_rewritten)) -> - (* try to rewrite this sub-term *) - CP_idx.retrieve_unifiables (idx,sc_active) (rewritten,sc_passive) - |> Sequence.filter_map - (fun (s,c'_with_pos,subst) -> - let c', pos' = c'_with_pos in - let pos_lit' = match pos' with P.Head p'->p' | _ -> assert false in - let t = match Lit.get_eqn (HC.head c') pos_lit' with - | Some (s_, t, true) -> - (*Format.eprintf "hd %a, s=`@[%a@]`, s_=`@[%a@]` pos %a@." - Lit.pp (HC.head c') T.pp s T.pp s_ P.pp pos_lit';*) - assert (T.equal s s_); t - | _ -> - Format.eprintf "hd %a, pos %a@." Lit.pp (HC.head c') P.pp pos_lit'; - assert false - in - let sup = { - hc_sup_active=(c',sc_active); - hc_sup_passive=(c,sc_passive); - hc_sup_s=s; - hc_sup_t=t; - hc_sup_subst=subst; - hc_sup_rewritten=rewritten; - hc_sup_active_pos=pos'; - hc_sup_passive_pos=pos_rewritten; - } in - do_sup_inference sup - )) - |> Sequence.to_rev_list - - (* equality resolution *) - let eq_res (c:HC.t): _ list = match HC.body0 c with - | None -> [] - | Some (Lit.Eq (a,b,true)) -> - let sc = 0 in - begin - try - let subst = Unif.FO.unification (a,sc) (b,sc) in - (* do inference, by removing [a=b] from body *) - let renaming = Subst.Renaming.createed () in - let new_head = - Lit.apply_subst ~renaming subst (HC.head c,sc) - and new_body = - HC.body_tail c - |> IArray.map_arr - (fun lit -> Lit.apply_subst ~renaming subst (lit,sc)) - |> IArray.of_array_unsafe - and proof = Proof.hc_eq_res c subst - and constr = Constraint.apply_subst ~renaming subst (HC.constr c,sc) - and label = - Label.apply_subst ~renaming subst (HC.label c,sc) - in - let c' = - HC.make new_head new_body proof - ~unordered_depth:(HC.unordered_depth c) - ~trail:(HC.trail c) ~constr ~label - in - Util.debugf ~section 4 - "(@[eq_res@ :on %a@ :subst %a@ :yield %a@])" - (fun k->k HC.pp c Subst.pp subst HC.pp c'); - Util.incr_stat stat_eq_res; - [c'] - with Unif.Fail -> [] - end - | Some (Lit.Atom (_,true)) (* TODO: E-unif for true? *) - | Some (Lit.Bool _) -> [] - | Some (Lit.Eq (_,_,false) | Lit.Atom (_,false)) -> assert false - - (* destructive equality resolution. - Works on every literal of the body, not only the first one. *) - let rule_destr_eq_resolution (c:HC.t): _ option = - let lits = HC.body c in - let lit_replace = - IArray.to_seqi lits - |> Sequence.find - (fun (i,lit) -> match lit with - | Lit.Eq (a,b,true) -> - begin match T.view a, T.view b with - | T.Var x, _ when not (T.var_occurs ~var:x b) -> Some (i,x,b) - | _, T.Var x when not (T.var_occurs ~var:x a) -> Some (i,x,a) - | _ -> None - end - | _ -> None) - in - begin match lit_replace with - | None -> None - | Some (i, x, t) -> - (* replace [x] by [t] in the clause, and remove the literal *) - let sc = 0 in - let subst = - Subst.bind Subst.empty ((x:>InnerTerm.t HVar.t),0) ((t:>InnerTerm.t),0) - in - let new_body = - IArray.init (IArray.length lits-1) - (fun j-> if jdestr_eq_res@ :on %a@ :subst %a@ :yield %a@])" - (fun k->k HC.pp c Subst.pp subst HC.pp c'); - Util.incr_stat stat_destr_eq_res; - Some c' - end - - (* Compute normal form of term w.r.t active set. Clauses used to - restrict is an option for restricting demodulation - in positive unit clauses. - add rewriting rules to [rules] *) - let demod_nf ~restrict (passive:HC.t)(rules:HC.Set.t ref) (t:term): term = - let ord = Ctx.ord in - let idx = Active_set.idx_heads () in - let sc_active = 1 in - let sc_passive = 0 in - (* compute normal form of subterm. If restrict is true, substitutions that - are variable renamings are forbidden (since we are at root of a max term) *) - let rec reduce_at_root ~restrict t = - (* find an equation l=r that match subterm *) - let matching_rule = - CP_idx.retrieve_generalizations (idx, sc_active) (t, sc_passive) - |> Sequence.find - (fun (l, c_with_pos, subst) -> - let active, pos = c_with_pos in - assert (HC.is_unit_pos active); - let lit_pos = match pos with P.Head p -> p | _ -> assert false in - let l', r, sign = Lit.get_eqn_exn (HC.head active) lit_pos in - assert (sign && T.equal l l'); - (* check ordering conditions and restriction. - if [restrict], we cannot rewrite [t] with itself, - only with terms that are strictly more general - (avoid self-demodulation of the rewrite rule) *) - let ok = - (not restrict || not (Unif.FO.matches ~pattern:t l)) - && H_trail.subsumes (HC.trail active) (HC.trail passive) - && Ordering.compare ord - (Subst.FO.apply_no_renaming subst (l,sc_active)) - (Subst.FO.apply_no_renaming subst (r,sc_active)) = Comparison.Gt - && Label.subsumes_pred ~subst - (HC.label active,sc_active)(HC.label passive,sc_passive) - && Constraint.subsumes - (HC.constr active,sc_active)(HC.constr passive,sc_passive) - in - if ok then ( - rules := HC.Set.add active !rules; - Util.incr_stat stat_demod_step; - Some (r, subst) - ) else - None) - in - begin match matching_rule with - | None -> t - | Some (t', subst) -> - Util.debugf ~section 5 "(@[<2>demod@ :old `@[%a@]`@ :new `@[%a@]`@])" - (fun k->k T.pp t T.pp t'); - normal_form ~restrict subst t' 1 (* done one rewriting step, continue *) - end - (* rewrite innermost-leftmost of [subst(t,scope)]. The initial scope is - 0, but then we normal_form terms in which variables are really the variables - of the RHS of a previously applied rule (in context 1); all those - variables are bound to terms in context 0 *) - and normal_form ~restrict subst t scope = - begin match T.view t with - | T.App (f, l) -> - begin match T.view f with - | T.DB _ - | T.Var _ -> Subst.FO.apply_no_renaming subst (t, scope) - | T.Const _ -> - (* rewrite subterms in call by value *) - let l' = - List.map (fun t' -> normal_form ~restrict:false subst t' scope) l - and f' = - Subst.FO.apply_no_renaming subst (f, scope) - in - (* avoid rebuilding term if nothing changed *) - let t' = - if T.equal f f' && T.same_l l l' - then t - else T.app f' l' - in - (* rewrite term at root *) - reduce_at_root ~restrict t' - | T.App _ - | T.AppBuiltin _ -> assert false - end - | _ -> Subst.FO.apply_no_renaming subst (t,scope) - end - in - normal_form ~restrict Subst.empty t 0 - - let demod_lit ~head passive (rules:HC.Set.t ref)(lit:lit): lit = - begin match lit with - | Atom (p,sign) -> - let p = demod_nf ~restrict:head passive rules p in - Lit.atom ~sign p - | Eq (a,b,sign) when head -> - (* head literal: restrict the bigger side(s) *) - let c = Ordering.compare Ctx.ord a b in - let restrict_a, restrict_b = match c with - | Comparison.Gt -> true, false - | Comparison.Lt -> false, true - | Comparison.Incomparable -> true, true - | Comparison.Eq -> false, false - in - (* demod with given restriction *) - Lit.eq ~sign - (demod_nf ~restrict:restrict_a passive rules a) - (demod_nf ~restrict:restrict_b passive rules b) - | Eq (a,b,sign) -> - (* demod without restriction *) - Lit.eq ~sign - (demod_nf ~restrict:false passive rules a) - (demod_nf ~restrict:false passive rules b) - | Bool _ -> lit - end - - let demod_ (c:HC.t): HC.t option = - Util.incr_stat stat_demod_call; - let rules = ref HC.Set.empty in - let new_head = demod_lit ~head:true c rules (HC.head c) - and new_body = - (* only demodulate first body literal *) - IArray.mapi - (fun i lit -> - if i=0 then demod_lit ~head:false c rules lit else lit) - (HC.body c) - in - (* rewriting happened iff there is at least one rule *) - if not (HC.Set.is_empty !rules) then ( - let rules = HC.Set.to_list !rules in - let new_c : HC.t = - HC.make new_head new_body - (Proof.hc_demod c rules) - ~constr:(HC.constr c) ~trail:(HC.trail c) - ~unordered_depth:(HC.unordered_depth c) ~label:(HC.label c) - in - Util.debugf ~section 3 - "(@[<2>demod@ :clause %a@ :into %a@ :rules {@[%a@]}@])" - (fun k->k HC.pp c HC.pp new_c (Util.pp_list HC.pp) rules); - Some new_c - ) else None - - (* find clauses that can be demodulated by the given positive unit eqn. - returns the list of demodulated clauses, removed from active set *) - let back_demod_ (c:HC.t): HC.t list = - let idx = Active_set.idx_sup_into () in - let renaming = Subst.Renaming.createed () in - (* find clauses that might be rewritten by l -> r *) - let find_candidates ~oriented set l r = - CP_idx.retrieve_specializations (idx,1) (l,0) - |> Sequence.filter_map - (fun (_,c'_with_pos,subst) -> - let c', _ = c'_with_pos in - (* subst(l) matches t' and is > subst(r), very likely to rewrite! *) - if (oriented || - Ordering.compare Ctx.ord - (Subst.FO.apply ~renaming subst (l,0)) - (Subst.FO.apply ~renaming subst (r,0)) = Comparison.Gt) && - H_trail.subsumes (HC.trail c) (HC.trail c') - then Some c' (* add the clause to the set, it may be rewritten by l -> r *) - else None) - |> HC.Set.add_seq set - in - let set = HC.Set.empty in - (* gather all candidates *) - let candidates = - if HC.is_unit_pos c - then match HC.head c with - | Lit.Eq (l,r,true) -> - begin match Ordering.compare Ctx.ord l r with - | Comparison.Gt -> find_candidates ~oriented:true set l r - | Comparison.Lt -> find_candidates ~oriented:true set r l - | _ -> - (* both sides can rewrite, but we need to check ordering *) - let set = find_candidates ~oriented:false set l r in - find_candidates ~oriented:false set r l - end - | _ -> HC.Set.empty - else HC.Set.empty - in - (* try to simplify candidates by demod now *) - let final_set = - HC.Set.to_seq candidates - |> Sequence.filter_map - (fun c' -> match demod_ c' with - | None -> None - | Some new_c -> - (* clause is simplified, remove it and return its new version *) - Util.incr_stat stat_back_demod_step; - Active_set.remove c'; - Some new_c) - |> Sequence.to_rev_list - in - final_set - - let rule_infer_active c = - Util.with_prof prof_infer_active rule_infer_active_ c - - let rule_infer_passive (c:HC.t): _ list = - Util.with_prof prof_infer_passive passive_sup c - - let rule_demod c = - Util.with_prof prof_demod demod_ c - - let rule_back_demod c = - Util.with_prof prof_back_demod back_demod_ c - - let rule_eq_resolution c : _ list = - Util.with_prof prof_eq_res eq_res c - end - - (** {2 Avatar} *) - - (** Part of the Avatar reasoning. Here we do simplifications related - to boolean literals that have been {b proved} by the SAT solver, - that is, that are propagated at level 0 *) - - module Avatar : sig - val has_trivial_trail : HC.t -> bool - val simplify_trail : HC.t rule_simp - end = struct - let stat_trail_trivial = Util.mk_stat "hornet.avatar_trivial_trail" - let stat_trail_simplify = Util.mk_stat "hornet.steps_avatar_simplify_trail" - - (* check whether the trail is false and will remain so *) - let trail_is_trivial_ (trail:H_trail.t): bool = - let res = - H_trail.exists - (fun lit -> match Ctx.valuation_at_level0 lit with - | Some false -> true (* false at level 0: proven false *) - | _ -> false) - trail - in - if res then ( - Util.incr_stat stat_trail_trivial; - Util.debugf ~section 3 "(@[<2>trail @[%a@]@ is trivial@])" - (fun k->k H_trail.pp trail); - ); - res - - let has_trivial_trail (c:HC.t) = - trail_is_trivial_ (HC.trail c) - - (* simplify the trail of [c] using boolean literals that have been proven *) - let simplify_trail (c:HC.t): HC.t option = - let trail = HC.trail c in - let n_simpl = ref 0 in - (* remove bool literals made trivial by SAT solver *) - let trail, trivial_trail = - trail - |> List.partition - (fun (lazy lit) -> match Ctx.valuation_at_level0 lit with - | Some true -> - (* [lit] is proven true, it is therefore not necessary - to depend on it *) - incr n_simpl; - false - | _ -> true) - in - if !n_simpl > 0 then ( - Util.incr_stat stat_trail_simplify; - (* use SAT resolution proofs for tracking why the trail - has been simplified, so that the other branches that have been - closed can appear in the proof *) - let proof_removed = - List.map (fun (lazy l) -> l, Ctx.proof_of_lit l) trivial_trail - in - let proof = Proof.avatar_cut c proof_removed in - let new_c : HC.t = - HC.make (HC.head c) (HC.body c) proof - ~trail ~constr:(HC.constr c) ~label:(HC.label c) - ~unordered_depth:(HC.unordered_depth c) - in - Util.incr_stat stat_trail_simplify; - Util.debugf ~section 3 - "(@[avatar_cut@ :clause %a@ :into @[%a@]@ :lits %a@])" - (fun k->k HC.pp c HC.pp new_c H_trail.pp trivial_trail); - Some new_c - ) else None - end - - (** {2 Simplifications} *) - - module Simplifications : sig - val rules_simp_fast : HC.t rule_simp list - val rules_simp_full : HC.t rule_simp list - val rules_simp_n : HC.t rule_simp_n list - val rules_back_simp : HC.t rule_back_simp list - end = struct - let stat_simp_body = Util.mk_stat "hornet.simp_body" - - (* simplification of first body literal *) - let simp_body0 c: HC.t option = match HC.body0 c with - | None -> None - | Some (Lit.Bool true) -> - (* trivial body literal, remove *) - let c' = - HC.make - ~constr:(HC.constr c) ~trail:(HC.trail c) - ~unordered_depth:(HC.unordered_depth c) ~label:(HC.label c) - (HC.head c) (HC.body_tail c) (Proof.hc_simplify c) - in - Util.incr_stat stat_simp_body; - Some c' - | Some (Lit.Eq (t, u, true)) when T.equal t u -> - (* [a=a] -> true *) - let c' = - HC.make - ~constr:(HC.constr c) ~trail:(HC.trail c) - ~unordered_depth:(HC.unordered_depth c) ~label:(HC.label c) - (HC.head c) (HC.body_tail c) (Proof.hc_simplify c) - in - Util.incr_stat stat_simp_body; - Some c' - | Some lit when not (Lit.sign lit) -> assert false - | Some _ -> None - - let rules_simp_fast = [ simp_body0; Avatar.simplify_trail ] - - (* TODO: rewriting for deduction modulo *) - - let rules_simp_full = - rules_simp_fast @ [ Sup.rule_destr_eq_resolution; Sup.rule_demod; ] - - let rules_simp_n = [ ] - let rules_back_simp = [ Sup.rule_back_demod ] - end - - (** {2 Saturation} *) - - (** Keeps a set of clauses that are saturated up to some limit. - The limit is on derivations: a clause that has been derived using - "too many" non-decreasing steps is thrown away. - This is sufficient for saturation to always terminate. - - The state is a set of Horn clauses, and is backtrackable. *) - - let rules_infer : HC.t rule_infer list = - [ Sup.rule_infer_active; - Sup.rule_infer_passive; - Sup.rule_eq_resolution; - ] - - module Saturate : sig - type res = - | Sat - | Unknown (* reached depth limit *) - | Unsat of HC.t (* empty clause *) - - type stats = { - num_clauses: int; (* number of clauses *) - } - - val pp_stats : stats CCFormat.printer - - val stats : unit -> stats - - val add_clauses : C.t list -> res - (** Add a list of clauses. - For each [c], adds the clause [c] to the set, and applies - Avatar splitting and Inst_gen_eq to it. *) - - val add_horn : HC.t -> res - (** [add_horn c] adds the clause [c] to the set, and saturates it - again. If, during saturation, the empty clause is derived, - [Unsat l] is returned (where [l] is a non-empty list of empty clauses). - Otherwise, [Sat] is returned. *) - - val saturate : ?full:bool -> unit -> res - (** Saturate again. Should be called after every increase of depth, - since it might unlock some clauses that were too deep till now. - @param full if true, ignore the saturation limit (default false) *) - end = struct - type res = - | Sat - | Unknown (* reached depth limit *) - | Unsat of HC.t - - let stat_fwd_subsumed = Util.mk_stat "hornet.subsumed_forward" - let stat_backward_subsumed = Util.mk_stat "hornet.subsumed_backward" - - type stats = { - num_clauses: int; (* number of clauses *) - } - - let pp_stats out s: unit = - Fmt.fprintf out "{@[num_clauses: %d@]}" s.num_clauses - - (** {6 Local State} *) - - let stats (): stats = { - num_clauses=Active_set.size(); - } - - (** {6 Saturation} *) - - (* simplify using given rules *) - let simplify rules0 c = - let rec aux rules c = match rules with - | [] -> c - | r :: rules_tail -> - begin match r c with - | None -> aux rules_tail c - | Some c' -> aux rules0 c' (* from start *) - end - in - let new_c = aux rules0 c in - if not (HC.equal c new_c) then ( - Util.debugf ~section 5 "(@[<2>simplify@ `%a`@ :into `%a`@])" - (fun k->k HC.pp c HC.pp new_c); - ); - new_c - - let simplify_fast = simplify Simplifications.rules_simp_fast - let simplify_full = simplify Simplifications.rules_simp_full - - (* apply the "splitting" rules *) - let simplify_n rules0 c = - let res = ref [] in - let rec aux rules c = match rules with - | [] -> - (* re-simplify c *) - let c = simplify_fast c in - CCList.Ref.push res c - | r :: rules_tail -> - begin match r c with - | None -> aux rules_tail c - | Some l -> List.iter (aux rules0) l (* from start for each new clause *) - end - in - aux rules0 c; - !res - - (* apply backward simplification rules (simplifies active set using [c]) *) - let back_simplify c = - CCList.flat_map - (fun r -> r c) - Simplifications.rules_back_simp - - let stat_loop_count = Util.mk_stat "hornet.saturation_iter_count" - - (* the main saturation loop *) - let rec saturation_loop n = - if n=0 - then - if Passive_set.has_too_deep_clauses () - then Unknown - else Sat - else saturate_next n - and saturate_next n = match Passive_set.next () with - | None -> - if Passive_set.has_too_deep_clauses () - then Unknown - else Sat - | Some c -> - Util.incr_stat stat_loop_count; - Util.debugf ~section 2 - "@[<2>@{## saturate@}: given clause@ %a@]" - (fun k->k HC.pp c); - let c = simplify_full c in - if HC.is_trivial c || Avatar.has_trivial_trail c then ( - saturation_loop n - ) else if HC.is_absurd c then ( - Util.debugf ~section 2 "@[<2>@{found empty clause@}@ %a@]" - (fun k->k HC.pp c); - Unsat c - ) else if Active_set.mem c then ( - Util.debugf ~section 4 "clause %a already in active set, continue" - (fun k->k HC.pp c); - saturation_loop n - ) else if Active_set.is_subsumed c then ( - Util.debugf ~section 4 "clause %a subsumed by active set, continue" - (fun k->k HC.pp c); - Util.incr_stat stat_fwd_subsumed; - saturation_loop n - ) else ( - (* remove clauses subsumed by [c] *) - let set = Active_set.find_subsuming c in - HC.Set.iter - (fun c' -> - Util.debugf ~section 4 "active clause %a@ subsumed by %a,@ remove it" - (fun k->k HC.pp c' HC.pp c); - Util.incr_stat stat_backward_subsumed; - Active_set.remove c') - set; - (* add to [c] *) - Active_set.add c; - (* backward simplifications *) - let back_simplified = - back_simplify c |> Sequence.of_list - in - (* infer new clauses *) - let inferred = - Sequence.of_list rules_infer - |> Sequence.flat_map_l (fun rule -> rule c) - in - (* simplify all new clauses, send to passive set *) - let new_c : HC.t Sequence.t = - (Sequence.append back_simplified inferred) - |> Sequence.map simplify_fast - |> Sequence.flat_map_l (simplify_n Simplifications.rules_simp_n) - |> Sequence.filter (fun c -> not (HC.is_trivial c)) - in - Passive_set.add_seq new_c; - saturation_loop (n-1) (* did one step *) - ) - - let saturate ?(full=false) () = - let n_steps = if full then max_int else Ctx.saturation_steps in - saturation_loop n_steps - - let add_horn c : res = - Util.debugf ~section 2 "@[<2>@{saturate.add_horn@}@ %a@]" - (fun k->k HC.pp c); - let c = simplify_fast c in - (* this clause might be currently dead, but give it another chance *) - Passive_set.add c; - saturate () - - let add_clause c = - Util.debugf ~section 3 "@[<2>saturate.add_clause@ %a@]" - (fun k->k C.pp c); - begin match C.classify c with - | C.Horn hc -> add_horn hc - | C.General -> Sat (* wait until it is split *) - end - - let rec add_clauses (l:C.t list) = match l with - | [] -> Sat - | c :: tail -> - begin match add_clause c with - | Sat | Unknown -> add_clauses tail - | Unsat p -> Unsat p - end - end - - (** {2 Interface to literal-selection} *) - module Select : sig - val add_select : clause -> select_lit -> c_constraint -> Saturate.res - end = struct - let add_select (c:clause) (sel:select_lit) (constr:c_constraint): Saturate.res = - let lit = sel.select_lit in - let head, body = - if Lit.is_pos lit - then lit, IArray.empty - else Lit.false_, IArray.make 1 (Lit.neg lit) - in - let hc = - HC.make head body - ~constr ~label:[Labelled_clause.make_empty c sel] - ~trail:H_trail.empty ~unordered_depth:0 - (Proof.split c sel constr) - in - Saturate.add_horn hc - end - - (** {2 Main} *) - - let initial_clauses : C.t list = - CCVector.to_seq Ctx.statements - |> Sequence.flat_map Statement.Seq.forms - |> Sequence.to_rev_list - - (* check result of saturation and trigger appropriate events *) - let check_res (res:Saturate.res): unit = - begin match res with - | Saturate.Unknown - | Saturate.Sat -> () - | Saturate.Unsat c -> - assert (HC.is_absurd c); - Ctx.send_event (E_conflict (HC.trail c, HC.label c, HC.proof c)); - end - - let set_depth_limit d = - Depth_limit.set d; - Passive_set.update_depth_limit (); - (* some clauses might have become active *) - check_res (Saturate.saturate ()); - () - - let presaturate () = - (* add the set of initial clauses *) - Util.debugf ~section 2 "@{## start presaturation ##@}"(fun k->k); - let res = Saturate.add_clauses initial_clauses in - check_res res - - (* no direct communication with SAT solver *) - let on_assumption _ = () - - let on_event e = - begin match e with - | E_add_component r -> - (* assume this component *) - begin match C.classify r.bool_box_clause with - | C.Horn c -> - HC.start_new_cycle(); - HC.make_alive_again c; - check_res (Saturate.add_horn c) - | C.General -> () - end - | E_remove_component r -> remove_all_box r - | E_select_lit (c,sel,constr) -> - check_res (Select.add_select c sel constr) - | E_unselect_lit (_,r) -> remove_all_select r - | E_stage Stage_presaturate -> presaturate () - | E_stage Stage_exit -> - Util.debugf ~section 1 "@[<2>saturate:@ %a@]" - (fun k-> - let stats = Saturate.stats() in - k Saturate.pp_stats stats); - () - | E_stage (Stage_start | Stage_init) -> () - | E_remove_ground_lit _ -> () - | E_if_sat -> - (* saturate again, fully *) - check_res (Saturate.saturate ~full:true ()) - | E_add_ground_lit _ - | E_conflict _ - | E_found_unsat _ -> () - end -end - -let theory : State.theory_fun = (module Make) - diff --git a/src/hornet/Horn_superposition.mli b/src/hornet/Horn_superposition.mli deleted file mode 100644 index f1e6ad986..000000000 --- a/src/hornet/Horn_superposition.mli +++ /dev/null @@ -1,13 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(* {1 Superposition on Horn Clauses} *) - -(** This module contains the main first-order reasoning engine. - It works incrementally, by saturating a growing set of Horn Clauses - up to some pre-defined limit. *) - -module Make : State.THEORY_FUN - -val theory : State.theory_fun - diff --git a/src/hornet/Hornet_types.mli b/src/hornet/Hornet_types.mli deleted file mode 100644 index 4b7ae2e1e..000000000 --- a/src/hornet/Hornet_types.mli +++ /dev/null @@ -1,184 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Common Type Declarations} *) - -(** We gather here the main data structures, because they are - often mutually recursive *) - -open Logtk - -type ty = Type.t -type term = Term.t -type var = ty HVar.t -type formula = TypedSTerm.t -type bool_unique_id = int - -type 'a var_map = 'a Type.VarMap.t - -type clause = { - c_id: int; (* unique ID *) - c_lits: lit IArray.t; - c_kind: c_kind; (* mut: can update the horn clause *) - c_proof: proof; - c_trail: bool_trail; (* components/splits the clause depends on *) - c_depth: int; (* number of instantiations in its proof *) - mutable c_constr: c_constraint; - mutable c_select: select_lit option; (* if there is currently a selected lit *) - mutable c_grounding: bool_lit IArray.t option; (* grounding *) -} - -and lit = - | Bool of bool - | Atom of term * bool - | Eq of term * term * bool - -(* internal kind *) -and c_kind = - | C_horn of horn_clause lazy_t - | C_general - -and proof = - | P_trivial - | P_from_input of Statement.role (* added to input *) - | P_from_file of Statement.from_file * Statement.role - | P_cnf_neg of proof_with_res - | P_cnf of proof_with_res - | P_renaming of proof_with_res * ID.t * formula - | P_preprocess of proof_with_res * string - | P_instance of clause * Subst.t - | P_avatar_split of clause - (* given clause has been split into var-disjoint components, - one of which is the current clause *) - | P_avatar_cut of horn_clause * (bool_lit * proof) list (* cut the given literals *) - | P_split of clause * select_lit * c_constraint (* model-driven recursive splitting *) - | P_bool_tauto (* boolean tautology *) - | P_bool_res of bool_res_step - | P_bool_grounding of clause (* grounding of clause *) - | P_hc_superposition of hc_superposition_step - | P_hc_eq_res of horn_clause * Subst.t (* equality resolution *) - | P_hc_simplify of horn_clause - | P_hc_demod of horn_clause * horn_clause list (* passive, active set *) - -and proof_with_res = proof * proof_res - -and proof_res = - | PR_formula of formula - | PR_horn_clause of horn_clause - | PR_clause of clause - | PR_bool_clause of bool_clause - -(* TODO: (HO) unification constraints - TODO: E unification constraints, for datatypes - TODO: arith constraints *) -and c_constraint = { - constr_dismatch: Dismatching_constr.t list; -} - -and horn_clause = { - hc_id: int; (* unique ID *) - hc_head: lit; - hc_body: lit IArray.t; - hc_constr: c_constraint; - hc_trail: bool_trail; - hc_proof: proof; - hc_unordered_depth: int; (* how many unordered inferences needed? *) - hc_label: label; - mutable hc_status: (horn_clause_status * int); - (* where is the clause in its lifecycle? int=number of cycles *) -} - -and horn_clause_status = - | HC_alive (** Alive and kicking *) - | HC_dead (** Unregistered, inert *) - -(* clause + substitution, for grounding purpose *) -and labelled_clause = { - lc_clause: clause; (* invariant: non horn *) - lc_sel: select_lit; (* the selected lit in [lc_clause] *) - lc_subst: term var_map; (* substitution to instantiate the clause *) - lc_real_subst: Subst.t lazy_t; -} - -(* label of a Horn clause: a set of labelled clauses *) -and label = labelled_clause list - -(** Description of a single superposition step *) -and hc_superposition_step = { - hc_sup_active: horn_clause Scoped.t; (* positive unit *) - hc_sup_passive: horn_clause Scoped.t; (* non-unit *) - hc_sup_active_pos: Position.t; - hc_sup_passive_pos: Position.t; - hc_sup_s: term; (* LHS of active eqn *) - hc_sup_t: term; (* RHS of active eqn *) - hc_sup_rewritten: term; (* unifies with [s] *) - hc_sup_subst: Subst.t; -} - -(** Description of a single boolean resolution step - between two clauses *) -and bool_res_step = { - bool_res_c1: bool_clause; - bool_res_p1: proof; - bool_res_c2: bool_clause; - bool_res_p2: proof; - bool_res_atom: bool_lit; -} - -and bool_atom = - | A_fresh of bool_unique_id - | A_box_clause of bool_box_clause - | A_ground of bool_ground - -and bool_box_clause = { - bool_box_id: bool_unique_id; - bool_box_clause: clause; - mutable bool_box_depends : horn_clause list; (* clauses depending on this *) -} - -(* selection of a literal in a non-ground non-horn clause *) -and select_lit = { - select_idx: clause_idx; - select_lit: lit; (* [lit = get clause idx] *) - mutable select_depends : horn_clause list; (* clauses depending on this *) -} - -and bool_ground = { - bool_ground_lit: lit; - bool_ground_id: int; - mutable bool_ground_instance_of: (clause*clause_idx) list; - (* clauses whose instance contain this ground lit (at given index) *) -} - -(* index of a literal in a clause *) -and clause_idx = int - -and bool_lit = { - bl_atom: bool_atom; - bl_sign: bool; -} - -and bool_clause = bool_lit list - -and bool_trail = bool_lit lazy_t list -(** A boolean trail, guarding the clauses that hold only in some models *) - -(* stages in the solver's algorithm *) -type stage = - | Stage_init - | Stage_presaturate - | Stage_start - | Stage_exit - -type event = - | E_add_component of bool_box_clause - | E_remove_component of bool_box_clause - | E_select_lit of clause * select_lit * c_constraint - (** [lit | constr] has been selected in some clause *) - | E_unselect_lit of clause * select_lit - | E_add_ground_lit of bool_ground - | E_remove_ground_lit of bool_ground - | E_if_sat (** final check of the model *) - | E_conflict of bool_trail * label * proof (* boolean conflict in some theory *) - | E_found_unsat of proof_with_res (* final proof *) - | E_stage of stage diff --git a/src/hornet/Hornet_types_util.ml b/src/hornet/Hornet_types_util.ml deleted file mode 100644 index 1b367c853..000000000 --- a/src/hornet/Hornet_types_util.ml +++ /dev/null @@ -1,324 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Basics for Hornet Types} *) - -open Logtk -open Hornet_types - -module T = Term -module Fmt = CCFormat -module Stmt = Statement - -let pp_lit out (t:lit): unit = match t with - | Bool b -> Fmt.bool out b - | Atom (t, true) -> T.pp out t - | Atom (t, false) -> Fmt.fprintf out "@[@<1>¬@[%a@]@]" T.pp t - | Eq (t,u,true) -> Fmt.fprintf out "@[%a@ = %a@]" T.pp t T.pp u - | Eq (t,u,false) -> Fmt.fprintf out "@[%a@ @<1>≠ %a@]" T.pp t T.pp u - -let pp_clause_lits out a = - Fmt.fprintf out "@[%a@]" (Util.pp_seq ~sep:" ∨ " pp_lit) (IArray.to_seq a.c_lits) - -let pp_atom out = function - | A_fresh i -> Fmt.fprintf out "fresh_%d" i - | A_box_clause b -> Fmt.fprintf out "%a" pp_clause_lits b.bool_box_clause - | A_ground r -> pp_lit out r.bool_ground_lit - -let pp_select out (r:select_lit) = - Fmt.fprintf out - "@[select@ :idx %d@ :lit %a@]" - r.select_idx pp_lit r.select_lit - -let pp_bool_lit out l = - let pp_inner out l = Fmt.within "⟦" "⟧" pp_atom out l.bl_atom in - if l.bl_sign - then pp_inner out l - else Fmt.fprintf out "¬%a" pp_inner l - -let pp_bool_clause out l = - Fmt.fprintf out "[@[%a@]]" (Util.pp_list ~sep:" ⊔ " pp_bool_lit) l - -let pp_bool_trail out (l:bool_trail) = - let ppx out (lazy lit) = pp_bool_lit out lit in - Fmt.fprintf out "[@[%a@]]" (Util.pp_list ~sep:" ⊓ " ppx) l - -let pp_bool_trail_opt out trail = match trail with - | [] -> () - | _ -> - Fmt.fprintf out "@ @[@<1>⇐@ %a@]" pp_bool_trail trail - -let pp_constraint out (c:c_constraint): unit = - Fmt.fprintf out "{@[%a@]}" - (Util.pp_list Dismatching_constr.pp) c.constr_dismatch - -let pp_constraint_opt out (c:c_constraint): unit = - if not (List.for_all Dismatching_constr.is_trivial c.constr_dismatch) then ( - Fmt.fprintf out "@ | %a" pp_constraint c - ) - -let pp_hc_status out (s:horn_clause_status): unit = match s with - | HC_alive -> Fmt.string out "alive" - | HC_dead -> Fmt.string out "dead" - -let vars_of_lit (l:lit): _ HVar.t Sequence.t = match l with - | Bool _ -> Sequence.empty - | Atom (t,_) -> T.Seq.vars t - | Eq (t,u,_) -> Sequence.append (T.Seq.vars t) (T.Seq.vars u) - -let vars_of_clause (c:clause) = - IArray.to_seq c.c_lits |> Sequence.flat_map vars_of_lit - -let vars_of_hclause (c:horn_clause) = - Sequence.append - (vars_of_lit c.hc_head) - (IArray.to_seq c.hc_body |> Sequence.flat_map vars_of_lit) - -(* remove trivial bindings from the substitution *) -let lc_filter_subst lc_subst: (var*term) Sequence.t = - Type.VarMap.to_seq lc_subst - |> Sequence.filter - (fun (v,t) -> match T.view t with - | T.Var v' -> not (HVar.equal Type.equal v v') - | _ -> true) - -(* stuff for printing clauses *) -module PP_c = struct - let pp_body out body = - if IArray.length body > 0 then ( - Fmt.fprintf out " @<1>← @[%a@]" (Util.pp_seq ~sep:" ∧ " pp_lit) (IArray.to_seq body) - ); - and pp_vars pp x out = function - | [] -> pp out x - | vars -> - Fmt.fprintf out "@[<2>∀ %a.@ %a@]" - (Util.pp_list ~sep:" " Type.pp_typed_var) vars pp x - and pp_lits out (lits:lit IArray.t) = - Fmt.fprintf out "[@[%a@]]" (Fmt.seq pp_lit) (IArray.to_seq lits) -end - -let pp_clause out (c:clause): unit = - let open PP_c in - let vars = vars_of_clause c |> T.VarSet.of_seq |> T.VarSet.to_list in - let pp_main out () = - Fmt.fprintf out "@[%a%a@]" - pp_clause_lits c pp_constraint_opt c.c_constr - in - pp_vars pp_main () out vars - -let pp_lc out (lc:labelled_clause): unit = - let pp_subst out lc = - Fmt.fprintf out "{@[%a@]}" - Fmt.(seq (pair ~sep:(return "@ -> ") HVar.pp T.pp)) - (lc_filter_subst lc.lc_subst) - in - Fmt.fprintf out "(@[%a@ @[:subst %a@]@ @[:select `%a`/%d@]@])" - pp_clause lc.lc_clause pp_subst lc pp_lit lc.lc_sel.select_lit - lc.lc_sel.select_idx - -let pp_label out (l:label): unit = - Fmt.fprintf out "{@[%a@]}" (Fmt.list pp_lc) l - -let pp_hclause out (c:horn_clause): unit = - let open PP_c in - let pp_label_opt out = function - | [] -> () - | lcs -> Fmt.fprintf out "@ label:%a" pp_label lcs - in - let pp_main out () = - Fmt.fprintf out "(@[%a%a%a%a%a@])" - pp_lit c.hc_head - pp_body c.hc_body - pp_bool_trail_opt c.hc_trail - pp_constraint_opt c.hc_constr - pp_label_opt c.hc_label - in - let vars = vars_of_hclause c |> T.VarSet.of_seq |> T.VarSet.to_list in - pp_vars pp_main () out vars - -let pp_hc_sup out sup : unit = - Fmt.fprintf out - "(@[hc_sup@ :active %a@ :at %a@ :passive %a@ :at %a@ :subst %a@])" - (Scoped.pp pp_hclause) sup.hc_sup_active - Position.pp sup.hc_sup_active_pos - (Scoped.pp pp_hclause) sup.hc_sup_passive - Position.pp sup.hc_sup_passive_pos - Subst.pp sup.hc_sup_subst - -let pp_proof out (p:proof) : unit = match p with - | P_trivial -> Fmt.string out "trivial" - | P_from_file (f,r) -> - Fmt.fprintf out "(@[<2>file %a@ :role %a@])" - Stmt.Src.pp_from_file f Stmt.Src.pp_role r - | P_from_input r -> - Fmt.fprintf out "(@[<2>input :role %a@])" Stmt.Src.pp_role r - | P_cnf _ -> Fmt.string out "cnf" - | P_cnf_neg _ -> Fmt.string out "cnf_neg" - | P_renaming (_,id,_) -> Fmt.fprintf out "(@[renaming :id %a@])" ID.pp id - | P_preprocess (_,msg) -> Fmt.fprintf out "(@[preprocess %S@])" msg - | P_instance (c, subst) -> - Fmt.fprintf out "(@[instance@ :clause %a@ :subst %a@])" - pp_clause c Subst.pp subst - | P_avatar_split c -> - Fmt.fprintf out "(@[avatar_split@ :from %a@])" pp_clause c - | P_avatar_cut (c, lits) -> - let pp_pair out (l,_) = pp_bool_lit out l in - Fmt.fprintf out "(@[avatar_cut@ :from %a@ :lits (@[%a@])@])" - pp_hclause c (Util.pp_list pp_pair) lits - | P_split (c,sel,constr) -> - Fmt.fprintf out "(@[split@ :clause %a@ :idx %a@ :constr %a@])" - pp_clause c pp_select sel pp_constraint constr - | P_bool_tauto -> Fmt.string out "bool_tauto" - | P_bool_res r -> - Fmt.fprintf out "(@[bool_res@ :on %a@ :c1 %a@ :c2 %a@])" - pp_bool_lit r.bool_res_atom - pp_bool_clause r.bool_res_c1 - pp_bool_clause r.bool_res_c2 - | P_bool_grounding c -> - Fmt.fprintf out "(@[<2>grounding@ %a@])" pp_clause c - | P_hc_superposition sup -> pp_hc_sup out sup - | P_hc_eq_res (c,subst) -> - Fmt.fprintf out "(@[eq_resolution@ :on %a@ :subst %a@])" - pp_hclause c Subst.pp subst - | P_hc_simplify c -> - Fmt.fprintf out "(@[simplify@ %a@])" pp_hclause c - | P_hc_demod (c,c_l) -> - Fmt.fprintf out "(@[demod@ :clause %a@ :rules {@[%a@]}@])" - pp_hclause c (Util.pp_list pp_hclause) c_l - -let equal_lit (a:lit) (b:lit): bool = match a, b with - | Bool b1, Bool b2 -> b1=b2 - | Atom (t1,sign1), Atom (t2,sign2) -> T.equal t1 t2 && sign1=sign2 - | Eq (t1,u1,sign1), Eq (t2,u2,sign2) -> - sign1=sign2 && - T.equal t1 t2 && T.equal u1 u2 - | Bool _, _ - | Atom _, _ - | Eq _, _ - -> false - -let hash_lit : lit -> int = function - | Bool b -> Hash.combine2 10 (Hash.bool b) - | Atom (t,sign) -> Hash.combine3 20 (T.hash t) (Hash.bool sign) - | Eq (t,u,sign) -> Hash.combine4 30 (T.hash t) (T.hash u) (Hash.bool sign) - -let equal_atom (a:bool_atom) b : bool = - begin match a, b with - | A_fresh i, A_fresh j -> i=j - | A_box_clause r1, A_box_clause r2 -> r1.bool_box_id = r2.bool_box_id - | A_ground r1, A_ground r2 -> r1.bool_ground_id = r2.bool_ground_id - | A_fresh _, _ - | A_box_clause _, _ - | A_ground _, _ - -> false - end - -let equal_bool_lit (a:bool_lit) b : bool = - a.bl_sign = b.bl_sign && - equal_atom a.bl_atom b.bl_atom - -let equal_clause (a:clause) b: bool = a.c_id = b.c_id -let hash_clause (a:clause) : int = CCHash.int a.c_id -let compare_clause a b: int = CCInt.compare a.c_id b.c_id - -let equal_lc (a:labelled_clause) b: bool = - equal_clause a.lc_clause b.lc_clause && - Type.VarMap.equal T.equal a.lc_subst b.lc_subst - -let hash_lc (a:labelled_clause): int = - CCHash.combine2 - CCHash.(seq (pair HVar.hash T.hash) (Type.VarMap.to_seq a.lc_subst)) - (hash_clause a.lc_clause) - -let compare_lc (a:labelled_clause) b: int = - CCOrd.(compare_clause a.lc_clause b.lc_clause - (Type.VarMap.compare T.compare, a.lc_subst, b.lc_subst)) - -let compare_atom (a:bool_atom) b : int = - let to_int = function - | A_fresh _ -> 0 - | A_box_clause _ -> 1 - | A_ground _ -> 2 - in - begin match a, b with - | A_fresh i, A_fresh j -> CCInt.compare i j - | A_box_clause r1, A_box_clause r2 -> CCInt.compare r1.bool_box_id r2.bool_box_id - | A_ground r1, A_ground r2 -> CCInt.compare r1.bool_ground_id r2.bool_ground_id - | A_fresh _, _ - | A_box_clause _, _ - | A_ground _, _ - -> CCInt.compare (to_int a)(to_int b) - end - -let compare_bool_lit (a:bool_lit) b : int = - let c = CCBool.compare a.bl_sign b.bl_sign in - if c<> 0 then c - else compare_atom a.bl_atom b.bl_atom - -let neg_bool_lit t = {t with bl_sign=not t.bl_sign} - -let int_of_atom (a:bool_atom): int = match a with - | A_box_clause r -> r.bool_box_id - | A_fresh i -> i - | A_ground r -> r.bool_ground_id - -let int_of_bool_lit (t:bool_lit): int = - let i = int_of_atom t.bl_atom in - if t.bl_sign then i else -i - -(* same trail, modulo ordering *) -let equal_bool_trail (a:bool_trail) b: bool = - let cmp (lazy a)(lazy b) = compare_bool_lit a b in - assert (CCList.is_sorted ~cmp a); - assert (CCList.is_sorted ~cmp b); - CCList.equal (fun a b-> cmp a b=0) a b - -let subsumes_bool_trail (l1:bool_trail) (l2:bool_trail): bool = - let rec aux l1 l2 = match l1, l2 with - | [], _ -> true - | _, [] -> false - | lazy t1 :: tail1, lazy t2 :: tail2 -> - begin match compare_bool_lit t1 t2 with - | 0 -> aux tail1 tail2 - | n when n<0 -> false (* all elements of [l2] are bigger than [t1] *) - | _ -> aux l1 tail2 (* drop [t2] *) - end - in - aux l1 l2 - -let hash_bool_lit a : int = match a.bl_atom with - | A_fresh i -> Hash.combine3 10 (Hash.bool a.bl_sign) (Hash.int i) - | A_box_clause r -> Hash.combine2 15 (Hash.int r.bool_box_id) - | A_ground r -> Hash.combine2 50 (Hash.int r.bool_ground_id) - -let pp_stage out = function - | Stage_init -> Fmt.string out "init" - | Stage_presaturate -> Fmt.string out "presaturate" - | Stage_start -> Fmt.string out "start" - | Stage_exit -> Fmt.string out "exit" - -let pp_event out (e:event): unit = match e with - | E_add_component r -> - Fmt.fprintf out "(@[add_component@ %a@])" pp_clause r.bool_box_clause - | E_remove_component r -> - Fmt.fprintf out "(@[remove_component@ %a@])" pp_clause r.bool_box_clause - | E_select_lit (c,r,cstr) -> - Fmt.fprintf out "(@[select_lit@ %a@ :clause %a@ :constr %a@])" - pp_lit r.select_lit - pp_clause c - pp_constraint cstr - | E_unselect_lit (c,r) -> - Fmt.fprintf out "(@[unselect_lit@ %a@ :clause %a@])" - pp_lit r.select_lit pp_clause c - | E_add_ground_lit r -> - Fmt.fprintf out "(@[add_ground_lit@ %a@])" pp_lit r.bool_ground_lit - | E_remove_ground_lit r -> - Fmt.fprintf out "(@[remove_ground_lit@ %a@])" pp_lit r.bool_ground_lit - | E_conflict (trail,l,p) -> - Fmt.fprintf out "(@[conflict@ :trail %a@ :label %a@ :proof %a@])" - pp_bool_trail trail pp_label l pp_proof p - | E_if_sat -> Fmt.string out "if_sat" - | E_found_unsat (p,_) -> - Fmt.fprintf out "(@[found_unsat@ :proof %a@])" pp_proof p - | E_stage s -> Fmt.fprintf out "(@[stage %a@])" pp_stage s - diff --git a/src/hornet/Label.ml b/src/hornet/Label.ml deleted file mode 100644 index cac052074..000000000 --- a/src/hornet/Label.ml +++ /dev/null @@ -1,81 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Label for Horn Clauses} *) - -open Logtk -open Hornet_types - -module Fmt = CCFormat -module LC = Labelled_clause - -type t = label -(** Set of labelled clauses. - Invariants: sorted; all labelled instances of a clause have same literal *) - -let return l : t = [l] - -let make l = CCList.sort_uniq ~cmp:LC.compare l - -let is_empty = CCList.is_empty - -let all_empty = List.for_all LC.is_empty - -let check_inv_sorted_ (l:t): bool = - CCList.is_sorted ~cmp:LC.compare l - -(* check invariant about labelled instances *) -let check_inv_ (l:t): bool = - List.for_all - (fun lc -> - List.for_all - (fun lc' -> - if Hornet_types_util.equal_clause lc.lc_clause lc'.lc_clause - then lc.lc_sel.select_idx = lc'.lc_sel.select_idx - else true) - l) - l - -let has_no_ground_instance l= - assert (check_inv_sorted_ l); - assert (check_inv_ l); - List.exists LC.has_no_ground_instance l - -let merge = CCList.sorted_merge_uniq ~cmp:LC.compare - -let apply_subst ~renaming subst (l,sc) = - l - |> List.rev_map (fun lc -> LC.apply_subst ~renaming subst (lc,sc)) - |> make - -let to_list (t:t) : _ list = t -let to_seq = Sequence.of_list - -let pp = Hornet_types_util.pp_label - -let to_string = Fmt.to_string pp - -let hash (t:t): int = Hash.list LC.hash t - -let hash_mod_alpha (t:t): int = Hash.list_comm LC.hash_mod_alpha t - -let equal (a:t)(b:t): bool = CCList.equal LC.equal a b - -(* TODO: use LC.hash_mod_alpha to partition elements? - maybe add this to unif_list_com as optional arg *) -let variant ?(subst=Subst.empty) (l1,sc1)(l2,sc2): Subst.t Sequence.t = - Unif.unif_list_com subst (l1,sc1)(l2,sc2) - ~op:(fun subst a b -> LC.variant ~subst a b) - -let matching ?(subst=Subst.empty) (l1,sc1)(l2,sc2): Subst.t Sequence.t = - Unif.unif_list_com subst (l1,sc1)(l2,sc2) - ~op:(fun subst a b -> LC.matching ~subst a b) - -let subsumes ?(subst=Subst.empty) (l1,sc1) (l2,sc2) = - Unif.unif_list_com - ~size:`Smaller - ~op:(fun subst a b -> LC.matching ~subst a b) - subst (l1,sc1)(l2,sc2) - -let subsumes_pred ?subst a b: bool = - not (Sequence.is_empty (subsumes ?subst a b)) diff --git a/src/hornet/Label.mli b/src/hornet/Label.mli deleted file mode 100644 index 79fe4e584..000000000 --- a/src/hornet/Label.mli +++ /dev/null @@ -1,64 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Label for Horn Clauses} *) - -open Logtk -open Hornet_types - -type t = Hornet_types.label -(** Set of labelled clauses. Invariant: sorted *) - -include Interfaces.PRINT with type t := t -include Interfaces.HASH with type t := t - -val hash_mod_alpha : t -> int - -val return : labelled_clause -> t - -val make : labelled_clause list -> t - -val is_empty : t -> bool -(** Empty set of labels *) - -val all_empty : t -> bool -(** All labelled clauses have empty labels. See {!Labelled_clause.is_empty} *) - -val has_no_ground_instance : t -> bool -(** Some labelled clause has unsatisfiable constraints *) - -val apply_subst : - renaming:Subst.Renaming.t -> - Subst.t -> - t Scoped.t -> - t - -val variant : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t - -val matching : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t -(** Substitution that make these the first label imply the second *) - -val subsumes : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t - -val subsumes_pred : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - bool - -val merge : t -> t -> t - -val to_list : t -> labelled_clause list -val to_seq: t -> labelled_clause Sequence.t diff --git a/src/hornet/Labelled_clause.ml b/src/hornet/Labelled_clause.ml deleted file mode 100644 index f4a220d16..000000000 --- a/src/hornet/Labelled_clause.ml +++ /dev/null @@ -1,112 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Labelled Clause} *) - -open Logtk -open Hornet_types - -module T = Term - -type t = labelled_clause - -let make c sel subst lc_real_subst : t = - {lc_clause=c; lc_sel=sel; lc_subst=subst; lc_real_subst} - -let make_empty (c:clause) (sel:select_lit): t = - (* initial subst: maps each var to itself *) - let subst = - IArray.to_seq c.c_lits - |> Sequence.flat_map Lit.vars_seq - |> T.VarSet.of_seq - |> T.VarSet.to_seq - |> Sequence.map (fun v -> v, T.var v) - |> Type.VarMap.of_seq - in - make c sel subst (Lazy.from_val Subst.empty) - -let equal = Hornet_types_util.equal_lc -let hash = Hornet_types_util.hash_lc -let compare = Hornet_types_util.compare_lc -let pp = Hornet_types_util.pp_lc -let to_string = CCFormat.to_string pp - -let same_clause lc1 lc2: bool = - Hornet_types_util.equal_clause lc1.lc_clause lc2.lc_clause - -let hash_mod_alpha (lc:t): int = - Hash.combine2 - (Hornet_types_util.hash_clause lc.lc_clause) - (Hash.(list_comm (pair HVar.hash T.hash_mod_alpha)) - (Type.VarMap.to_list lc.lc_subst)) - -let filter_subst = Hornet_types_util.lc_filter_subst - -let to_subst (lc:t): Subst.t = Lazy.force lc.lc_real_subst - -let to_subst_real lc_subst: Subst.t = - Type.VarMap.to_seq lc_subst - |> Sequence.map - (fun (v,t) -> - (* add scope, perform ugly casting *) - ((v:Type.t HVar.t:>InnerTerm.t HVar.t),0), ((t:T.t:>InnerTerm.t),1)) - |> Subst.of_seq - -let apply_subst ~renaming subst (lc,sc) = - let lc_subst = - Type.VarMap.map (fun t -> Subst.FO.apply ~renaming subst (t,sc)) - lc.lc_subst - in - { lc with lc_subst; lc_real_subst=lazy (to_subst_real lc_subst) } - -(* empty if the substitution is empty, or if it only renames binds - variables to other variables *) -let is_empty (lc:t) = - let subst = to_subst lc in - Subst.is_empty subst || - ( Subst.codomain subst - |> Sequence.for_all (fun (t,_) -> T.is_var (T.of_term_unsafe t))) - -(* absurd if at least one constraint of the clause is absurd under - current substitution. - NOTE: this is not cachable, as [lc.lc_clause.c_constr] is mutable. *) -let has_no_ground_instance_ (lc:t): bool = - Constraint.is_absurd_with - (to_subst lc) - (lc.lc_clause.c_constr,0) - -let prof_no_instance = Util.mk_profiler "labelled_clause.has_no_instance" -let has_no_ground_instance lc = Util.with_prof prof_no_instance has_no_ground_instance_ lc - -let to_dismatch (lc:t): Dismatching_constr.t = - filter_subst lc.lc_subst - |> Sequence.map (fun (v,t) -> T.var v, t) - |> Sequence.to_rev_list - |> CCFun.tap (fun l -> assert (l<>[])) - |> Dismatching_constr.make - -(* the literals corresponding to instantiating the clause with the subst *) -let lits_instance lc: Lit.t IArray.t = - let subst = to_subst lc in - Lit.apply_subst_arr_no_renaming subst (lc.lc_clause.c_lits,0) - -(* find whether these are variants. - We use [C.equal] to compare clauses, so it's not totally structural. *) -let variant ?(subst=Subst.empty) (lc1,sc1)(lc2,sc2): Subst.t Sequence.t = - if Hornet_types_util.equal_clause lc1.lc_clause lc2.lc_clause - then ( - assert (Type.VarMap.cardinal lc1.lc_subst = Type.VarMap.cardinal lc2.lc_subst); - Unif.unif_list subst - (Type.VarMap.values lc1.lc_subst |> Sequence.to_rev_list, sc1) - (Type.VarMap.values lc2.lc_subst |> Sequence.to_rev_list, sc2) - ~op:(fun subst a b -> - try Sequence.return (Unif.FO.variant ~subst a b) - with Unif.Fail -> Sequence.empty) - ) else Sequence.empty - -(* it is unclear what would be the exact criterion for a labelled clause - to subsume another instance of the same clause with a difference - substitution, so we only accept that [lc1] subsumes [lc2] if - [lc1 = lc2] *) -let matching = variant - diff --git a/src/hornet/Labelled_clause.mli b/src/hornet/Labelled_clause.mli deleted file mode 100644 index 742263322..000000000 --- a/src/hornet/Labelled_clause.mli +++ /dev/null @@ -1,55 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Labelled Clause} *) - -open Logtk -open Hornet_types - -type t = labelled_clause - -val make_empty : clause -> select_lit -> t -(** Initial empty label for this clause *) - -include Interfaces.PRINT with type t := t -include Interfaces.HASH with type t := t -include Interfaces.ORD with type t := t - -val same_clause : t -> t -> bool -(** Two labels for the same clause? *) - -val apply_subst : - renaming:Subst.Renaming.t -> - Subst.t -> - t Scoped.t -> - t -(** Apply the substitution to each variable in the given scope *) - -val hash_mod_alpha : t -> int - -val is_empty : t -> bool -(** Is the substitution trivial? (i.e. a renaming) *) - -val has_no_ground_instance : t -> bool -(** The constraints attached to the clause are not compatible - with the current substitution, meaning that the labelled clause - represents 0 ground clauses *) - -val to_subst : t -> Subst.t -(** Build a substitution (all terms have scope 0) *) - -val to_dismatch : t -> Dismatching_constr.t -(** Build a dismatching constraints that excludes precisely the - current substitution *) - -val variant : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t - -val matching : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t diff --git a/src/hornet/Lit.ml b/src/hornet/Lit.ml deleted file mode 100644 index ef7d3f10f..000000000 --- a/src/hornet/Lit.ml +++ /dev/null @@ -1,465 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Literal} *) - -open Logtk - -module Fmt = CCFormat -module T = Term -module TI = InnerTerm -module P = Position -module PW = Position.With -module S = Subst - -type ty = Type.t -type term = T.t - -type t = Hornet_types.lit = - | Bool of bool - | Atom of term * bool - | Eq of term * term * bool - -type lit = t - -let true_ = Bool true -let false_ = Bool false -let bool b = Bool b - -let ty_error_ a b = - let msg = - CCFormat.sprintf - "@[<2>Literal: incompatible types in equational lit@ \ - for `@[%a : %a@]`@ and `@[%a : %a@]`@]" - T.pp a Type.pp (T.ty a) T.pp b Type.pp (T.ty b) - in - raise (Type.ApplyError msg) - -(* primary constructor for equations and predicates *) -let rec mk_lit t u sign = - if not (Type.equal (T.ty t) (T.ty u)) then ty_error_ t u; - begin match TI.view (t:T.t:>TI.t), TI.view (u:T.t:>TI.t) with - | TI.AppBuiltin (Builtin.True, []), TI.AppBuiltin (Builtin.False, []) -> bool sign - | TI.AppBuiltin (Builtin.False, []), TI.AppBuiltin (Builtin.True, []) -> bool (not sign) - | TI.AppBuiltin (Builtin.True, []), _ -> Atom (u, sign) - | _, TI.AppBuiltin (Builtin.True, []) -> Atom (t, sign) - | TI.AppBuiltin (Builtin.False, []), _ -> Atom (u, not sign) - | _, TI.AppBuiltin (Builtin.False, []) -> Atom (t, not sign) - | TI.AppBuiltin (Builtin.Not, [t']), _ -> - mk_lit (T.of_term_unsafe t') u (not sign) - | _, TI.AppBuiltin (Builtin.Not, [u']) -> - mk_lit t (T.of_term_unsafe u') (not sign) - | _ -> Eq (t, u, sign) - end - -let eq ?(sign=true) t u = mk_lit t u sign - -let rec mk_atom t sign = match T.view t with - | T.AppBuiltin (Builtin.True, []) -> bool sign - | T.AppBuiltin (Builtin.False, []) -> bool (not sign) - | T.AppBuiltin (Builtin.Not, [t']) -> mk_atom t' (not sign) - | _ -> - if not (Type.equal (T.ty t) Type.prop) then ty_error_ t T.true_; - Atom (t, sign) - -let atom ?(sign=true) t = mk_atom t sign - -let sign = function - | Atom (_, b) - | Eq (_,_,b) - | Bool b -> b - -let is_pos = sign -let is_neg l = not (sign l) - -let equal = Hornet_types_util.equal_lit -let hash = Hornet_types_util.hash_lit - -let compare a b: int = - let to_int = function Bool _ -> 0 | Atom _ -> 1 | Eq _ -> 2 in - begin match a, b with - | Bool b1, Bool b2 -> CCOrd.bool b1 b2 - | Atom (t1,sign1), Atom (t2,sign2) -> - CCOrd.( T.compare t1 t2 (bool, sign1, sign2)) - | Eq (t1,u1,sign1), Eq (t2,u2,sign2) -> - CCOrd.( T.compare t1 t2 - (T.compare, u1, u2) - (bool, sign1, sign2)) - | Bool _, _ - | Atom _, _ - | Eq _, _ - -> CCInt.compare (to_int a)(to_int b) - end - -let pp = Hornet_types_util.pp_lit -let to_string = Fmt.to_string pp - -(** {2 Helpers} *) - -let neg lit = match lit with - | Eq (l,r,sign) -> Eq (l,r,not sign) - | Atom (p, sign) -> Atom (p, not sign) - | Bool b -> Bool (not b) - -let terms (lit:t): term Sequence.t = match lit with - | Bool _ -> Sequence.empty - | Atom (t,_) -> Sequence.return t - | Eq (l,r,_) -> Sequence.doubleton l r - -let vars_seq = Hornet_types_util.vars_of_lit - -let vars_list l = vars_seq l |> Sequence.to_rev_list - -let vars_set l = - vars_seq l - |> Sequence.to_rev_list - |> CCList.sort_uniq ~cmp:(HVar.compare Type.compare) - -let is_ground t : bool = vars_seq t |> Sequence.is_empty - -let depth t : int = - terms t |> Sequence.map T.depth |> Sequence.max |> CCOpt.get_or ~default:0 - -let weight = function - | Bool _ -> 0 - | Atom (t, _) -> T.weight t - | Eq (t,u,_) -> T.weight t + T.weight u - -let var_occurs ~var t = terms t |> Sequence.exists (T.var_occurs ~var) - -let hash_mod_alpha = function - | Bool b -> Hash.combine2 10 (Hash.bool b) - | Atom (t,sign) -> Hash.combine3 20 (T.hash_mod_alpha t) (Hash.bool sign) - | Eq (t,u,sign) -> - let h_t = T.hash_mod_alpha t in - let h_u = T.hash_mod_alpha u in - let h1 = min h_t h_u in - let h2 = max h_t h_u in - Hash.combine4 30 h1 h2 (Hash.bool sign) - -let is_trivial = function - | Bool true -> true - | Bool false - | Atom _ -> false - | Eq (a,b,true) -> T.equal a b - | Eq (_,_,false) -> - false (* TODO: check if distinct cstors/distinct dom elements *) - -let is_absurd lit = match lit with - | Eq (l, r, false) when T.equal l r -> true - | Atom (p, false) when T.equal p T.true_ -> true - | Atom (p, true) when T.equal p T.false_ -> true - | Bool false -> true - | _ -> false - -let to_slit lit: term SLiteral.t = match lit with - | Bool true -> SLiteral.true_ - | Bool false -> SLiteral.false_ - | Atom (t, sign) -> SLiteral.atom t sign - | Eq (t, u, true) -> SLiteral.eq t u - | Eq (t, u, false) -> SLiteral.neq t u - -(** {2 Containers} *) - -module As_key = struct - type t = lit - let compare = compare - let equal = equal - let hash = hash -end - -module Set = CCSet.Make(As_key) -module Tbl = CCHashtbl.Make(As_key) - -(** {2 Positions} *) - -module With_pos = struct - type t = lit Position.With.t - - let pp = PW.pp pp - let compare = PW.compare compare - let to_string = Fmt.to_string pp -end - -let direction ord = function - | Bool _ -> None - | Atom _ -> None - | Eq (t,u,_) -> Ordering.compare ord t u |> CCOpt.return - -let at_pos_exn pos lit = match lit, pos with - | Bool b, P.Stop -> if b then T.true_ else T.false_ - | Atom (t,_), P.Left pos' -> T.Pos.at t pos' - | Eq (t,_,_), P.Left pos' -> T.Pos.at t pos' - | Eq (_,u,_), P.Right pos' -> T.Pos.at u pos' - | _, _ -> raise Not_found - -let active_terms ?(pos=P.stop) ord lit = - let yield_term t pos = PW.make t pos in - begin match lit with - | Atom (t,true) -> - Sequence.return (yield_term t (P.append pos (P.left P.stop))) - | Eq (t,u,true) -> - begin match Ordering.compare ord t u with - | Comparison.Eq -> Sequence.empty (* trivial *) - | Comparison.Incomparable -> - Sequence.doubleton - (yield_term t (P.append pos (P.left P.stop))) - (yield_term u (P.append pos (P.right P.stop))) - | Comparison.Gt -> - Sequence.return (yield_term t (P.append pos (P.left P.stop))) - | Comparison.Lt -> - Sequence.return (yield_term u (P.append pos (P.right P.stop))) - end - | Bool _ - | Atom (_,false) - | Eq (_,_,false) -> Sequence.empty - end - -let passive_terms ?(pos=P.stop) ord lit = - let explore_term t pos = - T.all_positions ~pos ~vars:false ~ty_args:false t - |> Sequence.map PW.of_pair - in - begin match lit with - | Atom (t,_) -> explore_term t (P.append pos (P.left P.stop)) - | Eq (t,u,_) -> - begin match Ordering.compare ord t u with - | Comparison.Eq -> Sequence.empty (* trivial *) - | Comparison.Incomparable -> - Sequence.append - (explore_term t (P.append pos (P.left P.stop))) - (explore_term u (P.append pos (P.right P.stop))) - | Comparison.Gt -> explore_term t (P.append pos (P.left P.stop)) - | Comparison.Lt -> explore_term u (P.append pos (P.right P.stop)) - end - | Bool _ -> Sequence.empty - end - -let seq_terms = function - | Atom (t,_) -> Sequence.return t - | Eq (a,b,_) -> Sequence.doubleton a b - | Bool _ -> Sequence.empty - -module Pos = struct - type split = { - lit_pos : P.t; - term_pos : P.t; - term : term; - } - - let _fail_lit lit pos = - Util.errorf ~where:"Lit.Pos" - "@[<2>invalid position `@[%a@]`@ in lit `@[%a@]`@]" - P.pp pos pp lit - - let split lit pos = match lit, pos with - | Bool true, P.Stop -> - {lit_pos=P.stop; term_pos=P.stop; term=T.true_; } - | Bool false, P.Stop -> - {lit_pos=P.stop; term_pos=P.stop; term=T.false_; } - | Eq(l,_,_), P.Left pos' -> - {lit_pos=P.(left stop); term_pos=pos'; term=l; } - | Eq(_,r,_), P.Right pos' -> - {lit_pos=P.(right stop); term_pos=pos'; term=r; } - | Atom (p,_), P.Left pos' -> - {lit_pos=P.(left stop); term_pos=pos'; term=p; } - | _ -> _fail_lit lit pos - - let cut lit pos = - let s = split lit pos in - s.lit_pos, s.term_pos - - let at lit pos = - let s = split lit pos in - T.Pos.at s.term s.term_pos - - let replace lit ~at ~by = match lit, at with - | Eq(l, r, sign), P.Left pos' -> - eq (T.Pos.replace l pos' ~by) r ~sign - | Eq(l, r, sign), P.Right pos' -> - eq l (T.Pos.replace r pos' ~by) ~sign - | Atom (p, sign), P.Left pos' -> - atom (T.Pos.replace p pos' ~by) ~sign - | Bool _, _ -> lit (* flexible, lit can be the result of a simplification *) - | _ -> _fail_lit lit at -end - -let as_eqn lit = match lit with - | Eq (l,r,sign) -> Some (l, r, sign) - | Atom (p, sign) -> Some (p, T.true_, sign) - | Bool _ -> None - -let get_eqn lit position = match lit, position with - | Eq (l,r,sign), P.Left _ -> Some (l, r, sign) - | Eq (l,r,sign), P.Right _ -> Some (r, l, sign) - | Atom (p, sign), P.Left _ -> Some (p, T.true_, sign) - | Bool _, _ -> None - | _ -> Util.errorf ~where:"Lit.get_eqn" - "wrong literal `%a` or position `%a`" pp lit P.pp position - -let get_eqn_exn lit pos = match get_eqn lit pos with - | Some x -> x - | None -> Util.errorf ~where:"Lit.get_eqn_exn" - "non equational literal `%a`" pp lit P.pp pos - -(** {2 Unif} *) - -(** Unification-like operation on components of a literal. *) -module Unif_gen = struct - type op = { - term : subst:Subst.t -> term Scoped.t -> term Scoped.t -> - Subst.t Sequence.t; - } - - let op_matching : op = { - term=(fun ~subst t1 t2 k -> - try k (Unif.FO.matching_adapt_scope ~subst ~pattern:t1 t2) - with Unif.Fail -> ()); - } - - let op_variant : op = { - term=(fun ~subst t1 t2 k -> - try k (Unif.FO.variant ~subst t1 t2) - with Unif.Fail -> ()); - } - - let op_unif : op = { - term=(fun ~subst t1 t2 k -> - try k (Unif.FO.unification ~subst t1 t2) - with Unif.Fail -> ()); - } - - (* match {x1,y1} in scope 1, with {x2,y2} with scope2 *) - let unif4 f ~subst x1 y1 sc1 x2 y2 sc2 k = - f ~subst (Scoped.make x1 sc1) (Scoped.make x2 sc2) - (fun subst -> f ~subst (Scoped.make y1 sc1) (Scoped.make y2 sc2) k); - f ~subst (Scoped.make y1 sc1) (Scoped.make x2 sc2) - (fun subst -> f ~subst (Scoped.make x1 sc1) (Scoped.make y2 sc2) k); - () - - (* generic unification structure *) - let unif_lits (op:op) ~subst (lit1,sc1) (lit2,sc2) k = - begin match lit1, lit2 with - | Atom (p1, sign1), Atom (p2, sign2) when sign1 = sign2 -> - op.term ~subst (p1,sc1) (p2,sc2) k - | Bool b1, Bool b2 -> if b1=b2 then k subst - | Eq (l1, r1, sign1), Eq (l2, r2, sign2) when sign1 = sign2 -> - unif4 op.term ~subst l1 r1 sc1 l2 r2 sc2 k - | _, _ -> () - end -end - -let variant ?(subst=S.empty) lit1 lit2 k = - Unif_gen.unif_lits Unif_gen.op_variant ~subst lit1 lit2 k - -let are_variant lit1 lit2 = - not (Sequence.is_empty (variant (Scoped.make lit1 0) (Scoped.make lit2 1))) - -let matching ?(subst=Subst.empty) ~pattern:lit1 lit2 k = - let op = Unif_gen.op_matching in - Unif_gen.unif_lits op ~subst lit1 lit2 k - -(* find substitutions such that subst(l1=r1) implies l2=r2 *) -let eq_subsumes_ ~subst l1 r1 sc1 l2 r2 sc2 k = - (* make l2 and r2 equal using l1 = r2 (possibly several times) *) - let rec equate_terms ~subst l2 r2 k = - (* try to make the terms themselves equal *) - equate_root ~subst l2 r2 k; - (* decompose *) - match T.view l2, T.view r2 with - | _ when T.equal l2 r2 -> k subst - | T.App (f, ss), T.App (g, ts) when List.length ss = List.length ts -> - equate_terms ~subst f g - (fun subst -> equate_lists ~subst ss ts k) - | _ -> () - and equate_lists ~subst l2s r2s k = match l2s, r2s with - | [], [] -> k subst - | [], _ - | _, [] -> () - | l2::l2s', r2::r2s' -> - equate_terms ~subst l2 r2 (fun subst -> equate_lists ~subst l2s' r2s' k) - (* make l2=r2 by a direct application of l1=r1, if possible. This can - enrich [subst] *) - and equate_root ~subst l2 r2 k = - begin try - let subst = Unif.FO.matching_adapt_scope - ~subst ~pattern:(Scoped.make l1 sc1) (Scoped.make l2 sc2) in - let subst = Unif.FO.matching_adapt_scope - ~subst ~pattern:(Scoped.make r1 sc1) (Scoped.make r2 sc2) in - k subst - with Unif.Fail -> () - end; - begin try - let subst = Unif.FO.matching_adapt_scope - ~subst ~pattern:(Scoped.make l1 sc1) (Scoped.make r2 sc2) in - let subst = Unif.FO.matching_adapt_scope - ~subst ~pattern:(Scoped.make r1 sc1) (Scoped.make l2 sc2) in - k subst - with Unif.Fail -> () - end; - () - in - equate_terms ~subst l2 r2 k - -let subsumes ?(subst=Subst.empty) (lit1,sc1) (lit2,sc2) k = - match lit1, lit2 with - | Eq (l1, r1, true), Eq (l2, r2, true) -> - eq_subsumes_ ~subst l1 r1 sc1 l2 r2 sc2 k - | _ -> matching ~subst ~pattern:(lit1,sc1) (lit2,sc2) k - -let subsumes_pred lit1 lit2 : bool = - not (subsumes (lit1,0)(lit2,1) |> Sequence.is_empty) - -let unify ?(subst=Subst.empty) lit1 lit2 k = - let op = Unif_gen.op_unif in - Unif_gen.unif_lits op ~subst lit1 lit2 k - -let map f = function - | Eq (left, right, sign) -> - let new_left = f left - and new_right = f right in - eq ~sign new_left new_right - | Atom (p, sign) -> - let p' = f p in - atom ~sign p' - | Bool b -> bool b - -let apply_subst_ ~f_term subst (lit,sc) = match lit with - | Eq (l,r,sign) -> - let new_l = f_term subst (l,sc) in - let new_r = f_term subst (r,sc) in - eq ~sign new_l new_r - | Atom (p, sign) -> - let p' = f_term subst (p,sc) in - atom ~sign p' - | Bool _ -> lit - -let apply_subst ~renaming subst (lit,sc) = - apply_subst_ subst (lit,sc) - ~f_term:(S.FO.apply ~renaming) - -let apply_subst_no_renaming subst (lit,sc) = - apply_subst_ subst (lit,sc) - ~f_term:S.FO.apply_no_renaming - -let apply_subst_no_simp ~renaming subst (lit,sc) = match lit with - | Eq (l,r,sign) -> - Eq ( - S.FO.apply ~renaming subst (l,sc), - S.FO.apply ~renaming subst (r,sc), - sign) - | Atom (p, sign) -> - Atom (S.FO.apply ~renaming subst (p,sc), sign) - | Bool _ -> lit - -let variant_arr ?(subst=S.empty) (lits1,sc1)(lits2,sc2): S.t Sequence.t = - Unif.unif_array_com subst - (IArray.to_array_unsafe lits1,sc1) - (IArray.to_array_unsafe lits2,sc2) - ~op:(fun subst x y -> variant ~subst x y) - -let apply_subst_arr ~renaming subst (lits,sc): t IArray.t = - IArray.map (fun lit -> apply_subst ~renaming subst (lit,sc)) lits - -let apply_subst_arr_no_renaming subst (lits,sc): t IArray.t = - IArray.map (fun lit -> apply_subst_no_renaming subst (lit,sc)) lits diff --git a/src/hornet/Lit.mli b/src/hornet/Lit.mli deleted file mode 100644 index bfbc01752..000000000 --- a/src/hornet/Lit.mli +++ /dev/null @@ -1,174 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Literal} *) - -(** Literals occurring in clauses *) - -open Logtk - -type ty = Type.t -type term = Term.t - -type t = Hornet_types.lit = - | Bool of bool - | Atom of term * bool - | Eq of term * term * bool - -type lit = t - -val true_ : t -val false_: t -val bool : bool -> t -val atom : ?sign:bool -> term -> t -val eq : ?sign:bool -> term -> term -> t - -val sign : t -> bool -val is_pos : t -> bool (** alias to {!sign} *) -val is_neg : t -> bool - -val neg : t -> t -(** negate literal *) - -val map : (term -> term) -> t -> t -(** functor *) - -include Interfaces.EQ with type t := t -include Interfaces.HASH with type t := t -include Interfaces.ORD with type t := t -include Interfaces.PRINT with type t := t - -(** {2 Helpers} *) - -val terms : t -> term Sequence.t -val vars_seq : t -> ty HVar.t Sequence.t -val vars_list : t -> ty HVar.t list -val vars_set : t -> ty HVar.t list (** unique *) - -val is_ground : t -> bool - -val weight : t -> int -val depth : t -> int - -val var_occurs : var:ty HVar.t -> t -> bool - -val hash_mod_alpha : t -> int - -val is_trivial : t -> bool -val is_absurd : t -> bool - -val to_slit : t -> term SLiteral.t - -(** {2 Containers} *) - -module Set : CCSet.S with type elt = t -module Tbl : CCHashtbl.S with type key = t - -(** {2 Positions} *) - -module With_pos : sig - type t = lit Position.With.t - - include Interfaces.PRINT with type t := t - include Interfaces.ORD with type t := t -end - -val direction : Ordering.t -> t -> Comparison.t option - -val at_pos_exn : Position.t -> t -> term -(** Get the term at the given pos - @raise Not_found if the position is not valid or if it - empty (would return the lit itself) *) - -val active_terms : ?pos:Position.t -> Ordering.t -> t -> term Position.With.t Sequence.t -(** Terms in active position for paramodulation/resolution *) - -val passive_terms : ?pos:Position.t -> Ordering.t -> t -> term Position.With.t Sequence.t -(** Terms in passive position for paramodulation/resolution *) - -val seq_terms : t -> term Sequence.t - -module Pos : sig - val at : t -> Position.t -> term - (** retrieve subterm at pos - @raise Invalid_argument if the position is invalid *) - - val replace : t -> at:Position.t -> by:term -> t - (** [replace t ~at:pos ~by] replaces the subterm at position [pos] - in [t] by the term [by]. The two terms should have the same type. - @raise Invalid_argument if the position is not valid *) -end - -val get_eqn : t -> Position.t -> (term * term * bool) option -(** View of a Atom or Eq literal, oriented by the position. If the - position selects its left term, return l, r, otherwise r, l. - for propositions it will always be p, true. - @return None for other literals - @raise Invalid_argument if the position doesn't match the literal. *) - -val get_eqn_exn : t -> Position.t -> term * term * bool -(** Same as {!get_eqn}, but - @raise Error if the literal is not equational *) - -(** {2 Unification and Matching} *) - -val variant : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t - -val are_variant : t -> t -> bool - -val subsumes : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t - -val subsumes_pred : t -> t -> bool - -val unify : - ?subst:Subst.t -> - t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t - -val matching : - ?subst:Subst.t -> - pattern:t Scoped.t -> - t Scoped.t -> - Subst.t Sequence.t - -val apply_subst : - renaming:Subst.Renaming.t -> - Subst.t -> - t Scoped.t -> - t - -val apply_subst_no_renaming : Subst.t -> t Scoped.t -> t - -val apply_subst_no_simp : - renaming:Subst.Renaming.t -> - Subst.t -> - t Scoped.t -> - t - -(** {2 Arrays of Lits} *) - -val variant_arr : - ?subst:Subst.t -> - t IArray.t Scoped.t -> - t IArray.t Scoped.t -> - Subst.t Sequence.t - -val apply_subst_arr : - renaming:Subst.Renaming.t -> - Subst.t -> - t IArray.t Scoped.t -> - t IArray.t - -val apply_subst_arr_no_renaming : - Subst.t -> - t IArray.t Scoped.t -> - t IArray.t diff --git a/src/hornet/Proof.ml b/src/hornet/Proof.ml deleted file mode 100644 index 7d438db07..000000000 --- a/src/hornet/Proof.ml +++ /dev/null @@ -1,142 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 CProofs} *) - -open Logtk -open Hornet_types - -module U = Hornet_types_util -module Stmt = Statement -module Fmt = CCFormat - -type t = proof -type formula = TypedSTerm.t - -let trivial = P_trivial -let instance c subst = P_instance (c,subst) -let avatar_split c = P_avatar_split c -let split c sel constr = P_split (c,sel,constr) -let avatar_cut c l = P_avatar_cut (c,l) - -let bool_tauto = P_bool_tauto -let bool_res a c1 p1 c2 p2 = - let s = { - bool_res_atom=a; - bool_res_c1=c1; - bool_res_p1=p1; - bool_res_c2=c2; - bool_res_p2=p2; - } in - P_bool_res s - -let bool_grounding c = P_bool_grounding c - -let hc_sup x = P_hc_superposition x -let hc_eq_res c proof = P_hc_eq_res (c,proof) -let hc_simplify c = P_hc_simplify c -let hc_demod c c_l = P_hc_demod (c,c_l) - -let pp = Hornet_types_util.pp_proof -let to_string = Fmt.to_string pp - -let name (p:t): string = match p with - | P_trivial -> "trivial" - | P_from_input _ -> "from_input" - | P_from_file _ -> "from_file" - | P_cnf_neg _ -> "cnf_neg" - | P_cnf _ -> "cnf" - | P_renaming _ -> "renaming" - | P_preprocess _ -> "preprocess" - | P_bool_tauto -> "bool_tauto" - | P_avatar_split _ -> "avatar_split" - | P_avatar_cut _ -> "avatar_cut" - | P_split _ -> "split" - | P_instance (_,subst) -> Fmt.sprintf "instance(@[%a@])" Subst.pp subst - | P_bool_res r -> Fmt.sprintf "bool_res(%a)" U.pp_bool_lit r.bool_res_atom - | P_bool_grounding _ -> "grounding" - | P_hc_superposition _ -> "hc_sup" - | P_hc_eq_res _ -> "hc_eq_res" - | P_hc_simplify _ -> "hc_simpl" - | P_hc_demod _ -> "hc_demod" - -let parents_of_hc (c:horn_clause) = c.hc_proof, PR_horn_clause c - -let parents (p:t): proof_with_res list = match p with - | P_trivial - | P_bool_tauto - | P_from_file _ - | P_from_input _ - -> [] - | P_cnf_neg r - | P_cnf r -> [r] - | P_preprocess (r, _) -> [r] - | P_renaming (r, id, form) -> - let def = - trivial, PR_formula (TypedSTerm.(Form.eq (const id ~ty:Ty.prop) form)) - in - [r; def] - | P_avatar_split c - | P_split (c,_,_) - | P_instance (c,_) -> [c.c_proof, PR_clause c] - | P_avatar_cut (c,l) -> - parents_of_hc c :: (List.map (fun (lit,p) -> p, PR_bool_clause [lit]) l) - | P_bool_res r -> - [ r.bool_res_p1, PR_bool_clause r.bool_res_c1; - r.bool_res_p2, PR_bool_clause r.bool_res_c2; - ] - | P_bool_grounding c -> [c.c_proof, PR_clause c] - | P_hc_eq_res (c,_) -> [ parents_of_hc c ] - | P_hc_superposition r -> - let c1, _ = r.hc_sup_active in - let c2, _ = r.hc_sup_passive in - [ parents_of_hc c1; parents_of_hc c2 ] - | P_hc_simplify c -> [ parents_of_hc c ] - | P_hc_demod (c,c_l) -> - parents_of_hc c :: List.rev_map parents_of_hc c_l - -let get ?(compress=true) (p:t): string * proof_with_res list = - let rec aux p = match p with - | P_hc_simplify c when compress -> aux c.hc_proof - | _ -> name p, parents p - in aux p - -module Src_tbl = CCHashtbl.Make(struct - type t = Stmt.source - let equal = Stmt.Src.equal - let hash = Stmt.Src.hash - end) - -(* used to share the same clauses in the proof *) -let input_proof_tbl_ : t Src_tbl.t = Src_tbl.create 32 - -let rec proof_of_stmt src : t = - try Src_tbl.find input_proof_tbl_ src - with Not_found -> - let p = match Stmt.Src.view src with - | Stmt.Input (_, r) -> P_from_input r - | Stmt.From_file (f, r) -> P_from_file (f,r) - | Stmt.Internal _ -> trivial - | Stmt.Neg srcd -> P_cnf_neg (proof_of_sourced srcd) - | Stmt.CNF srcd -> P_cnf (proof_of_sourced srcd) - | Stmt.Preprocess (srcd,str) -> P_preprocess (proof_of_sourced srcd, str) - | Stmt.Renaming (srcd, id, form) -> - P_renaming (proof_of_sourced srcd, id, form) - in - Src_tbl.add input_proof_tbl_ src p; - p - -and proof_of_sourced (x:Stmt.sourced_t) : proof_with_res = - let module F = TypedSTerm.Form in - let r, src = x in - let p = proof_of_stmt src in - let res = match r with - | Stmt.Sourced_input f -> PR_formula f - | Stmt.Sourced_statement _ - | Stmt.Sourced_clause _ -> assert false (* TODO: how? dep cycles… *) - in - p, res - -(* conversion from statement *) -let from_stmt (st:(_,_,_)Stmt.t): t = proof_of_stmt (Stmt.src st) - diff --git a/src/hornet/Proof.mli b/src/hornet/Proof.mli deleted file mode 100644 index ea4c865a5..000000000 --- a/src/hornet/Proof.mli +++ /dev/null @@ -1,42 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Proofs} *) - -(** Each clause, Horn clause, etc. contains its own proof, - that is, a derivation from axioms through instanciations/resolution/… *) - -open Logtk -open Hornet_types - -type t = proof - -val trivial : t -val from_stmt : Statement.clause_t -> t -val instance : clause -> Subst.t -> t -val avatar_split : clause -> t -val split : clause -> select_lit -> c_constraint -> t -val avatar_cut : horn_clause -> (bool_lit * proof) list -> t - -val bool_tauto : t -val bool_res : bool_lit -> bool_clause -> t -> bool_clause -> t -> t -val bool_grounding : clause -> t - -val hc_sup : Hornet_types.hc_superposition_step -> t -val hc_eq_res : horn_clause -> Subst.t -> t -val hc_simplify : horn_clause -> t -val hc_demod : horn_clause -> horn_clause list -> t - -include Interfaces.PRINT with type t := t - -val name : t -> string -(** Name of the rule, no other info *) - -val parents : t -> proof_with_res list -(** Immediate parents of this proof step, i.e. the subproofs it uses *) - -val get : ?compress:bool -> t -> string * proof_with_res list -(** Get name and parent - @param compress if true, skip some uninteresting steps *) - - diff --git a/src/hornet/Proof_print.ml b/src/hornet/Proof_print.ml deleted file mode 100644 index 56992d9e3..000000000 --- a/src/hornet/Proof_print.ml +++ /dev/null @@ -1,103 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Print Proofs} *) - -open Logtk -open Hornet_types - -module HC = Horn_clause -module P_res = Proof_res -module U = Hornet_types_util -module Fmt = CCFormat -module Stmt = Statement - -type t = proof_with_res - -(* traverse recursively, with a table to preserve DAG *) -let pp_dag out (p:t): unit = - let tbl : int P_res.Tbl.t = P_res.Tbl.create 32 in - let count = ref 0 in - (* recursive traversal. Returns the unique ID of this step *) - let rec aux (x:t): int = - let p, res = x in - begin match P_res.Tbl.get tbl res with - | Some id -> id - | None -> - let id = CCRef.incr_then_get count in - P_res.Tbl.add tbl res id; - (* print parents, get their ID *) - let l = - Proof.parents p |> List.map aux - in - Format.fprintf out "@[@[@{* [%d]@} %a@]@ :from %a@ :dep %a@]@," - id Proof_res.pp res U.pp_proof p Fmt.Dump.(list int) l; - id - end - in - let aux' _ () = ignore (aux p) in - Format.fprintf out "@[%a@]" aux' () - -let get_proof (x:proof_with_res): proof = fst x -let get_res (x:proof_with_res): proof_res = snd x - -let as_graph ?compress : (t,string) CCGraph.t = - CCGraph.make - (fun (p,_) -> - let name, parents = Proof.get ?compress p in - Sequence.of_list parents - |> Sequence.map (fun p' -> name, p')) - -let is_proof_of_false p = Proof_res.is_absurd (get_res p) - -let is_goal p = match get_proof p with - | P_from_file (_,Stmt.R_goal) - | P_from_input Stmt.R_goal -> true - | _ -> false - -let is_assert p = match get_proof p with - | P_from_file (_,(Stmt.R_assert | Stmt.R_def)) - | P_from_input (Stmt.R_assert | Stmt.R_def) -> true - | _ -> false - -let is_bool_clause p = match get_res p with - | PR_bool_clause _ -> true - | PR_clause _ | PR_horn_clause _ | PR_formula _ -> false - -let is_trivial p = match get_proof p with - | P_trivial | P_bool_tauto -> true - | _ -> false - -let pp_dot ?compress out (p:t) : unit = - let equal = CCFun.compose_binop get_res Proof_res.equal in - let hash = CCFun.compose get_res Proof_res.hash in - let pp_node (p:t) = Proof_res.to_string (get_res p) in - (* how to display a node *) - let attrs_v p = - let label = pp_node p in - let attrs = [`Label label; `Style "filled"; `Shape "box"] in - if is_proof_of_false p then `Color "red" ::attrs - (* else if has_absurd_lits p then `Color "orange" :: attrs *) - else if is_assert p then `Color "yellow" :: attrs - else if is_goal p then `Color "green" :: attrs - else if is_trivial p then `Color "cyan" :: attrs - else if is_bool_clause p then `Color "orange" :: attrs - else attrs - in - let attrs_e s = [`Label s; `Other ("dir", "back")] in - CCGraph.Dot.pp - ~tbl:(CCGraph.mk_table ~eq:equal ~hash 32) - ~eq:equal - ~attrs_v - ~attrs_e - ~name:"proof" - ~graph:(as_graph ?compress) - out p - -let pp_dot_file ?compress file p = - CCIO.with_out file - (fun oc -> - let out = Format.formatter_of_out_channel oc in - pp_dot ?compress out p; - Format.pp_print_flush out (); - flush oc) diff --git a/src/hornet/Proof_print.mli b/src/hornet/Proof_print.mli deleted file mode 100644 index b7beed521..000000000 --- a/src/hornet/Proof_print.mli +++ /dev/null @@ -1,20 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Print Proofs} *) - -open Hornet_types - -type t = proof_with_res - -val pp_dag : t CCFormat.printer -(** Print the proof as text *) - -val pp_dot : ?compress:bool -> t CCFormat.printer -(** Print proof in DOT format - @param compress if true, show compressed proof *) - -val pp_dot_file : ?compress:bool -> string -> t -> unit -(** [pp_dot_file file p] writes the proof [p] into the given file, - in DOT format - @param compress if true, show compressed proof *) diff --git a/src/hornet/Proof_res.ml b/src/hornet/Proof_res.ml deleted file mode 100644 index d83ed103c..000000000 --- a/src/hornet/Proof_res.ml +++ /dev/null @@ -1,53 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Proof Result} *) - -(** The various results of a proof *) - -open Logtk -open Hornet_types - -module Fmt = CCFormat -module HC = Horn_clause - -type t = Hornet_types.proof_res - -let equal (a:t)(b:t): bool = match a, b with - | PR_horn_clause hc1, PR_horn_clause hc2 -> HC.equal hc1 hc2 - | PR_clause c1, PR_clause c2 -> Clause.equal c1 c2 - | PR_bool_clause c1, PR_bool_clause c2 -> Bool_lit.equal_clause c1 c2 - | PR_formula f1, PR_formula f2 -> TypedSTerm.equal f1 f2 - | PR_horn_clause _, _ - | PR_clause _, _ - | PR_bool_clause _, _ - | PR_formula _, _ - -> false - -let hash (a:t): int = match a with - | PR_horn_clause c -> Hash.combine2 10 (HC.hash c) - | PR_clause c -> Hash.combine2 20 (Clause.hash c) - | PR_bool_clause c -> Hash.combine2 30 (Bool_lit.hash_clause c) - | PR_formula f -> Hash.combine2 40 (TypedSTerm.hash f) - -let pp out (a:t): unit = match a with - | PR_horn_clause c -> HC.pp out c - | PR_clause c -> Clause.pp out c - | PR_bool_clause c -> Bool_lit.pp_clause out c - | PR_formula f -> TypedSTerm.pp out f - -let to_string = Fmt.to_string pp - -let is_absurd = function - | PR_horn_clause hc -> HC.is_absurd hc && H_trail.is_empty (HC.trail hc) - | PR_clause c -> IArray.length (Clause.lits c) = 0 - | PR_bool_clause [] -> true - | PR_bool_clause _ -> false - | PR_formula f -> TypedSTerm.equal f TypedSTerm.Form.false_ - -module As_key = struct - type t = proof_res - let equal = equal - let hash = hash -end -module Tbl = CCHashtbl.Make(As_key) diff --git a/src/hornet/Proof_res.mli b/src/hornet/Proof_res.mli deleted file mode 100644 index e1999aea1..000000000 --- a/src/hornet/Proof_res.mli +++ /dev/null @@ -1,15 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Proof Result} *) - -(** The various results of a proof *) - -type t = Hornet_types.proof_res - -include Interfaces.HASH with type t := t -include Interfaces.PRINT with type t := t - -val is_absurd : t -> bool - -module Tbl : CCHashtbl.S with type key = t diff --git a/src/hornet/Splitting.ml b/src/hornet/Splitting.ml deleted file mode 100644 index 1d816cc67..000000000 --- a/src/hornet/Splitting.ml +++ /dev/null @@ -1,417 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Avatar + Inst-Gen-Eq} *) - -open Logtk -open Hornet_types - -module T = Term -module C = Clause - -let section = Util.Section.make "splitting" - -let stat_conflict = Util.mk_stat "hornet.split_conflict" -let stat_instantiate = Util.mk_stat "hornet.split_instantiate" - -module Make(Ctx : State.CONTEXT) = struct - module Ctx = Ctx - - let name = "splitting" - - (* table of all clauses so far *) - let clause_set : unit C.Tbl_mod_alpha.t = C.Tbl_mod_alpha.create 256 - - (** {2 Avatar Splitting} *) - - (** Clauses that contain several "components" are split immediately. - A clause [C] is splittable if it contains subsets of literals - [C_1 \lor … \lor C_n] where each [C_i] - is a component. - A component [C_i] is a non-empty subset of the literals of the clause, - that shares no variables with the other [C_j | j≠i] *) - - module Avatar : sig - val split : C.t -> C.t list option - end = struct - let stat_avatar_split = Util.mk_stat "hornet.avatar_split" - - (* for a component [¬p], add [[¬p] => ¬[p]] to SAT *) - let add_neg_lit_complement (b:bool_lit): unit = - begin match Bool_lit.view b with - | A_box_clause r -> - let c = r.bool_box_clause in - if C.is_unit_ground c && - Lit.is_neg (IArray.get (C.lits c) 0) && - Constraint.is_trivial (C.constr c) - then ( - let lit' = Lit.neg (IArray.get (C.lits c) 0) in - let c' = - C.make_l [lit'] Proof.trivial - ~constr:(C.constr c) ~depth:(C.depth c) ~trail:(C.trail c) - in - let b' = Bool_lit.box_clause Ctx.bool_state c' in - let b_c = [Bool_lit.neg b; Bool_lit.neg b'] in - Ctx.add_clause Proof.bool_tauto b_c; - ) - | _ -> () - end - - (* union-find that maps vars to list of literals, used for splitting *) - module UF = UnionFind.Make(struct - type key = T.var - type value = Lit.Set.t - let equal = HVar.equal Type.equal - let hash = HVar.hash - let zero = Lit.Set.empty - let merge = Lit.Set.union - end) - - (* main Avatar splitting function *) - let try_split_ lits c : C.t list option = - assert (IArray.length lits >= 2); - (* ground literals (each one is its own component) *) - let cluster_ground = ref [] in - (* maps each variable to a list of literals. Sets can be merged whenever - two variables occur in the same literal. *) - let uf_vars = - IArray.to_seq lits - |> Sequence.flat_map Lit.vars_seq - |> T.VarSet.of_seq - |> T.VarSet.to_list - |> UF.create - in - (* literals belong to either their own ground component, or to every - sets in [uf_vars] associated to their variables *) - IArray.iter - (fun lit -> - let v_opt = Lit.vars_seq lit |> Sequence.head in - begin match v_opt with - | None -> (* ground, lit has its own component *) - cluster_ground := lit :: !cluster_ground - | Some v -> - (* merge other variables of the literal with [v] *) - Lit.vars_seq lit - |> Sequence.iter - (fun v' -> - UF.add uf_vars v' (Lit.Set.singleton lit); (* lit is in the equiv class of [v'] *) - UF.union uf_vars v v') - end) - lits; - - (* now gather all the components as a literal list list *) - let components = ref [] in - List.iter (fun lit -> components := Lit.Set.singleton lit :: !components) !cluster_ground; - UF.iter uf_vars (fun _ comp -> components := comp :: !components); - - begin match !components with - | [] -> assert (IArray.length lits=0); None - | [_] -> None - | _::_ -> - (* do a simplification by splitting [c]! *) - Util.incr_stat stat_avatar_split; - let proof = Proof.avatar_split c in - let bool_lits, clauses = - !components - |> List.map - (fun lits -> - let lits = Lit.Set.to_list lits in - let rec sub_clause = lazy ( - C.make_l lits proof - ~constr:(C.constr c) ~depth:(C.depth c) ~trail:[b_lit] - ) - and b_lit = - lazy (Bool_lit.box_clause Ctx.bool_state (Lazy.force sub_clause)) - in - Lazy.force b_lit, Lazy.force sub_clause) - |> List.split - in - Util.debugf ~section 2 "@[<2>@{avatar.split@}@ %a@]" (fun k->k C.pp c); - Util.debugf ~section 4 - "@[avatar_split@ :clause @[%a@]@ :yields (@[%a@])@ @[:trail %a@]@]" - (fun k->k C.pp c (Util.pp_list C.pp) clauses Bool_lit.pp_trail (C.trail c)); - (* add boolean constraint: trail(c) => bigor_{name in clauses} name *) - (* guard for the boolean clause *) - let guard = - C.trail c - |> List.map (fun (lazy blit) -> Bool_lit.neg blit) - in - (* also add boolean constraint to pick ≥ 1 components *) - let bool_clause = guard @ bool_lits in - Ctx.add_clause proof bool_clause; - (* shortcut: for [¬p], add clause [[¬p] ⇒ ¬[¬p]] *) - List.iter add_neg_lit_complement bool_lits; - Util.debugf ~section 4 "@[<2>constraint clause is@ @[%a@]@]" - (fun k->k Bool_lit.pp_clause bool_clause); - (* return the clauses *) - Some clauses - end - - let split c : C.t list option = match C.proof c with - | _ when IArray.length (C.lits c) <= 1 -> None - | P_avatar_split _ | P_split _ -> None (* by construction, impossible *) - | _ -> try_split_ (C.lits c) c - end - - (** {2 Inst-Gen-Eq} *) - - module Inst_gen_eq : sig - val grounding : C.t -> unit - (** Instantiate the given non-horn clause with grounding subst, - so as to select its literals depending on the current ground - interpretation *) - - val assert_ground : bool_ground -> unit - (** Called when the given boolean ground literal is true. - This will select some FO literals in clauses whose instance contain - the bool ground literal *) - end = struct - let stat_grounding = Util.mk_stat "hornet.grounding" - - (* ground the literals of [c] *) - let ground_lits (c:clause): bool_lit IArray.t = - let subst = - C.vars_l c - |> List.map - (fun v -> - let t = T.grounding (HVar.ty v) in - ((v:>InnerTerm.t HVar.t),0), ((t:>InnerTerm.t),0)) - |> Subst.of_list - in - let renaming = Subst.Renaming.createed () in - let lits = - C.lits c - |> IArray.mapi - (fun i lit -> - (* ground [lit] using the substitution *) - let lit' = Lit.apply_subst ~renaming subst (lit,0) in - assert (Lit.is_ground lit'); - let b_lit = Bool_lit.ground Ctx.bool_state lit' in - (* register [c] in each ground literal *) - begin match Bool_lit.view b_lit with - | A_ground r -> - r.bool_ground_instance_of <- (c,i) :: r.bool_ground_instance_of; - | _ -> assert false - end; - b_lit) - in - lits - - let grounding (c:C.t): unit = - begin match C.grounding c with - | None -> - Util.incr_stat stat_grounding; - let b_clause = ground_lits c in - C.set_grounding c b_clause; - let b_clause = IArray.to_list b_clause in - Util.debugf ~section 3 - "@[<2>@{inst_gen_eq.grounding@}@ %a@ :grounding %a@]" - (fun k->k C.pp c Bool_lit.pp_clause b_clause); - Ctx.add_clause (Proof.bool_grounding c) b_clause; - () - | Some _ -> () - end - - let try_select (c:clause)(i:clause_idx)(_:bool_ground): unit = - begin match C.select c with - | Some _ -> () - | None -> - (* select the literal of [c] whose instance is [r.bool_ground_lit] *) - let sel = { - select_lit=IArray.get (C.lits c) i; - select_idx=i; - select_depends=[]; - } in - C.set_select c sel; - (* be sure to remove the selection afterwards *) - Ctx.on_backtrack - (fun () -> - C.clear_select c; - Util.debugf ~section 3 - "@[<2>@{unselect_lit@} `%a`@ :clause %a@]" - (fun k->k Lit.pp sel.select_lit C.pp c); - Ctx.send_event (E_unselect_lit (c,sel))); - (* select lit *) - Util.debugf ~section 3 "@[<2>@{select_lit@} `%a`@ :clause %a@]" - (fun k->k Lit.pp sel.select_lit C.pp c); - Ctx.send_event (E_select_lit (c,sel,C.constr c)); - end - - (* when a boolean literal is asserted, try to select it - in every clause whose instance it belongs to *) - let assert_ground (r:bool_ground): unit = - Util.debugf ~section 5 "(@[assert_ground@ %a@])" (fun k->k Lit.pp r.bool_ground_lit); - List.iter - (fun (c,i) -> try_select c i r) - r.bool_ground_instance_of - end - - (** {2 Non-Horn Clauses} *) - - let initial_clauses : C.t list = - CCVector.to_seq Ctx.statements - |> Sequence.flat_map Statement.Seq.forms - |> Sequence.to_rev_list - - (* split a clause into Avatar components, then normally. - If the clause is already present in {!clause_set}, do nothing *) - let rec split_clause (c:C.t): unit = - if not (C.Tbl_mod_alpha.mem clause_set c) then ( - C.Tbl_mod_alpha.add clause_set c (); - begin match C.classify c with - | C.Horn _ -> () - | C.General -> - (* first, try Avatar splitting *) - begin match Avatar.split c with - | Some l -> List.iter split_clause l (* recurse *) - | None when C.is_ground c -> - assert (C.is_unit_ground c); (* otherwise, avatar would have split *) - () - | None -> Inst_gen_eq.grounding c - end - end - ) - - let split_initial_clauses () = - List.iter split_clause initial_clauses - - let on_assumption (lit:Bool_lit.t): unit = - begin match Bool_lit.view lit, Bool_lit.sign lit with - | A_box_clause r, true -> - Ctx.on_backtrack - (fun () -> Ctx.send_event (E_remove_component r)); - Ctx.send_event (E_add_component r) - | A_box_clause _, false -> () - | A_ground r, true -> - (* maybe select some FO literals in reaction *) - Ctx.on_backtrack - (fun () -> Ctx.send_event (E_remove_ground_lit r)); - Inst_gen_eq.assert_ground r; - Ctx.send_event (E_add_ground_lit r); - | A_ground _, false -> () - | A_fresh _, _ - -> () - end - - let new_instances_q : C.t Queue.t = Queue.create() - - let flush_new_clauses () = - while not (Queue.is_empty new_instances_q) do - let c = Queue.pop new_instances_q in - split_clause c; - done - - (* what to do if a conflict is detected *) - let on_conflict (trail:H_trail.t) (label:Label.t) (proof:Proof.t): unit = - let non_trivial_instantiations = - Label.to_seq label - |> Sequence.filter (fun lc -> not (Labelled_clause.is_empty lc)) - |> Sequence.to_rev_list - in - Util.incr_stat stat_conflict; - if CCList.is_empty non_trivial_instantiations then ( - (* all instances are trivial (same clause), we can trigger - conflict in SAT using a conflict clause that combines - the trail and the label *) - let neg_trail = - H_trail.bool_lits trail - |> Bool_lit.Tbl.of_seq_count - |> Bool_lit.Tbl.keys - |> Sequence.map Bool_lit.neg - |> Sequence.to_rev_list - and neg_ground_lits = - Label.to_list label - |> List.map - (fun lc -> - assert (Labelled_clause.is_empty lc); - let sel = lc.lc_sel in - let idx = sel.select_idx in - let b_lit = IArray.get (C.grounding_exn lc.lc_clause) idx in - Bool_lit.neg b_lit) - in - let conflict = List.rev_append neg_trail neg_ground_lits in - Util.debugf ~section 2 - "(@[conflict@ :trail %a@ :label %a@ :conflict %a@])" - (fun k->k H_trail.pp trail Label.pp label Bool_lit.pp_clause conflict); - Ctx.add_clause proof conflict - ) else ( - (* at least one labelled clause needs instantiation, so we don't - have a conflict here. The real conflict with come from the instance. *) - Util.debugf ~section 2 - "(@[conflict->instantiate@ :trail %a@ :label %a@ :instances (@[%a@])@])" - (fun k->k H_trail.pp trail Label.pp label - (Util.pp_list Labelled_clause.pp) non_trivial_instantiations); - let clauses_to_instantiate, new_instances = - Sequence.of_list non_trivial_instantiations - |> Sequence.map - (fun lc -> - let c = lc.lc_clause in - let subst = Labelled_clause.to_subst lc in - assert (not (Subst.is_renaming subst)); - (* apply substitution to create a new instance *) - let renaming = Subst.Renaming.createed () in - let lits' = - C.lits c - |> IArray.map (fun lit -> Lit.apply_subst ~renaming subst (lit,0)) - and constr' = - Constraint.apply_subst ~renaming subst (C.constr c,0) - in - let c' = - C.make lits' (Proof.instance c subst) - ~constr:constr' ~trail:H_trail.empty ~depth:(C.depth c+1) - in - Util.incr_stat stat_instantiate; - (* block this instance from [c] *) - let new_constr = Labelled_clause.to_dismatch lc in - assert (not (Dismatching_constr.is_trivial new_constr)); - C.add_dismatch_constr c new_constr; - Util.debugf ~section 2 - "(@[@{inst_gen_eq.instantiate@}@ :clause %a@ \ - :subst %a@ :new_dismatch %a@ :all_constr %a@])" - (fun k->k C.pp c Subst.pp subst - Dismatching_constr.pp new_constr Constraint.pp (C.constr c)); - (* be ready to remove and re-add c, and to add c' *) - (c, lc.lc_sel), c') - |> Sequence.to_rev_list - |> List.split - in - let clauses_to_instantiate = - CCList.sort_uniq - clauses_to_instantiate - ~cmp:(CCOrd.pair C.compare - (CCFun.compose_binop (fun sel->sel.select_idx) CCOrd.int)) - in - (* these clauses have new constraints, remove then re-add them *) - List.iter - (fun (c,sel) -> Ctx.send_event (E_unselect_lit (c, sel))) - clauses_to_instantiate; - List.iter - (fun (c,sel) -> - assert (sel.select_depends=[]); - Ctx.send_event (E_select_lit (c, sel, C.constr c))) - clauses_to_instantiate; - List.iter - (fun new_c -> Queue.push new_c new_instances_q) - new_instances; - ) - - let set_depth_limit _ = () - - let on_event (e:event) = - begin match e with - | E_add_component _ | E_remove_component _ - | E_add_ground_lit _ | E_remove_ground_lit _ - | E_select_lit _ | E_unselect_lit _ -> () (* come from here *) - | E_conflict (trail,label,proof) -> on_conflict trail label proof - | E_if_sat -> flush_new_clauses () - | E_found_unsat _ -> () - | E_stage s -> - begin match s with - | Stage_start -> split_initial_clauses () - | _ -> () - end - end -end - -let theory = (module Make : State.THEORY_FUN) - diff --git a/src/hornet/Splitting.mli b/src/hornet/Splitting.mli deleted file mode 100644 index 45b27ff37..000000000 --- a/src/hornet/Splitting.mli +++ /dev/null @@ -1,10 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Avatar + Inst-Gen-Eq} *) - -(** Splitting on non-Horn clauses. *) - -module Make : State.THEORY_FUN - -val theory : State.theory_fun diff --git a/src/hornet/State.ml b/src/hornet/State.ml deleted file mode 100644 index ef6008fe6..000000000 --- a/src/hornet/State.ml +++ /dev/null @@ -1,283 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 State} *) - -open Logtk -open Hornet_types - -module SI = Msat.Solver_intf -module TI = Msat.Theory_intf - -module Fmt = CCFormat - -let section = Util.Section.(make ~parent:root) "state" - -type term = Term.t -type ty = Type.t -type statement = (Clause.t, term, ty) Statement.t - -(** {2 Context for Theories} *) - -module type CONTEXT = State_intf.CONTEXT - -type context = (module CONTEXT) - -(** {2 Theory} *) - -module type THEORY = State_intf.THEORY -module type THEORY_FUN = State_intf.THEORY_FUN - -type theory_fun = State_intf.theory_fun - -(** {2 State in a Module} *) - -module type S = sig - module M : SI.S with type St.formula = Bool_lit.t and type St.proof = proof - module Ctx : CONTEXT (* for theories *) - val rebuild_proof : M.Proof.proof -> proof_with_res - val theories : (module THEORY) list - val pp_dimacs: unit -> unit -end - -module type ARGS = State_intf.ARGS - -(** Mapping between proofs and tags *) -module Proof_tbl : sig - val tag_of_proof : proof -> int - val proof_of_tag : int -> proof -end = struct - let tbl : (int,proof) Hashtbl.t = Hashtbl.create 128 - let count = ref 0 - let tag_of_proof (p:proof): int = - let n = CCRef.incr_then_get count in - Hashtbl.add tbl n p; - n - let proof_of_tag i: proof = Hashtbl.find tbl i -end - -(* bool_clause -> 'a *) -module Bool_clause_tbl = CCHashtbl.Make(struct - type t = bool_clause - let equal = CCList.equal Bool_lit.equal - let hash = Hash.list Bool_lit.hash - end) - -module Make(A : ARGS) : S = struct - (* defined below *) - let send_event_ : (event -> unit) ref = ref (fun _ -> assert false) - - module SAT_theory = struct - type formula = Bool_lit.t - type proof = Hornet_types.proof - - let backtrack_vec : (unit -> unit) CCVector.vector = CCVector.create () - - let on_assumption_ : (Bool_lit.t -> unit) list ref = ref [] - - type level = int (* offset in [backtrack] *) - - let dummy = 0 - - let current_level () = CCVector.length backtrack_vec - - let backtrack lev = - Util.debugf ~section 2 "@[<2>@{backtrack to level %d@}@]" (fun k->k lev); - while CCVector.length backtrack_vec > lev do - let f = CCVector.pop_exn backtrack_vec in - f() - done - - let assume slice : _ TI.res = - for i = slice.TI.start to slice.TI.start + slice.TI.length - 1 do - let lit = slice.TI.get i in - List.iter (fun f -> f lit) !on_assumption_ - done; - TI.Sat - - let if_sat _ = - !send_event_ E_if_sat; - TI.Sat - end - - module M = - Msat.Solver.Make - (Bool_lit) - (SAT_theory) - (struct end) - - (* convert the SAT proof into a normal proof *) - let rebuild_proof (p:M.Proof.proof) : proof_with_res = - let module Pr = M.Proof in - (* map bool_clause -> its proof *) - let tbl : proof Bool_clause_tbl.t = Bool_clause_tbl.create 64 in - let bool_clause_of_sat c : bool_clause = - Pr.to_list c |> List.map (fun a -> a.M.St.lit) - in - let rec aux p : proof * bool_clause = match Pr.expand p with - | { Pr.step = Pr.Lemma lemma; conclusion=c } -> - let c = bool_clause_of_sat c in - lemma, c - | { Pr.conclusion=c; step = Pr.Resolution (p1,p2,{M.St.lit;_}) } -> - let c = bool_clause_of_sat c in - (* atomic resolution step *) - begin match Bool_clause_tbl.get tbl c with - | Some pr -> pr, c - | None -> - let p1, c1 = aux p1 in - let p2, c2 = aux p2 in - let proof = Proof.bool_res lit c1 p1 c2 p2 in - Bool_clause_tbl.add tbl c proof; - proof, c - end - | _ -> assert false (* TODO *) - in - Pr.check p; - let proof, c = aux p in - proof, PR_bool_clause c - - module Ctx : CONTEXT = struct - include A - module Bool_lit = Bool_lit - - type bool_clause = Bool_lit.t list - let bool_state = Bool_lit.create_state () - let on_backtrack f = CCVector.push SAT_theory.backtrack_vec f - let add_clause_l proof l = - let tag = Proof_tbl.tag_of_proof proof in - let l = List.rev_map (CCList.sort_uniq ~cmp:Bool_lit.compare) l in - Util.debugf ~section 2 "@[<2>add_bool_clauses@ (@[%a@])@]" - (fun k->k (Util.pp_list Bool_lit.pp_clause) l); - M.assume ~tag l - let add_clause p c = add_clause_l p [c] - let valuation_at_level0 lit = - if M.true_at_level0 lit then Some true - else if M.true_at_level0 (Bool_lit.neg lit) then Some false - else None - let proof_of_lit lit = - let a = M.St.add_atom lit in - begin match M.Proof.prove_atom a with - | Some p -> fst(rebuild_proof p) - | None -> assert false - end - module Form = struct - include Msat.Tseitin.Make(struct - include Bool_lit - let fresh () = fresh bool_state (* need to pass context implicitely here *) - end) - let imply = make_imply - let and_ = make_and - let or_ = make_or - let not_ = make_not - let atom = make_atom - end - let add_form p f = add_clause_l p (Form.make_cnf f) - let send_event e = !send_event_ e - - let renaming_ = Subst.Renaming.create() - let renaming_cleared () = - Subst.Renaming.clear renaming_; - renaming_ - end - - let add_on_assumption_ f = - SAT_theory.on_assumption_ := f :: !SAT_theory.on_assumption_ - - let theories : (module THEORY) list = - List.map - (fun (module Th_fun : THEORY_FUN) -> - let module Th = Th_fun(Ctx) in - Util.debugf ~section 2 "@[add_theory %s@]" (fun k->k Th.name); - add_on_assumption_ Th.on_assumption; - (module Th : THEORY)) - A.theories - - let () = - (* process one single event, possibly triggering other events *) - let process_one_event e = - Util.debugf ~section 5 "@[process_event@ %a@]" (fun k->k Event.pp e); - try - List.iter (fun (module Th : THEORY) -> Th.on_event e) theories - with exc -> - let trace = Util.Exn.string_of_backtrace () in - Util.debugf ~section 1 "@[<2>error when processing event@ %a@ :msg %s@]" - (fun k->k Event.pp e trace); - raise exc - in - send_event_ := process_one_event; - () - - (* print SAT problem *) - let pp_dimacs () = - CCOpt.iter - (fun file -> - Util.debugf ~section 1 "(@[export_dimacs@ %S@])" (fun k->k file); - CCIO.with_out file - (fun oc -> - let out = Format.formatter_of_out_channel oc in - M.export_dimacs out (); - Format.pp_print_flush out ())) - A.dimacs_file -end - -(** {2 State} *) - -type signature = Type.t ID.Map.t - -type t = (module S) - -let create (module A:ARGS) = - let module M = Make(A) in - let st = (module M : S) in - st - -let context (t:t) = - let module M = (val t) in - (module M.Ctx : CONTEXT) - -(** {2 Result} *) - -type res = - | Sat - | Unsat of proof_with_res - | Unknown - -let pp_res out = function - | Sat -> Fmt.string out "SAT" - | Unsat _ -> Fmt.string out "UNSAT" - | Unknown -> Fmt.string out "UNKNOWN" - -let run (t:t): res = - let module St = (val t) in - let module F = St.Ctx.Form in - St.Ctx.send_event Hornet_types.(E_stage Stage_init); - St.Ctx.send_event Hornet_types.(E_stage Stage_presaturate); - St.Ctx.send_event Hornet_types.(E_stage Stage_start); - (* currently at depth [d] *) - let rec iter (d:int) = - Util.debugf ~section 1 "@[<2>@{#### DEPTH %d ####@}@]" (fun k->k d); - (* set depth limit *) - List.iter - (fun (module Th : THEORY) -> Th.set_depth_limit d) - St.theories; - (* solve under assumption [limit] *) - let res = St.M.solve ~assumptions:[] () in - begin match res with - | St.M.Sat _ -> - if d = St.Ctx.max_depth - then Unknown (* TODO: completeness proof(!); also, ask theories if complete *) - else iter (d+1) (* increase depth *) - | St.M.Unsat us -> - Util.debugf ~section 1 "@[Found unsat@]" (fun k->k); - let p = St.rebuild_proof (us.SI.get_proof ()) in - St.Ctx.send_event (Hornet_types.E_found_unsat p); - Unsat p - end - in - (* compute result *) - let res = iter 1 in - St.Ctx.send_event Hornet_types.(E_stage Stage_exit); - St.pp_dimacs(); - res - - diff --git a/src/hornet/State.mli b/src/hornet/State.mli deleted file mode 100644 index 60039e109..000000000 --- a/src/hornet/State.mli +++ /dev/null @@ -1,53 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 State} *) - -(** The global state of a proof attempt *) - -open Logtk -open Hornet_types - -type term = Term.t -type ty = Type.t -type statement = (Clause.t, term, ty) Statement.t - -(** {2 Context for Theories} *) - -(** Each theory is given this context, which serves to communicate - with the SAT solver *) - -module type CONTEXT = State_intf.CONTEXT - -type context = (module CONTEXT) - -(** {2 Theory} *) - -module type THEORY = State_intf.THEORY -module type THEORY_FUN = State_intf.THEORY_FUN - -type theory_fun = State_intf.theory_fun - -(** {2 State} *) - -type t - -module type ARGS = State_intf.ARGS - -val create : (module ARGS) -> t - -val context : t -> context - -(** {2 Result} *) - -type res = - | Sat - | Unsat of proof_with_res - | Unknown - -val pp_res : res CCFormat.printer - -val run : t -> res -(** Main loop. It calls the SAT solver which takes care of - (trying to) find a model *) - diff --git a/src/hornet/State_intf.ml b/src/hornet/State_intf.ml deleted file mode 100644 index 69ed17fb7..000000000 --- a/src/hornet/State_intf.ml +++ /dev/null @@ -1,100 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -open Logtk - -type term = Term.t -type ty = Type.t -type statement = (Clause.t, term, ty) Statement.t -type proof = Hornet_types.proof -type event = Hornet_types.event - -module type CTX_ARGS = sig - val ord : Ordering.t - val signature : Type.t ID.Map.t - val conf : Flex_state.t - val statements : statement CCVector.ro_vector - val max_depth : int - val saturation_steps : int - val compress_proof : bool - val dimacs_file : string option -end - -module type CONTEXT = sig - type bool_clause = Bool_lit.t list - - val bool_state : Bool_lit.state - - (** {6 SAT} *) - - val on_backtrack : (unit -> unit) -> unit - (** Push the given callback on a stack. It will be - called when the SAT solver backtracks. *) - - val add_clause : proof -> bool_clause -> unit - val add_clause_l : proof -> bool_clause list -> unit - val valuation_at_level0 : Bool_lit.t -> bool option - val proof_of_lit : Bool_lit.t -> proof (** Only if true at level 0 *) - - module Form : sig - type t - val imply : t -> t -> t - val atom : Bool_lit.t -> t - val and_ : t list -> t - val or_: t list -> t - val not_ : t -> t - end - - val add_form : proof -> Form.t -> unit - (** Add boolean form to the SAT solver *) - - val send_event : event -> unit - (** Send an event to notify other parts of the prover *) - - (** {6 FO} *) - - val renaming_cleared: unit -> Subst.Renaming.t - (** A global renaming, reset every time this is called *) - - (** {6 Config} *) - - include CTX_ARGS -end - -(** A reasoning engine. Each theory is informed when the SAT solver - makes some decisions, and when it backtracks. - In return, theories can exploit their domain-specific knowledge - to propagate new (boolean) clauses to the SAT solver, - and to detect unsatisfiability by adding a conflict clause. - - Theories can communicate via boolean literals. - - Initially a theory is a function that takes a context, - and returns some callback that will be called when the solver - makes decisions *) - -module type THEORY = sig - module Ctx : CONTEXT - - val name : string - - val on_assumption : Bool_lit.t -> unit - (** Called every time the SAT solver picks a new boolean literal *) - - val on_event : event -> unit - (** React to events *) - - val set_depth_limit : int -> unit - (** Called when the depth limit is changed *) -end - -module type THEORY_FUN = functor(C:CONTEXT) -> THEORY with module Ctx = C - -type theory_fun = (module THEORY_FUN) - -(** Parameters to create a Context *) -module type ARGS = sig - include CTX_ARGS - val theories : theory_fun list -end - diff --git a/src/hornet/hornet.ml b/src/hornet/hornet.ml deleted file mode 100644 index 7e089d539..000000000 --- a/src/hornet/hornet.ml +++ /dev/null @@ -1,194 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Horn Superposition + Splitting} *) - -open Logtk -open Logtk_parsers -module E = CCResult -open E.Infix -module Fmt = CCFormat - -let section = Util.Section.(make ~parent:root "hornet") - -let start_ k = Util.debugf ~section 1 k - -let parse_file file = - Util.debugf ~section 1 "@[@{### process file@ `%s` ###@}@]" - (fun k->k file); - let input = Parsing_utils.input_of_file file in - Parsing_utils.parse_file input file - -type conf = Flex_state.t - -let k_def_as_rewrite : bool Flex_state.key = Flex_state.create_key() - -let typing conf stmts : (_ Statement.t CCVector.ro_vector * Type.t ID.Map.t, string) E.t = - start_ "start typing" (fun k->k); - let def_as_rewrite = - Flex_state.get_or ~or_:false k_def_as_rewrite conf - in - TypeInference.infer_statements ~def_as_rewrite ?ctx:None stmts >|= fun stmts -> - (* compute signature *) - let signature = - let conv = Type.Conv.create () in - CCVector.to_seq stmts - |> Sequence.flat_map Statement.Seq.ty_decls - |> Sequence.map (CCPair.map2 (Type.Conv.of_simple_term_exn conv)) - |> ID.Map.of_seq - in - Util.debugf ~section 2 "@[signature {@ %a@,}@]" - (fun k->k - Fmt.(seq (hbox (Dump.pair ID.pp Type.pp))) - (ID.Map.to_seq signature)); - Util.debugf ~section 2 "@[typed statements {@ %a@,}@]" - (fun k-> - let module T = TypedSTerm in - k (Util.pp_seq ~sep:" " (Statement.pp T.pp T.pp T.pp)) (CCVector.to_seq stmts)); - stmts, signature - -(* obtain clauses *) -let cnf ~file decls = - let stmts = - decls - |> CCVector.to_seq - |> Sequence.map (Statement.add_src ~file) - |> Cnf.cnf_of_seq - |> CCVector.to_seq - |> Cnf.convert - in - Util.debugf ~section 2 "@[CNF {@ %a@,}@]" - (fun k-> k (Util.pp_seq ~sep:" " Cnf.pp_fo_c_statement) - (CCVector.to_seq stmts)); - E.return stmts - -(* TODO: make defined symbols smaller, skolems bigger *) - -(* compute a precedence *) -let compute_prec stmts = - let cp = - Compute_prec.empty - - (* add constraint about inductive constructors, etc. *) - |> Compute_prec.add_constr 10 Classify_cst.prec_constr - - (* use "invfreq", with low priority *) - |> Compute_prec.add_constr_rule 90 - (fun seq -> - seq - |> Sequence.flat_map Statement.Seq.terms - |> Sequence.flat_map Term.Seq.symbols - |> Precedence.Constr.invfreq) - in - let prec = Compute_prec.mk_precedence cp stmts in - Util.debugf ~section 2 "@[<2>precedence: %a@]" (fun k->k Precedence.pp prec); - E.return prec - -let compute_ord (ord:string) precedence = - let ord = Ordering.by_name ord precedence in - Util.debugf ~section 2 "@[<2>ord: %a@]" (fun k->k Ordering.pp ord); - E.return ord - -(* setup an alarm for abrupt stop *) -let setup_alarm timeout = - let handler _ = - Format.printf "%% SZS status ResourceOut@."; - Unix.kill (Unix.getpid ()) Sys.sigterm - in - ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle handler)); - ignore (Unix.alarm (max 1 (int_of_float timeout))) - -let setup_gc () = - let gc = Gc.get () in - Gc.set { gc with Gc.space_overhead=150; } - -(** {2 Main} *) - -let time : float ref = ref 0. -let file : string ref = ref "" -let def_as_rewrite : bool ref = ref false -let max_depth : int ref = ref 6 -let saturation_steps : int ref = ref 256 -let ord_ : string ref = ref Ordering.default_name -let dot_file_ : string ref = ref "" -let dimacs_file_ : string ref = ref "" -let compress_proof_ : bool ref = ref true - -let options = - Arg.align - ([ "--time", Arg.Set_float time, " set timeout"; - "-t", Arg.Set_float time, " alias to --time"; - "--ord", Arg.Symbol (Ordering.names(), (:=) ord_), " pick term ordering"; - "--def-as-rewrite", Arg.Set def_as_rewrite, " definitions as rewrite rules"; - "--no-def-as-rewrite", Arg.Clear def_as_rewrite, " definitions as axioms"; - "--max-depth", Arg.Set_int max_depth, (Fmt.sprintf " maximum depth (default %d)" !max_depth); - "--saturation-steps", Arg.Set_int saturation_steps, " saturation steps at every decision"; - "--dot", Arg.Set_string dot_file_, " print proof to in DOT" ; - "--dimacs", Arg.Set_string dimacs_file_, " print SAT problem in dimacs into " ; - "--compress", Arg.Set compress_proof_, " compress proof"; - "--no-compress", Arg.Clear compress_proof_, " do not compress proof"; - ] @ Options.make ()) - -let main () = - Arg.parse options (fun s->file := s) "usage: hornet "; - setup_alarm !time; - setup_gc (); - let conf = - Flex_state.empty - |> Flex_state.add k_def_as_rewrite !def_as_rewrite - in - parse_file !file >>= - typing conf >>= fun (stmts, signature) -> - cnf ~file:!file stmts >>= fun stmts -> - compute_prec (CCVector.to_seq stmts) >>= - compute_ord !ord_ >>= fun ord -> - (* convert statements in {!Clause.t} *) - let stmts = - CCVector.map - (fun stmt -> - Statement.map stmt ~form:(Clause.of_slit_l ~stmt) ~term:CCFun.id ~ty:CCFun.id) - stmts - in - let st = - let module A = struct - let ord = ord - let signature = signature - let conf = conf - let statements = stmts - let max_depth = !max_depth - let saturation_steps = !saturation_steps - let dimacs_file = if !dimacs_file_ =""then None else Some !dimacs_file_ - let compress_proof = !compress_proof_ - let theories = [ - Horn_superposition.theory; - Splitting.theory; - ] - end - in - State.create (module A) - in - let res = State.run st in - Format.printf "%a@." State.pp_res res; - begin match res with - | State.Sat | State.Unknown -> () - | State.Unsat p -> - Format.printf "@[proof:@ %a@]@." Proof_print.pp_dag p; - (* print into DOT *) - if !dot_file_ <> "" then ( - Proof_print.pp_dot_file ~compress:!compress_proof_ !dot_file_ p; - ); - end; - E.return () (* done *) - -let () = - CCFormat.set_color_default true; - at_exit - (fun () -> - if !Options.stats then Util.print_global_stats (); - Util.debugf ~section 1 "run time: %.3f" (fun k->k (Util.total_time_s ()))); - begin match main () with - | E.Error msg -> - print_endline msg; - exit 1 - | E.Ok () -> () - end diff --git a/src/main/jbuild b/src/main/jbuild new file mode 100644 index 000000000..b866576d2 --- /dev/null +++ b/src/main/jbuild @@ -0,0 +1,14 @@ +; vim:ft=lisp: + +(jbuild_version 1) + +; main binary +(executable + ((name zipperposition) + (package zipperposition) + (public_name zipperposition) + (libraries (logtk libzipperposition.phases)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -color always + -unbox-closures -unbox-closures-factor 20)) + )) diff --git a/src/main/zipperposition.ml b/src/main/zipperposition.ml index 0bf188b18..e0b4ce7e4 100644 --- a/src/main/zipperposition.ml +++ b/src/main/zipperposition.ml @@ -7,30 +7,23 @@ passed as arguments on the command line. *) open Logtk -open Libzipperposition +open Libzipperposition_phases -let section = Const.section +let section = Libzipperposition.Const.section -let phases = - let open Phases.Infix in - Phases_impl.setup_gc >>= fun () -> - Phases_impl.setup_signal >>= fun () -> - Phases_impl.parse_cli >>= fun (files, params) -> - Phases_impl.load_extensions >>= fun _ -> - Phases_impl.process_files_and_print params files >>= fun errcode -> - Phases.exit >|= fun () -> - errcode +let phases = Phases_impl.main_cli ~setup_gc:true () let () = - match Phases.run phases with + begin match Phases.run phases with | CCResult.Error msg -> print_endline msg; exit 1 | CCResult.Ok (_, 0) -> () | CCResult.Ok (_, errcode) -> exit errcode (* failure *) + end let _ = at_exit (fun () -> Util.debugf ~section 1 "run time: %.3f" (fun k->k (Util.total_time_s ())); - Signal.send Signals.on_exit 0) + Signal.send Libzipperposition.Signals.on_exit 0) diff --git a/src/meta/libzipperposition_meta.mldylib b/src/meta/libzipperposition_meta.mldylib deleted file mode 100644 index 4d262073b..000000000 --- a/src/meta/libzipperposition_meta.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: d54a8436130673fc29afa7618a2df069) -Libzipperposition_meta -# OASIS_STOP diff --git a/src/meta/libzipperposition_meta.mllib b/src/meta/libzipperposition_meta.mllib deleted file mode 100644 index 4d262073b..000000000 --- a/src/meta/libzipperposition_meta.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: d54a8436130673fc29afa7618a2df069) -Libzipperposition_meta -# OASIS_STOP diff --git a/src/meta/libzipperposition_meta.mlpack b/src/meta/libzipperposition_meta.mlpack deleted file mode 100644 index 0d29d0449..000000000 --- a/src/meta/libzipperposition_meta.mlpack +++ /dev/null @@ -1,7 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: cd72bca5f4332701d3c049f6387ecf24) -Encoding -Reasoner -Plugin -Prover -# OASIS_STOP diff --git a/src/parsers/lex_dk.mll b/src/parsers/Lex_dk.mll similarity index 100% rename from src/parsers/lex_dk.mll rename to src/parsers/Lex_dk.mll diff --git a/src/parsers/lex_tptp.mll b/src/parsers/Lex_tptp.mll similarity index 100% rename from src/parsers/lex_tptp.mll rename to src/parsers/Lex_tptp.mll diff --git a/src/parsers/lex_zf.mll b/src/parsers/Lex_zf.mll similarity index 100% rename from src/parsers/lex_zf.mll rename to src/parsers/Lex_zf.mll diff --git a/src/parsers/parse_dk.mly b/src/parsers/Parse_dk.mly similarity index 100% rename from src/parsers/parse_dk.mly rename to src/parsers/Parse_dk.mly diff --git a/src/parsers/parse_tptp.mly b/src/parsers/Parse_tptp.mly similarity index 99% rename from src/parsers/parse_tptp.mly rename to src/parsers/Parse_tptp.mly index 29f2b4578..2b32a8bab 100644 --- a/src/parsers/parse_tptp.mly +++ b/src/parsers/Parse_tptp.mly @@ -130,7 +130,7 @@ declaration: | INCLUDE LEFT_PAREN x=SINGLE_QUOTED RIGHT_PAREN DOT { A.Include (remove_quotes x) } | INCLUDE LEFT_PAREN x=SINGLE_QUOTED COMMA names=name_list RIGHT_PAREN DOT - { A.IncludeOnly (x, names) } + { A.IncludeOnly (remove_quotes x, names) } | error { let loc = L.mk_pos $startpos $endpos in @@ -445,7 +445,7 @@ variable: } atomic_word: - | s=SINGLE_QUOTED { s } + | s=SINGLE_QUOTED { remove_quotes s } | s=LOWER_WORD { s } atomic_defined_word: diff --git a/src/parsers/parse_zf.mly b/src/parsers/Parse_zf.mly similarity index 100% rename from src/parsers/parse_zf.mly rename to src/parsers/Parse_zf.mly diff --git a/src/parsers/Tip_ast.ml b/src/parsers/Tip_ast.ml index 7eca83963..e38eb3757 100644 --- a/src/parsers/Tip_ast.ml +++ b/src/parsers/Tip_ast.ml @@ -150,13 +150,13 @@ let fpf = Format.fprintf let pp_list ?(start="") ?(stop="") ?(sep=" ") pp out l = let rec pp_list l = match l with - | x::((_::_) as l) -> - pp out x; - Format.pp_print_string out sep; - Format.pp_print_cut out (); - pp_list l - | x::[] -> pp out x - | [] -> () + | x::((_::_) as l) -> + pp out x; + Format.pp_print_string out sep; + Format.pp_print_cut out (); + pp_list l + | x::[] -> pp out x + | [] -> () in Format.pp_print_string out start; pp_list l; diff --git a/src/parsers/jbuild b/src/parsers/jbuild new file mode 100644 index 000000000..72597cd1e --- /dev/null +++ b/src/parsers/jbuild @@ -0,0 +1,26 @@ +; vim:ft=lisp: + +(jbuild_version 1) + +; main lib +(library + ((name logtk_parsers) + (public_name logtk.parsers) + (synopsis "parsers for logtk") + (optional) + (libraries (containers logtk)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -Oclassic)) + )) + +(menhir + (;(flags (--infer)) + (modules (Parse_tptp Parse_zf Parse_dk Tip_parser)))) + +(ocamllex + (Lex_tptp Lex_zf Lex_dk Tip_lexer)) + +;(ocamllex (Lex_tptp)) +;(ocamllex (Lex_zf)) +;(ocamllex (Lex_dk)) +;(ocamllex (Tip_lexer)) diff --git a/src/parsers/libzipperposition_parsers.mldylib b/src/parsers/libzipperposition_parsers.mldylib deleted file mode 100644 index d8fd113ad..000000000 --- a/src/parsers/libzipperposition_parsers.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: fe83efda6541f6ffed93a5045b521550) -Libzipperposition_parsers -# OASIS_STOP diff --git a/src/parsers/libzipperposition_parsers.mllib b/src/parsers/libzipperposition_parsers.mllib deleted file mode 100644 index d8fd113ad..000000000 --- a/src/parsers/libzipperposition_parsers.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: fe83efda6541f6ffed93a5045b521550) -Libzipperposition_parsers -# OASIS_STOP diff --git a/src/parsers/libzipperposition_parsers.mlpack b/src/parsers/libzipperposition_parsers.mlpack deleted file mode 100644 index c8374c8f9..000000000 --- a/src/parsers/libzipperposition_parsers.mlpack +++ /dev/null @@ -1,16 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: b3c1e32a5b7640dd9f45e51c07d6fbd0) -Parse_tptp -Lex_tptp -Ast_tptp -Util_tptp -Ast_ho -Lex_ho -Parse_ho -Trace_tstp -Parse_zf -Lex_zf -Util_zf -Parsing_utils -CallProver -# OASIS_STOP diff --git a/src/parsers/logtk_parsers.mld b/src/parsers/logtk_parsers.mld new file mode 100644 index 000000000..b888260ef --- /dev/null +++ b/src/parsers/logtk_parsers.mld @@ -0,0 +1,5 @@ + +Parsers for diverse input formats, using menhir. + +{!modules: Logtk_parsers} + diff --git a/src/parsers/logtk_parsers.mldylib b/src/parsers/logtk_parsers.mldylib deleted file mode 100644 index 6a517cd41..000000000 --- a/src/parsers/logtk_parsers.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: c753d3d96a67896889605ff526cbebad) -Logtk_parsers -# OASIS_STOP diff --git a/src/parsers/logtk_parsers.mllib b/src/parsers/logtk_parsers.mllib deleted file mode 100644 index 6a517cd41..000000000 --- a/src/parsers/logtk_parsers.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: c753d3d96a67896889605ff526cbebad) -Logtk_parsers -# OASIS_STOP diff --git a/src/parsers/logtk_parsers.mlpack b/src/parsers/logtk_parsers.mlpack deleted file mode 100644 index ddcc3b1bb..000000000 --- a/src/parsers/logtk_parsers.mlpack +++ /dev/null @@ -1,21 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 22a576cd1fdaeca6fbf5101a1f4ffd13) -Parse_tptp -Lex_tptp -Ast_tptp -Util_tptp -Trace_tstp -Parse_zf -Lex_zf -Util_zf -Util_tip -Tip_ast -Tip_parser -Tip_lexer -Util_dk -Parse_dk -Lex_dk -Ast_dk -Parsing_utils -CallProver -# OASIS_STOP diff --git a/src/parsers/util_tptp.ml b/src/parsers/util_tptp.ml index 9e8e5c3eb..467c841ff 100644 --- a/src/parsers/util_tptp.ml +++ b/src/parsers/util_tptp.ml @@ -138,7 +138,8 @@ let parse_file ?cache ~recursive f = ) | (A.Include _ | A.IncludeOnly _), _ -> Queue.push decl result_decls) - decls + decls; + close_in input with e -> close_in input; raise e diff --git a/src/proofs/LLProof.ml b/src/proofs/LLProof.ml index 02e6dae75..7e596b776 100644 --- a/src/proofs/LLProof.ml +++ b/src/proofs/LLProof.ml @@ -19,10 +19,16 @@ type tag = Proof.tag type name = string +type check_res = + | R_ok + | R_fail + | R_skip + type t = { id: int; (* unique ID *) concl: form; step: step; + mutable checked: check_res option; (* caching result of checking *) } and step = | Goal @@ -147,7 +153,7 @@ let pp_dag out (p:t): unit = let mk_ : form -> step -> t = let n = ref 0 in fun concl step -> - { id=CCRef.incr_then_get n; concl; step } + { id=CCRef.incr_then_get n; concl; step; checked=None; } let goal f = mk_ f Goal let negated_goal f p = mk_ f (Negated_goal p) @@ -165,6 +171,14 @@ let inference ~intros ~local_intros ~tags f name ps : t = mk_ f (Inference {name;intros;local_intros;parents=ps;tags}) +let get_check_res t = t.checked +let set_check_res t r = t.checked <- Some r + +let pp_check_res out = function + | R_ok -> Fmt.string out "ok" + | R_fail -> Fmt.string out "fail" + | R_skip -> Fmt.string out "skip" + module Dot = struct (** Get a graph of the proof *) let as_graph : (t, string * inst) CCGraph.t = @@ -206,7 +220,7 @@ module Dot = struct | Assert, _ -> Some "yellow" | Trivial, _ -> Some "gold" | (By_def _ | Define _), _ -> Some "navajowhite" - | _ -> None + | _ -> Some "grey" end let pp_dot_seq ~name out seq = @@ -216,11 +230,17 @@ module Dot = struct ~name ~graph:as_graph ~attrs_v:(fun p -> - let label = _to_str_escape "@[<2>%a@]@." T.pp (concl p) in + let top, b_color = match get_check_res p with + | None -> "[no-check]", [] + | Some R_ok -> "[check ✔]", [`Color "green"; `Other ("penwidth", "6")] + | Some R_fail -> "[check ×]", [`Color "red"; `Other ("penwidth", "8")] + | Some R_skip -> "[check ø]", [`Color "yellow"] + in + let label = _to_str_escape "@[%s@,@[<2>%a@]@]@." top T.pp (concl p) in let attrs = [`Label label; `Style "filled"] in let shape = `Shape "box" in - let color = match color p with None -> [] | Some c -> [`Color c] in - shape :: color @ attrs + let color = match color p with None -> [] | Some c -> [`Other ("fillcolor", c)] in + shape :: color @ b_color @ attrs ) ~attrs_e:(fun (r,inst) -> let label = _to_str_escape "@[%s%a@]@." r pp_inst_some inst in diff --git a/src/proofs/LLProof.mli b/src/proofs/LLProof.mli index ed65f649e..a38b5960b 100644 --- a/src/proofs/LLProof.mli +++ b/src/proofs/LLProof.mli @@ -93,6 +93,22 @@ val inference : tags:tag list -> form -> name -> parent list -> t + +(** {2 Checking steps} *) + +type check_res = + | R_ok + | R_fail + | R_skip + +val get_check_res : t -> check_res option + +val set_check_res : t -> check_res -> unit + +val pp_check_res : check_res CCFormat.printer + +(** {2 Printing} *) + module Tbl : CCHashtbl.S with type key = t module Dot : sig diff --git a/src/proofs/LLProof_check.ml b/src/proofs/LLProof_check.ml index 14f8d4d5a..ac9d39bfd 100644 --- a/src/proofs/LLProof_check.ml +++ b/src/proofs/LLProof_check.ml @@ -32,7 +32,6 @@ type stats = { let section = LLProof.section let prof_check = Util.mk_profiler "llproof.check.step" let stat_check = Util.mk_stat "llproof.check.step" -let stat_tab_solve = Util.mk_stat "llproof.check.tab_solve" let pp_res out = function | R_ok -> Fmt.fprintf out "@{OK@}" @@ -52,308 +51,6 @@ let () = Printexc.register_printer | Error msg -> Some (Util.err_spf "llproof_check: %s" msg) | _ -> None) -(** {2 Tableau Prover} *) - -(** A simple tableau prover for discharging every proof obligation. - It does not do instantiation (we assume every inference step is - preceded by relevant instantiations) but can handle renamings. -*) - -module Tab : sig - val can_check : LLProof.tag list -> bool - (** Is this set of tags accepted by the tableau prover? *) - - val prove : form list -> form -> res - (** [prove a b] returns [R_ok] if [a => b] is a tautology. *) -end = struct - module T = LLTerm - module F = LLTerm.Form - - (** Congruence Closure *) - module CC = Congruence.Make(struct - include T - - let subterms t = match T.view t with - | T.App (f, a) -> [f;a] - | T.Arrow (a,b) -> [a;b] - | T.AppBuiltin (Builtin.Box_opaque, _) -> [] (* simple equality *) - | T.AppBuiltin (_,l) -> l - | T.Ite (a,b,c) -> [a;b;c] - | T.Bind {body;_} -> [body] - | T.Const _ | T.Var _ | T.Type - -> [] - - let update_subterms t l = match T.view t, l with - | T.App (_, _), [f;a] -> T.app f a - | T.Arrow (_, _), [a;b] -> T.arrow a b - | T.AppBuiltin (b, l1), l1' when List.length l1 = List.length l1' -> - T.app_builtin ~ty:(T.ty_exn t) b l1' - | T.Bind {binder;ty_var;_}, [body] -> - T.bind ~ty:(T.ty_exn t) binder ~ty_var body - | (T.Const _ | T.Var _), [] -> t - | T.Ite (_,_,_), [a;b;c] -> T.ite a b c - | T.App _, _ - | T.Arrow _, _ - | T.AppBuiltin _, _ - | T.Bind _, _ - | T.Const _, _ - | T.Var _, _ - | T.Type, _ - | T.Ite _, _ - -> assert false - end) - - (** Branches of the tableau. A branch is a conjunction of formulas - plus some theory context (congruence closure). - A branch is closed if it's inconsistent *) - module Branch : sig - type t - - val make : T.t list -> t - - val closed : t -> bool - - val add : t -> T.t list -> t - (** add the given set of formulas *) - - val pop_open : t -> (T.t * t) option - (** remove and return next formula to expand *) - - val debug : t Fmt.printer - end = struct - module T_set = T.Set - - type t = { - expanded: T_set.t; - to_expand : T_set.t; - cc: CC.t; - diseq: (T.t * T.t) list; (* negative constraints *) - closed: bool; - } - - (* make a new empty branch *) - let empty () = { - expanded=T_set.empty; - to_expand=T_set.empty; - cc=CC.create(); - diseq=[(F.true_, F.false_)]; - closed=false; - } - - (* check if some diseq is true *) - let check_closed (b:t) : t = - if b.closed then b - else ( - let closed = List.exists (fun (t,u) -> CC.is_eq b.cc t u) b.diseq in - if closed then {b with closed} else b - ) - - let[@inline] add_cc_ t b = { b with cc=CC.add b.cc t } - let[@inline] add_cc_eq t u b = { b with cc=CC.mk_eq b.cc t u } - let[@inline] add_diseq_ t u b = { b with diseq=(t,u)::b.diseq } - - let[@inline] add_expanded f b = {b with expanded = T_set.add f b.expanded} - let[@inline] add_eq t u b : t = b |> add_expanded (F.eq t u) |> add_cc_eq t u |> check_closed - let[@inline] add_diseq t u b : t = b |> add_diseq_ t u |> check_closed - let[@inline] add_to_expand f b = {b with to_expand = T_set.add f b.to_expand} - - let[@inline] add_form_to_expand f b = - b |> add_to_expand f |> check_closed - - let rec is_atomic f = match F.view f with - | F.Eq _ | F.Neq _ | F.Atom _ -> true - | F.Not u -> is_atomic u - | _ -> false - - (* add one formula to [b] *) - let add1 (br:t) (f:T.t): t = - let br = add_cc_ f br in - begin match F.view f with - | F.Atom t -> add_eq t F.true_ br - | F.True -> br - | F.False -> add_eq F.true_ F.false_ br - | F.Eq (t,u) -> add_eq t u br - | F.Neq (t,u) -> add_diseq t u br - | F.Not f' -> - begin match F.view f' with - | F.Eq _ | F.Neq _ | F.Not _ -> assert false - | F.True -> add_diseq F.true_ F.false_ br - | F.False -> br - | F.Atom t -> add_eq t F.false_ br - | F.And l -> add_form_to_expand (F.or_ (List.map F.not_ l)) br - | F.Or l -> add_form_to_expand (F.and_ (List.map F.not_ l)) br - | F.Imply (a,b) -> add_form_to_expand (F.and_ [a; F.not_ b]) br - | F.Equiv (a,b) -> - add_form_to_expand (F.or_ [F.and_ [a; F.not_ b]; F.and_ [b; F.not_ a]]) br - | F.Xor (a,b) -> - add_form_to_expand (F.and_ [F.or_ [a; F.not_ b]; F.or_ [b; F.not_ a]]) br - | F.Exists {ty_var;body} -> - let f = F.forall ~ty_var (F.not_ body) in - br |> add_expanded f |> add_cc_eq f F.true_ |> check_closed - | F.Forall _ -> - br |> add_expanded f |> add_cc_eq f F.false_ |> check_closed - end - | F.And _ | F.Or _ -> add_form_to_expand f br - | F.Imply (a,b) -> add_form_to_expand (F.or_ [F.not_ a; b]) br - | F.Xor (a,b) -> - add_form_to_expand (F.or_ [F.and_ [a; F.not_ b]; F.and_ [b; F.not_ a]]) br - | F.Equiv (a,b) -> - add_form_to_expand (F.and_ [F.or_ [a; F.not_ b]; F.or_ [b; F.not_ a]]) br - | F.Forall _ -> - br |> add_expanded f |> add_cc_eq f F.true_ |> check_closed - | F.Exists {ty_var;body} -> - let f = F.forall ~ty_var (F.not_ body) in - br |> add_expanded f |> add_cc_eq f F.false_ |> check_closed - end - - let[@inline] add b l = - (* put atomic formulas first *) - let l = - List.sort - (fun a b -> match is_atomic a, is_atomic b with - | true, true | false, false -> 0 - | true, false -> -1 | false, true -> 1) - l - in - List.fold_left add1 b l - - let[@inline] make l = add (empty ()) l - let[@inline] closed b = b.closed - - let pop_open b = - if closed b then None - else begin match T_set.choose b.to_expand with - | f -> - let tail = T_set.remove f b.to_expand in - Some (f, {b with to_expand=tail; expanded=T_set.add f b.expanded}) - | exception Not_found -> None - end - - let debug out (b:t) : unit = - Fmt.fprintf out - "(@[branch (closed %B)@ \ - :to_expand (@[%a@])@ :expanded (@[%a@])@])" - b.closed - (Util.pp_seq T.pp) (T_set.to_seq b.to_expand) - (Util.pp_seq T.pp) (T_set.to_seq b.expanded) - end - - (** Rules for the Tableau calculus *) - module Rule : sig - type t - - val apply : t list -> F.t -> F.t list list - (** Return a disjunctive list of conjuctions *) - - val all : t list - end = struct - type t = F.t -> F.t list list - - let or_ f = match F.view f with - | F.Or l -> List.map CCList.return l - | _ -> [] - - let and_ f = match F.view f with - | F.And l -> [l] - | _ -> [] - - let all = [ - or_; - and_; - ] - - let[@inline] apply (l:t list) (f:F.t) : F.t list list = - CCList.flat_map (fun r -> r f) l - end - - type branch = Branch.t - - (** main state *) - type t = { - mutable open_branches: branch list; - mutable closed_branches: branch list; - } - - let debug_tag out (tab:t) : unit = - Fmt.fprintf out "(@[%a@])" - (Util.pp_list Branch.debug) - (List.rev_append tab.open_branches tab.closed_branches) - - exception Saturated_branch of branch - - (* solve tableau by expanding it piece by piece *) - let solve_ (tab:t) : res = - try - while tab.open_branches <> [] do - let b = List.hd tab.open_branches in - tab.open_branches <- List.tl tab.open_branches; - Util.debugf ~section 3 - "(@[llproof.check.tab.solve@ %a@])" - (fun k->k debug_tag tab); - begin match Branch.pop_open b with - | None -> - if Branch.closed b then ( - tab.closed_branches <- b :: tab.closed_branches - ) else ( - (* cannot close this branch *) - raise (Saturated_branch b) - ) - (* saturated *) - | Some (f, b_tail) -> - let new_branches = - Rule.apply Rule.all f - |> List.map - (fun forms -> Branch.add b_tail forms) - in - (* add new branches *) - List.iter - (fun b -> - if Branch.closed b then ( - tab.closed_branches <- b :: tab.closed_branches - ) else ( - tab.open_branches <- b :: tab.open_branches - )) - new_branches - end - done; - (* closed all branches *) - assert (tab.open_branches=[]); - Util.debugf ~section 5 "(@[llproof.check.tab.success@ :branches (@[%a@])@])" - (fun k->k (Util.pp_list Branch.debug) tab.closed_branches); - R_ok - with Saturated_branch b -> - (* found a branch that is not refutable *) - Util.debugf ~section 1 "(@[llproof.check.tab.failed@ :branch %a@])" - (fun k->k Branch.debug b); - R_fail - - let can_check : LLProof.tag list -> bool = - let open Builtin.Tag in - let f = function - | T_ho -> true - | T_lra | T_lia | T_ind | T_data - | T_distinct | T_ac _ | T_ext -> false - in - List.for_all f - - let prove (a:form list) (b:form) = - Util.debugf ~section 3 - "(@[@{llproof.check.tab.prove@}@ :hyps (@[%a@])@ :concl %a@])" - (fun k->k (Util.pp_list TypedSTerm.pp) a TypedSTerm.pp b); - Util.incr_stat stat_tab_solve; - (* convert into {!LLTerm.t} *) - let ctx = T.Conv.create() in - let a = List.map (T.Conv.of_term ctx) a in - let b = T.Conv.of_term ctx b in - (* prove [a ∧ -b ⇒ ⊥] *) - let b_init = Branch.make (F.not_ b :: a) in - let tab = { - open_branches=[b_init]; - closed_branches=[]; - } in - solve_ tab -end - (** {2 Checking Proofs} *) let instantiate (f:form) (inst:LLProof.inst) : form = @@ -392,7 +89,36 @@ let pp_csr out = function | `Other -> "other" | `Trivial -> "trivial" in Fmt.fprintf out "@{SKIP@} (%s)" s -let check_step_ (p:proof): check_step_res = +let conv_res = function + | LLProver.R_ok -> R_ok + | LLProver.R_fail -> R_fail + +let n_proof = ref 0 (* proof counter *) + +let prove ~dot_prefix (a:form list) (b:form) = + let module TT = LLTerm in + (* convert into {!LLTerm.t} *) + let ctx = TT.Conv.create() in + let a = List.map (TT.Conv.of_term ctx) a in + let b = TT.Conv.of_term ctx b in + (* prove [a ∧ -b ⇒ ⊥] *) + let res, final_state = LLProver.prove a b in + Util.debugf ~section 5 "(@[proof-stats@ %a@])"(fun k->k LLProver.pp_stats final_state); + (* print state, maybe *) + begin match dot_prefix with + | None -> () + | Some prefix -> + let p_id = CCRef.incr_then_get n_proof in + let file = Printf.sprintf "%s_%d.dot" prefix p_id in + Util.debugf ~section 2 "print proof %d@ into `%s`" (fun k->k p_id file); + CCIO.with_out file + (fun oc -> + let out = Format.formatter_of_out_channel oc in + Fmt.fprintf out "%a@." LLProver.pp_dot final_state); + end; + conv_res res + +let check_step_ ?dot_prefix (p:proof): check_step_res = let concl = P.concl p in Util.incr_stat stat_check; begin match P.step p with @@ -403,9 +129,9 @@ let check_step_ (p:proof): check_step_res = -> CS_check R_ok | P.Negated_goal p' -> (* [p'] should prove [not concl] *) - CS_check (Tab.prove [P.concl p'] (F.not_ concl)) + CS_check (prove ~dot_prefix [P.concl p'] (F.not_ concl)) | P.Trivial -> CS_skip `Other (* axiom of the theory *) - | P.Instantiate {tags;_} when not (Tab.can_check tags) -> CS_skip `Tags + | P.Instantiate {tags;_} when not (LLProver.can_check tags) -> CS_skip `Tags | P.Instantiate {form=p';inst;_} -> (* re-instantiate and check we get the same thing *) let p'_inst = instantiate (LLProof.concl p') inst in @@ -416,23 +142,24 @@ let check_step_ (p:proof): check_step_res = |> List.mapi (fun i v -> v, T.const ~ty:(Var.ty v) (ID.makef "sk_%d" i)) |> Var.Subst.of_list in - CS_check (Tab.prove [T.Subst.eval subst p'_inst] (T.Subst.eval subst body_concl)) + CS_check (prove ~dot_prefix [T.Subst.eval subst p'_inst] (T.Subst.eval subst body_concl)) | P.Esa (_,_) -> CS_skip `ESA (* TODO *) | P.Inference {parents;tags;intros;_} -> - if Tab.can_check tags then ( + if LLProver.can_check tags then ( (* within the fragment of {!Tab.prove} *) let all_premises = List.map concl_of_parent parents and concl = instantiate concl intros in - CS_check (Tab.prove all_premises concl) + CS_check (prove ~dot_prefix all_premises concl) ) else CS_skip `Tags end -let check_step p = Util.with_prof prof_check check_step_ p +let check_step ?dot_prefix p = Util.with_prof prof_check (check_step_ ?dot_prefix) p let check + ?dot_prefix ?(before_check=fun _ -> ()) ?(on_check=fun _ _ -> ()) (p:proof) : res * stats @@ -448,16 +175,21 @@ let check before_check p; Util.debugf ~section 3 "(@[@{start_checking_proof@}@ %a@])" (fun k->k P.pp p); - let res = check_step p in + let res = check_step ?dot_prefix p in P.Tbl.add tbl p res; Util.debugf ~section 3 "(@[@{done_checking_proof@}@ :of %a@ :res %a@])" (fun k->k P.pp p pp_csr res); on_check p res; begin match res with - | CS_check R_ok -> upd_stats (fun s -> {s with n_ok = s.n_ok+1}) - | CS_check R_fail -> upd_stats (fun s -> {s with n_fail = s.n_fail+1}) + | CS_check R_ok -> + P.set_check_res p P.R_ok; + upd_stats (fun s -> {s with n_ok = s.n_ok+1}) + | CS_check R_fail -> + P.set_check_res p P.R_fail; + upd_stats (fun s -> {s with n_fail = s.n_fail+1}) | CS_skip r -> + P.set_check_res p P.R_skip; upd_stats (fun s -> {s with @@ -473,3 +205,4 @@ let check in check p; if !stats.n_fail = 0 then R_ok, !stats else R_fail, !stats + diff --git a/src/proofs/LLProof_check.mli b/src/proofs/LLProof_check.mli index 86a1668f5..8944aebab 100644 --- a/src/proofs/LLProof_check.mli +++ b/src/proofs/LLProof_check.mli @@ -9,8 +9,6 @@ simple way. *) -open Logtk - type proof = LLProof.t type res = @@ -36,6 +34,7 @@ type check_step_res = | CS_skip of [`ESA | `Other | `Tags | `Trivial] val check : + ?dot_prefix:string -> ?before_check:(proof -> unit) -> ?on_check:(proof -> check_step_res -> unit) -> proof -> diff --git a/src/proofs/LLProver.ml b/src/proofs/LLProver.ml new file mode 100644 index 000000000..ef6650625 --- /dev/null +++ b/src/proofs/LLProver.ml @@ -0,0 +1,429 @@ + +(** {1 Low Level Prover} *) + +open Logtk + +module T = LLTerm +module F = LLTerm.Form +module Fmt = CCFormat + +type form = LLTerm.Form.t + +type res = + | R_ok + | R_fail + +let section = LLProof.section +let stat_solve = Util.mk_stat "llprover.prove" + +(** Congruence Closure *) +module CC = Congruence.Make(struct + include T + let pp = pp_inner + + let subterms t = match T.view t with + | T.App (f, a) -> [f;a] + | T.Arrow (a,b) -> [a;b] + | T.AppBuiltin (Builtin.Box_opaque, _) -> [] (* simple equality *) + | T.AppBuiltin (_,l) -> l + | T.Ite (a,b,c) -> [a;b;c] + | T.Bind {body;_} -> [body] + | Int_pred (l,_) -> T.Linexp_int.subterms l |> Sequence.to_list + | Rat_pred (l,_) -> T.Linexp_rat.subterms l |> Sequence.to_list + | T.Const _ | T.Var _ | T.Type + -> [] + + let update_subterms t l = match T.view t, l with + | T.App (_, _), [f;a] -> T.app f a + | T.Arrow (_, _), [a;b] -> T.arrow a b + | T.AppBuiltin (b, l1), l1' when List.length l1 = List.length l1' -> + T.app_builtin ~ty:(T.ty_exn t) b l1' + | T.Bind {binder;ty_var;_}, [body] -> + T.bind ~ty:(T.ty_exn t) binder ~ty_var body + | (T.Const _ | T.Var _), [] -> t + | T.Ite (_,_,_), [a;b;c] -> T.ite a b c + | Int_pred (le,op), l -> + let l' = T.Linexp_int.subterms le |> Sequence.to_list in + assert (List.length l = List.length l'); + let map = List.combine l' l in + let le' = T.Linexp_int.map (fun t -> CCList.Assoc.get_exn ~eq:T.equal t map) le in + T.int_pred le' op + | Rat_pred (le,op), l -> + let l' = T.Linexp_rat.subterms le |> Sequence.to_list in + assert (List.length l = List.length l'); + let map = List.combine l' l in + let le' = T.Linexp_rat.map (fun t -> CCList.Assoc.get_exn ~eq:T.equal t map) le in + T.rat_pred le' op + | T.App _, _ + | T.Arrow _, _ + | T.AppBuiltin _, _ + | T.Bind _, _ + | T.Const _, _ + | T.Var _, _ + | T.Type, _ + | T.Ite _, _ + -> assert false + end) + +(** Branches of the tableau. A branch is a conjunction of formulas + plus some theory context (congruence closure). + A branch is closed if it's inconsistent *) +module Branch : sig + type t + + val root : unit -> t + + val check_closed : t -> t + val is_closed : t -> bool + + val add : t -> T.t list -> t + (** add the given set of formulas *) + + val pop_to_expand : t -> (T.t * t) option + (** remove and return next formula to expand *) + + type closed = + | C_not_closed + | C_closed_by_diseq of T.t * T.t + | C_closed_by_theory of string + + val to_expand : t -> T.t Sequence.t + val form : t -> F.t option + val closed : t -> closed + val id : t -> int + val parent : t -> t option + val diseq : t -> (T.t * T.t) Sequence.t + + val debug : t CCFormat.printer +end = struct + module T_set = T.Set + + type closed = + | C_not_closed + | C_closed_by_diseq of T.t * T.t + | C_closed_by_theory of string + + type t = { + id: int; (* generative ID *) + form: T.t option; + to_expand : T_set.t; (* all to expand *) + cc: CC.t; + diseq: (T.t * T.t) list; (* negative constraints *) + mutable closed: closed; + parent: t option; + } + + let[@inline] closed t = t.closed + let[@inline] to_expand t = T_set.to_seq t.to_expand + let[@inline] parent t = t.parent + let[@inline] id t = t.id + let[@inline] diseq t = Sequence.of_list t.diseq + let[@inline] form t = t.form + + let root () : t = { + id=0; + form=None; + to_expand=T_set.empty; + cc=CC.create(); + diseq=[(F.true_, F.false_)]; + closed=C_not_closed; + parent=None; + } + + let[@inline] is_closed b : bool = match b.closed with + | C_not_closed -> false + | _ -> true + + let mk_child = + let n = ref 1 in + let aux (f:F.t) (b:t) : t = + { b with id=CCRef.incr_then_get n; form=Some f; parent=Some b } + in + aux + + (* check if some diseq is true *) + let check_closed (b:t) : t = + if is_closed b then b + else ( + begin match CCList.find_pred (fun (t,u) -> CC.is_eq b.cc t u) b.diseq with + | None -> () + | Some (t,u) -> b.closed <- C_closed_by_diseq (t,u) + end; + b + ) + + let[@inline] add_cc_ t b = { b with cc=CC.add b.cc t; } + let[@inline] add_cc_eq t u b = { b with cc=CC.mk_eq b.cc t u } + let[@inline] add_diseq_l_ t u b = { b with diseq=(t,u)::b.diseq } + + let[@inline] add_eq t u b : t = + if is_closed b then b else b |> add_cc_eq t u |> check_closed + let[@inline] add_diseq t u b : t = + if is_closed b then b else b |> add_cc_ t |> add_cc_ u |> add_diseq_l_ t u |> check_closed + let[@inline] add_to_expand f b = + if is_closed b then b else {b with to_expand=T_set.add f b.to_expand} + + let[@inline] add_form_to_expand f b = + b |> add_to_expand f |> check_closed + + let rec is_atomic f = match F.view f with + | F.Eq _ | F.Neq _ | F.Atom _ | F.Int_pred _ | F.Rat_pred _ -> true + | F.Not u -> is_atomic u + | _ -> false + + (* add one formula to [b] *) + let add1_ (br:t) (f:T.t): t = + let br = mk_child f @@ add_cc_ f br in + begin match F.view f with + | F.Atom t -> add_eq t F.true_ br + | F.True -> br + | F.False -> add_eq F.true_ F.false_ br + | F.Eq (t,u) -> add_eq t u br + | F.Neq (t,u) -> add_diseq t u br + | F.Int_pred (_,_) -> add_eq f F.true_ br (* TODO: decision proc *) + | F.Rat_pred (_,_) -> add_eq f F.true_ br (* TODO: simplex *) + | F.Not f' -> + begin match F.view f' with + | F.Eq _ | F.Neq _ | F.Not _ | F.Int_pred _ | F.Rat_pred _ -> assert false + | F.True -> add_diseq F.true_ F.false_ br + | F.False -> br + | F.Atom t -> add_eq t F.false_ br + | F.And l -> add_form_to_expand (F.or_ (List.map F.not_ l)) br + | F.Or l -> add_form_to_expand (F.and_ (List.map F.not_ l)) br + | F.Imply (a,b) -> add_form_to_expand (F.and_ [a; F.not_ b]) br + | F.Equiv (a,b) -> + add_form_to_expand (F.or_ [F.and_ [a; F.not_ b]; F.and_ [b; F.not_ a]]) br + | F.Xor (a,b) -> + add_form_to_expand (F.and_ [F.or_ [a; F.not_ b]; F.or_ [b; F.not_ a]]) br + | F.Exists {ty_var;body} -> + let f = F.forall ~ty_var (F.not_ body) in + br |> add_eq f F.true_ + | F.Forall _ -> + br |> add_eq f F.false_ + end + | F.And _ | F.Or _ -> add_form_to_expand f br + | F.Imply (a,b) -> add_form_to_expand (F.or_ [F.not_ a; b]) br + | F.Xor (a,b) -> + add_form_to_expand (F.or_ [F.and_ [a; F.not_ b]; F.and_ [b; F.not_ a]]) br + | F.Equiv (a,b) -> + add_form_to_expand (F.and_ [F.or_ [a; F.not_ b]; F.or_ [b; F.not_ a]]) br + | F.Forall _ -> + br |> add_eq f F.true_ + | F.Exists {ty_var;body} -> + let f = F.forall ~ty_var (F.not_ body) in + br |> add_eq f F.false_ + end + + let add1 br f : t = if is_closed br then br else add1_ br f + + let add b l = + (* put atomic formulas first *) + let l = + List.sort + (fun a b -> match is_atomic a, is_atomic b with + | true, true | false, false -> 0 + | true, false -> -1 | false, true -> 1) + l + in + List.fold_left add1 b l + + let pop_to_expand b = + if is_closed b then None + else begin match T_set.choose b.to_expand with + | f -> + let tail = T_set.remove f b.to_expand in + Some (f, {b with to_expand=tail;}) + | exception Not_found -> None + end + + let rec unfold_parents b = match b.parent with + | None -> [b] + | Some p -> b :: unfold_parents p + + let debug out (b:t) : unit = + (* print one branch *) + let pp_b out b = + Fmt.fprintf out + "(@[branch/%d :closed %B@ :form (%a)@ \ + :to_expand (@[%a@])@])" + b.id (is_closed b) + (Fmt.some T.pp) b.form + (Util.pp_seq T.pp) (T_set.to_seq b.to_expand) + in + Fmt.fprintf out "(@[%a@])" (Util.pp_list pp_b) (unfold_parents b) +end + +(** Rules for the Tableau calculus *) +module Rule : sig + type t + + val apply : t list -> F.t -> F.t list list + (** Return a disjunctive list of conjuctions *) + + val all : t list +end = struct + type t = F.t -> F.t list list + + let or_ f = match F.view f with + | F.Or l -> List.map CCList.return l + | _ -> [] + + let and_ f = match F.view f with + | F.And l -> [l] + | _ -> [] + + let all = [ + or_; + and_; + ] + + let[@inline] apply (l:t list) (f:F.t) : F.t list list = + CCList.flat_map (fun r -> r f) l +end + +type branch = Branch.t + +(** main state *) +type t = { + mutable open_branches: branch list; + mutable closed_branches: branch list; + mutable saturated: branch option; +} + +type final_state = t + +let debug_tab out (tab:t) : unit = + Fmt.fprintf out "(@[tab@ :branches (@[%a@])@ :saturated (%a)@])" + (Util.pp_list Branch.debug) + (List.rev_append tab.open_branches tab.closed_branches) + (Fmt.some Branch.debug) tab.saturated + +(* solve tableau by expanding it piece by piece *) +let solve_ (tab:t) : res = + while not (CCList.is_empty tab.open_branches) && CCOpt.is_none tab.saturated do + let b = List.hd tab.open_branches in + tab.open_branches <- List.tl tab.open_branches; + Util.debugf ~section 3 + "(@[llproof.check.tab.solve@ %a@])" (fun k->k debug_tab tab); + begin match Branch.pop_to_expand b with + | None -> + if Branch.is_closed b then ( + tab.closed_branches <- b :: tab.closed_branches + ) else ( + (* cannot close this branch, it has no form to expand *) + tab.saturated <- Some b; + ) + | Some (f, b_tail) -> + let new_branches = + Rule.apply Rule.all f + |> List.map + (fun forms -> Branch.add b_tail forms) + in + assert (not @@ CCList.is_empty new_branches); + (* add new branches *) + List.iter + (fun b -> + if Branch.is_closed b then ( + tab.closed_branches <- b :: tab.closed_branches + ) else ( + tab.open_branches <- b :: tab.open_branches + )) + new_branches; + end + done; + (* closed all branches, or found saturation *) + begin match tab.saturated with + | Some b -> + (* found a branch that is not refutable *) + assert (not (Branch.is_closed @@ Branch.check_closed b)); + Util.debugf ~section 1 "(@[llprover.prove.failed@ :branch %a@])" + (fun k->k Branch.debug b); + R_fail + | None -> + assert (CCList.is_empty tab.open_branches); + Util.debugf ~section 5 + "(@[llprover.prove.success@ :branches (@[%a@])@ :saturated %a@])" + (fun k->k (Util.pp_list Branch.debug) tab.closed_branches + (Fmt.some Branch.debug) tab.saturated); + R_ok + end + +let can_check : LLProof.tag list -> bool = + let open Builtin.Tag in + let f = function + | T_ho -> true + | T_lra | T_lia | T_ind | T_data + | T_distinct | T_ac _ | T_ext -> false + in + List.for_all f + +let prove (a:form list) (b:form) = + Util.debugf ~section 3 + "(@[@{llprover.prove@}@ :hyps (@[%a@])@ :concl %a@])" + (fun k->k (Util.pp_list T.pp) a T.pp b); + Util.incr_stat stat_solve; + (* prove [a ∧ -b ⇒ ⊥] *) + let b_init = Branch.add (Branch.root()) (F.not_ b :: a) in + let tab = { + open_branches=[b_init]; + closed_branches=[]; + saturated=None; + } in + solve_ tab, tab + +let pp_stats out (s:final_state) = + let n_open = List.length s.open_branches in + let n_closed = List.length s.closed_branches in + Format.fprintf out "(@[llprover.stats@ :n_branches %d@ :n_closed %d@])" + (n_closed + n_open) n_closed + +let _to_str_escape fmt = + Util.ksprintf_noc ~f:Util.escape_dot fmt + +let pp_dot out (s:final_state) : unit = + let module ISet = Util.Int_set in + let as_graph = + CCGraph.make + (fun b -> Branch.parent b |> Sequence.of_opt |> Sequence.map (fun v->(),v)) + in + let saturated_set = + Sequence.of_opt s.saturated |> + Sequence.fold (fun s b -> ISet.add (Branch.id b) s) ISet.empty + in + let br_eq b1 b2 = CCInt.equal (Branch.id b1) (Branch.id b2) in + let br_hash b = Hash.int @@ Branch.id b in + let tbl = CCGraph.mk_table ~eq:br_eq ~hash:br_hash 32 in + let attrs_v (b:Branch.t) : _ list = + let color = + if Branch.is_closed b then [`Color "green"] + else if ISet.mem (Branch.id b) saturated_set then [`Color "red"] + else [] + in + let pp_closed out b = match Branch.closed b with + | Branch.C_not_closed -> + Fmt.fprintf out " (%d to expand)" (Branch.to_expand b |> Sequence.length) + | Branch.C_closed_by_diseq (t,u) -> + Fmt.fprintf out "%a ≠@ %a@]`>" T.pp t T.pp u + | Branch.C_closed_by_theory s -> + Fmt.fprintf out "" s + in + let label = + _to_str_escape "@[[%d] %a@ (@[%a@])@]" + (Branch.id b) pp_closed b + (Fmt.some T.pp) (Branch.form b) + in + [`Label label; `Shape "box"; `Style "filled"] @ color + in + let all_branches = + Sequence.append + (Sequence.of_list s.open_branches) + (Sequence.of_list s.closed_branches) + in + CCGraph.Dot.pp_seq + ~tbl + ~eq:br_eq + ~graph:as_graph + ~attrs_v + out all_branches + ; + () (* TODO *) diff --git a/src/proofs/LLProver.mli b/src/proofs/LLProver.mli new file mode 100644 index 000000000..fd5a478cf --- /dev/null +++ b/src/proofs/LLProver.mli @@ -0,0 +1,24 @@ + +(** {1 Low Level Prover} *) + +(** A small theorem prover that checks entailment of ground formulas, + with higher order terms and some theories *) + +type form = LLTerm.Form.t + +type res = + | R_ok + | R_fail + +type final_state + +val can_check : LLProof.tag list -> bool +(** Is this set of tags accepted by the tableau prover? *) + +val prove : form list -> form -> res * final_state +(** [prove a b] returns [R_ok] if [a => b] is a tautology. *) + +val pp_stats : final_state CCFormat.printer + +val pp_dot : final_state CCFormat.printer + diff --git a/src/proofs/LLTerm.ml b/src/proofs/LLTerm.ml index 3bd809ba8..467a4e5b4 100644 --- a/src/proofs/LLTerm.ml +++ b/src/proofs/LLTerm.ml @@ -6,9 +6,55 @@ open Logtk module Fmt = CCFormat +module I_map = Util.Int_map let errorf msg = Util.errorf ~where:"llterm" msg +module Int_op = struct + type t = Leq0 | Geq0 | Lt0 | Gt0 | Eq0 | Neq0 | Divisible_by of Z.t | Not_div_by of Z.t + let equal a b = match a, b with + | Divisible_by a, Divisible_by b -> Z.equal a b + | Not_div_by a, Not_div_by b -> Z.equal a b + | Divisible_by _, _ | _, Divisible_by _ + | Not_div_by _, _ | _, Not_div_by _ -> false + | _ -> a=b + let hash = function + | Divisible_by n -> Hash.combine2 10 (Z.hash n) + | Not_div_by n -> Hash.combine2 20 (Z.hash n) + | x -> Hash.poly x + let not = function + | Leq0 -> Gt0 | Geq0 -> Lt0 + | Lt0 -> Geq0 | Gt0 -> Leq0 + | Eq0 -> Neq0 | Neq0 -> Eq0 + | Divisible_by n -> Not_div_by n | Not_div_by n -> Divisible_by n + let pp out = function + | Leq0 -> Fmt.fprintf out "=< 0" + | Geq0 -> Fmt.fprintf out ">= 0" + | Lt0 -> Fmt.fprintf out "< 0" + | Gt0 -> Fmt.fprintf out "> 0" + | Eq0 -> Fmt.fprintf out "= 0" + | Neq0 -> Fmt.fprintf out "!= 0" + | Divisible_by n -> Fmt.fprintf out "div_by %a" Z.pp_print n + | Not_div_by n -> Fmt.fprintf out "not_div_by %a" Z.pp_print n +end + +module Rat_op = struct + type t = Leq0 | Geq0 | Lt0 | Gt0 | Eq0 | Neq0 + let equal : t -> t -> bool = (=) + let hash : t -> int = Hash.poly + let pp out = function + | Leq0 -> Fmt.fprintf out "=< 0" + | Geq0 -> Fmt.fprintf out ">= 0" + | Lt0 -> Fmt.fprintf out "< 0" + | Gt0 -> Fmt.fprintf out "> 0" + | Eq0 -> Fmt.fprintf out "= 0" + | Neq0 -> Fmt.fprintf out "!= 0" + let not = function + | Leq0 -> Gt0 | Geq0 -> Lt0 + | Lt0 -> Geq0 | Gt0 -> Leq0 + | Eq0 -> Neq0 | Neq0 -> Eq0 +end + type t = { view: view; ty: t option; @@ -28,11 +74,114 @@ and view = } | AppBuiltin of Builtin.t * t list | Ite of t * t * t + | Int_pred of Z.t linexp * Int_op.t + | Rat_pred of Q.t linexp * Rat_op.t and var = t HVar.t +and 'a linexp = { + const: 'a; + coeffs: (t * 'a) I_map.t; +} + type term = t type ty = t +module type NUM = sig + type t + val equal : t -> t -> bool + val zero : t + val one : t + val (+) : t -> t -> t + val (-) : t -> t -> t + val ( * ) : t -> t -> t + val to_string : t -> string + val pp_print : t CCFormat.printer +end + +module type LINEXP = sig + type num + type t = num linexp + val zero : t + val is_zero : t -> bool + val is_const : t -> bool + val ( + ) : t -> t -> t + val ( - ) : t -> t -> t + val ( * ) : num -> t -> t + val add : num -> term -> t -> t + val const : num -> t + val monomial : num -> term -> t + val monomial1 : term -> t + val equal : t -> t -> bool + val map : (term -> term) -> t -> t + val subterms : t -> term Sequence.t + val pp : term CCFormat.printer -> t CCFormat.printer +end + +module Make_linexp(N : NUM) = struct + type num = N.t + type t = num linexp + let zero : t = {const=N.zero; coeffs=I_map.empty} + let is_const e = I_map.is_empty e.coeffs + let is_zero e = is_const e && N.equal N.zero e.const + let merge_ f a b : t = { + const=f a.const b.const; + coeffs=I_map.merge_safe a.coeffs b.coeffs + ~f:(fun _ o -> match o with + | `Left n | `Right n -> Some n + | `Both ((t,a),(t2,b)) -> + assert (t==t2); + let c = f a b in + if N.equal N.zero c then None else Some (t,c)) + } + + let (+) = merge_ N.(+) + let (-) = merge_ N.(-) + let ( * ) c e : t = + if N.equal N.zero c then zero + else {const=N.(c * e.const); coeffs=I_map.map (fun (t,n) -> t, N.(c*n)) e.coeffs} + let const c = {const=c; coeffs=I_map.empty} + let add c t e = + let _, n = I_map.get_or ~default:(t,N.zero) t.id e.coeffs in + let n = N.(n + c) in + let coeffs = + if N.equal N.zero n + then I_map.remove t.id e.coeffs else I_map.add t.id (t,n) e.coeffs + in + {e with coeffs;} + let monomial c t = {const=N.zero; coeffs=I_map.singleton t.id (t,c)} + let monomial1 t = {const=N.zero; coeffs=I_map.singleton t.id (t,N.one)} + let equal e1 e2 = + N.equal e1.const e2.const && + I_map.equal (CCEqual.pair (==) N.equal) e1.coeffs e2.coeffs + let hash hash_t e = + let hash_n n = Hash.string @@ N.to_string n in + Hash.combine3 10 + (hash_n e.const) + (Hash.seq (Hash.pair hash_t hash_n) @@ I_map.values e.coeffs) + let map f e = + I_map.fold (fun _ (t,n) acc -> add n (f t) acc) e.coeffs (const e.const) + + let subterms e = I_map.values e.coeffs |> Sequence.map fst + + let pp pp_t out (e:t): unit = + if is_const e then N.pp_print out e.const + else ( + let pp_const out () = + if N.equal N.zero e.const then () + else Fmt.fprintf out "@ + %a" N.pp_print e.const + and pp_pair out (t,c) = + if N.equal N.one c then pp_t out t + else Fmt.fprintf out "@[<2>%a@ @<1>· %a@]" N.pp_print c pp_t t + in + Fmt.fprintf out "(@[%a%a@])" + Fmt.(seq ~sep:(return "@ + ") pp_pair) + (I_map.values e.coeffs) pp_const () + ) +end + +module Linexp_int = Make_linexp(Z) +module Linexp_rat = Make_linexp(Q) + let[@inline] view t = t.view let[@inline] ty t = t.ty let[@inline] ty_exn t = match t.ty with Some ty -> ty | None -> assert false @@ -64,6 +213,10 @@ module H_cons = Hashcons.Make(struct CCList.equal equal l1 l2 | Ite (a1,b1,c1), Ite (a2,b2,c2) -> equal a1 a2 && equal b1 b2 && equal c1 c2 + | Int_pred (l1,o1), Int_pred (l2,o2) -> + Int_op.equal o1 o2 && Linexp_int.equal l1 l2 + | Rat_pred (l1,o1), Rat_pred (l2,o2) -> + Rat_op.equal o1 o2 && Linexp_rat.equal l1 l2 | Type, _ | Const _, _ | App _, _ @@ -72,6 +225,8 @@ module H_cons = Hashcons.Make(struct | Bind _, _ | AppBuiltin _, _ | Ite _, _ + | Int_pred _, _ + | Rat_pred _, _ -> false end @@ -87,6 +242,8 @@ module H_cons = Hashcons.Make(struct CCHash.combine3 50 (Builtin.hash b) (CCHash.list hash l) | Ite (a,b,c) -> CCHash.combine4 60 (hash a)(hash b)(hash c) + | Int_pred (l,o) -> Hash.combine3 70 (Linexp_int.hash hash l) (Int_op.hash o) + | Rat_pred (l,o) -> Hash.combine3 80 (Linexp_rat.hash hash l) (Rat_op.hash o) let tag (i:int) (t:t) : unit = assert (t.id = -1); @@ -96,23 +253,23 @@ module H_cons = Hashcons.Make(struct let rec pp_rec depth out (t:t) = match view t with | Type -> Fmt.string out "type" | Const id -> ID.pp_fullc out id - | App (f,a) -> Fmt.fprintf out "@[%a@ %a@]" (pp_rec depth) f (pp_inner depth) a + | App (f,a) -> Fmt.fprintf out "@[%a@ %a@]" (pp_rec depth) f (pp_rec_inner depth) a | Arrow (a,b) -> - Fmt.fprintf out "@[%a@ @<1>→ %a@]" (pp_inner depth) a (pp_rec depth) b + Fmt.fprintf out "@[%a@ @<1>→ %a@]" (pp_rec_inner depth) a (pp_rec depth) b | Var v -> Format.fprintf out "Y%d" (depth-HVar.id v-1) | AppBuiltin (Builtin.Box_opaque, [t]) -> Format.fprintf out "@<1>⟦@[%a@]@<1>⟧" (pp_rec depth) t | AppBuiltin (b, [a]) when Builtin.is_prefix b -> - Format.fprintf out "@[%a %a@]" Builtin.pp b (pp_inner depth) a + Format.fprintf out "@[<1>%a@ %a@]" Builtin.pp b (pp_rec_inner depth) a | AppBuiltin (b, ([t1;t2] | [_;t1;t2])) when Builtin.fixity b = Builtin.Infix_binary -> - Format.fprintf out "@[%a %a@ %a@]" - (pp_inner depth) t1 Builtin.pp b (pp_inner depth) t2 + Format.fprintf out "@[<1>%a %a@ %a@]" + (pp_rec_inner depth) t1 Builtin.pp b (pp_rec_inner depth) t2 | AppBuiltin (b, l) when Builtin.is_infix b && List.length l > 0 -> Format.fprintf out "@[%a@]" (pp_infix_ depth b) l | AppBuiltin (b, []) -> Builtin.pp out b | AppBuiltin (b, l) -> Format.fprintf out "(@[%a@ %a@])" - Builtin.pp b (Util.pp_list (pp_inner depth)) l + Builtin.pp b (Util.pp_list (pp_rec_inner depth)) l | Bind {ty_var;binder;body} -> Fmt.fprintf out "@[%a (@[Y%d:%a@]).@ %a@]" Binder.pp binder @@ -120,22 +277,44 @@ let rec pp_rec depth out (t:t) = match view t with (pp_rec @@ depth+1) body | Ite (a,b,c) -> Fmt.fprintf out "@[ite %a@ %a@ %a@]" - (pp_inner depth) a - (pp_inner depth) b - (pp_inner depth) c -and pp_inner depth out t = match view t with + (pp_rec_inner depth) a + (pp_rec_inner depth) b + (pp_rec_inner depth) c + | Int_pred (l,o) -> + Fmt.fprintf out "(@[%a@ %a@])" (Linexp_int.pp (pp_rec_inner depth)) l Int_op.pp o + | Rat_pred (l,o) -> + Fmt.fprintf out "(@[%a@ %a@])" (Linexp_rat.pp (pp_rec_inner depth)) l Rat_op.pp o +and pp_rec_inner depth out t = match view t with | App _ | Bind _ | AppBuiltin (_,_::_) | Arrow _ | Ite _ -> Fmt.fprintf out "(%a)@{/%d@}" (pp_rec depth) t t.id - | Type | Const _ | Var _ | AppBuiltin (_,[]) -> + | Type | Const _ | Var _ | AppBuiltin (_,[]) | Int_pred _ | Rat_pred _ -> Fmt.fprintf out "%a@{/%d@}" (pp_rec depth) t t.id and pp_infix_ depth b out l = match l with | [] -> assert false - | [t] -> pp_inner depth out t + | [t] -> pp_rec_inner depth out t | t :: l' -> Format.fprintf out "@[%a@]@ %a %a" - (pp_inner depth) t Builtin.pp b (pp_infix_ depth b) l' + (pp_rec_inner depth) t Builtin.pp b (pp_infix_ depth b) l' let pp = pp_rec 0 +let pp_inner = pp_rec_inner 0 + +let subterms (t:t) (k:t -> unit) : unit = + let rec aux t = + k t; + CCOpt.iter aux (ty t); + begin match view t with + | Type | Const _ | Var _ -> () + | App (f,a) -> aux f; aux a + | Arrow (a,b) -> aux a; aux b + | Bind { body;_ } -> aux body + | AppBuiltin (_,l) -> List.iter aux l + | Ite (a,b,c) -> aux a; aux b; aux c + | Int_pred (l,_) -> Linexp_int.subterms l k + | Rat_pred (l,_) -> Linexp_rat.subterms l k + end + in + aux t let[@inline] mk_ view ty : t = let t = {view; ty; id= -1; } in @@ -144,6 +323,7 @@ let[@inline] mk_ view ty : t = let t_type = mk_ Type None let[@inline] var v = mk_ (Var v) (Some (HVar.ty v)) let[@inline] const ~ty id = mk_ (Const id) (Some ty) +let prop = mk_ (AppBuiltin (Builtin.Prop,[])) (Some t_type) let[@inline] is_type t : bool = match ty t with | Some ty -> ty == t_type @@ -161,7 +341,9 @@ let ite a b c = let[@inline] app_ f x ~ty = mk_ (App (f,x)) (Some ty) let[@inline] arrow_ a b = mk_ (Arrow (a,b)) (Some t_type) -let[@inline] bind ~ty binder ~ty_var body = mk_ (Bind {binder;ty_var;body}) (Some ty) +let[@inline] bind_ ~ty binder ~ty_var body = mk_ (Bind {binder;ty_var;body}) (Some ty) + +let id_eta_ = ID.make "test_eta_" (* privat to {!as_eta_expansion} *) let[@inline] app_builtin ~ty b l = let mk_ b l = mk_ (AppBuiltin(b,l)) (Some ty) in @@ -180,6 +362,41 @@ let[@inline] app_builtin ~ty b l = let[@inline] builtin ~ty b = app_builtin ~ty b [] +let bool = builtin ~ty:t_type Builtin.Prop +let true_ = builtin ~ty:bool Builtin.True +let false_ = builtin ~ty:bool Builtin.False +let of_bool b = if b then true_ else false_ + +let int_pred l o = + if Linexp_int.is_const l then ( + let module O = Int_op in + let n = l.const in + begin match o with + | O.Leq0 -> Z.sign n <= 0 + | O.Geq0 -> Z.sign n >= 0 + | O.Lt0 -> Z.sign n < 0 + | O.Gt0 -> Z.sign n > 0 + | O.Eq0 -> Z.sign n = 0 + | O.Neq0 -> Z.sign n <> 0 + | O.Divisible_by k -> Z.equal Z.zero (Z.rem n k) + | O.Not_div_by k -> not (Z.equal Z.zero (Z.rem n k)) + end |> of_bool + ) else mk_ (Int_pred (l,o)) (Some prop) + +let rat_pred l o = + if Linexp_rat.is_const l then ( + let module O = Rat_op in + let n = l.const in + begin match o with + | O.Leq0 -> Q.sign n <= 0 + | O.Geq0 -> Q.sign n >= 0 + | O.Lt0 -> Q.sign n < 0 + | O.Gt0 -> Q.sign n > 0 + | O.Eq0 -> Q.sign n = 0 + | O.Neq0 -> Q.sign n <> 0 + end |> of_bool + ) else mk_ (Rat_pred (l,o)) (Some prop) + let[@inline] map ~f ~bind:f_bind b_acc t = match view t with | Type -> t_type | Var v -> var (HVar.update_ty v ~f:(f b_acc)) @@ -188,12 +405,14 @@ let[@inline] map ~f ~bind:f_bind b_acc t = match view t with | Arrow (a,b) -> arrow_ (f b_acc a) (f b_acc b) | Bind b -> let b_acc' = f_bind b_acc in - bind b.binder ~ty:(f b_acc @@ ty_exn t) ~ty_var:(f b_acc b.ty_var) + bind_ b.binder ~ty:(f b_acc @@ ty_exn t) ~ty_var:(f b_acc b.ty_var) (f b_acc' b.body) | AppBuiltin (b,l) -> app_builtin ~ty:(f b_acc @@ ty_exn t) b (List.map (f b_acc) l) | Ite (a,b,c) -> ite (f b_acc a) (f b_acc b) (f b_acc c) + | Int_pred (l,o) -> int_pred (Linexp_int.map (f b_acc) l) o + | Rat_pred (l,o) -> rat_pred (Linexp_rat.map (f b_acc) l) o (* shift DB indices by [n] *) let db_shift n (t:t) : t = @@ -223,6 +442,17 @@ let db_eval ~(sub:t) (t:t) : t = in aux 0 t +let bind ~ty binder ~ty_var body = match binder, view body with + | Binder.Lambda, App (t, {view=Var v; _}) when HVar.id v = 0 -> + (* eta reduction for λ: + check if replacing [db0] with a fresh [c] in [t] contains [c] *) + let c = const id_eta_ ~ty:(HVar.ty v) in + let t_reduced = db_eval ~sub:c t in + if subterms t_reduced |> Sequence.exists (equal c) + then bind_ binder ~ty ~ty_var body + else t_reduced + | _ -> bind_ binder ~ty ~ty_var body + let app_ f x = match ty f, ty x with | Some {view=Arrow (a,b);_}, Some a' when equal a a' -> app_ f x ~ty:b | Some {view=Bind{binder=Binder.ForallTy;ty_var;body};_}, Some ty_x -> @@ -271,10 +501,21 @@ let rec arrow_l l ret = match l with | [] -> ret | a :: tail -> arrow a (arrow_l tail ret) -let bool = builtin ~ty:t_type Builtin.Prop let box_opaque t = app_builtin ~ty:(ty_exn t) Builtin.Box_opaque [t] -let lambda ~ty_var body = +let id_eta_ = ID.make "test_eta_" (* privat to {!as_eta_expansion} *) + +(* check if [body = t db0], with [db0 ∉ t]. + returns [Some (t shift -1)] if it's the case *) +let as_eta_expansion body : _ option = match view body with + | App (t, {view=Var v; _}) when HVar.id v = 0 -> + (* check if replacing [db0] with a fresh [c] in [t] contains [c] *) + let c = const id_eta_ ~ty:(HVar.ty v) in + let t_reduced = db_eval ~sub:c t in + if subterms t_reduced |> Sequence.exists (equal c) then None else Some t_reduced + | _ -> None + +let[@inline] lambda ~ty_var body = bind Binder.Lambda ~ty:(arrow ty_var @@ ty_exn body) ~ty_var body module Form = struct @@ -291,6 +532,8 @@ module Form = struct | Atom of t | Eq of t * t | Neq of t * t + | Int_pred of Z.t linexp * Int_op.t + | Rat_pred of Q.t linexp * Rat_op.t | Forall of {ty_var: ty; body: t} | Exists of {ty_var: ty; body: t} @@ -302,17 +545,19 @@ module Form = struct | AppBuiltin (Builtin.And, l) -> And l | AppBuiltin (Builtin.Or, l) -> Or l | AppBuiltin (Builtin.Not, [t]) -> Not t - | AppBuiltin (Builtin.Eq, [t;u]) -> Eq(t,u) - | AppBuiltin (Builtin.Neq, [t;u]) -> Neq(t,u) + | AppBuiltin (Builtin.Eq, ([_;t;u]|[t;u])) -> Eq(t,u) + | AppBuiltin (Builtin.Neq, ([_;t;u]|[t;u])) -> Neq(t,u) | AppBuiltin (Builtin.Imply, [t;u]) -> Imply(t,u) | AppBuiltin (Builtin.Equiv, [t;u]) -> Equiv(t,u) | AppBuiltin (Builtin.Xor, [t;u]) -> Xor(t,u) | Bind {binder=Binder.Forall; ty_var; body; _} -> Forall {ty_var;body} | Bind {binder=Binder.Exists; ty_var; body; _} -> Exists {ty_var;body} + | Int_pred (l,o) -> Int_pred (l,o) + | Rat_pred (l,o) -> Rat_pred (l,o) | _ -> Atom t - let true_ = builtin ~ty:bool Builtin.True - let false_ = builtin ~ty:bool Builtin.False + let true_ = true_ + let false_ = false_ let eq a b = app_builtin ~ty:(ty_exn a) Builtin.Eq [a;b] let neq a b = app_builtin ~ty:bool Builtin.Neq [a;b] let and_ a = app_builtin ~ty:bool Builtin.And a @@ -320,6 +565,8 @@ module Form = struct let equiv a b = app_builtin ~ty:(ty_exn a) Builtin.Equiv [a;b] let imply a b = app_builtin ~ty:(ty_exn a) Builtin.Imply [a;b] let xor a b = app_builtin ~ty:(ty_exn a) Builtin.Xor [a;b] + let int_pred = int_pred + let rat_pred = rat_pred let forall ~ty_var body = bind Binder.Forall ~ty:bool ~ty_var body let exists ~ty_var body = bind Binder.Exists ~ty:bool ~ty_var body @@ -327,6 +574,8 @@ module Form = struct | Eq (a,b) -> neq a b | Neq (a,b) -> eq a b | Not f -> f + | Int_pred (l,o) -> int_pred l (Int_op.not o) + | Rat_pred (l,o) -> rat_pred l (Rat_op.not o) | _ -> app_builtin ~ty:bool Builtin.Not [a] end @@ -360,6 +609,12 @@ module Conv = struct let ty = db_shift (ctx.depth-i) ty in var (HVar.make (ctx.depth-i-1) ~ty) end + | T.AppBuiltin (Builtin.Pseudo_de_bruijn i, []) -> + (* NOTE: magic here. This was a free De Bruijn index, typically coming + from rewriting under lambdas. Now we convert it back into a + normal DB index. *) + let ty = of_term ctx (T.ty_exn t) in + var (HVar.make i ~ty) | T.Const id -> let ty = of_term ctx (T.ty_exn t) in const id ~ty @@ -386,12 +641,99 @@ module Conv = struct let l = List.map (of_term ctx) l in arrow_l l ret | T.AppBuiltin (b, l) -> - let ty = of_term ctx (T.ty_exn t) in - let l = List.map (of_term ctx) l in - app_builtin ~ty b l + let ty = T.ty_exn t in + begin match b with + | (Builtin.Greatereq | Builtin.Lesseq | Builtin.Less + | Builtin.Greater | Builtin.Eq | Builtin.Neq) when List.exists is_arith l -> + if List.exists is_int l then ( + conv_int_pred ctx ~ty b l + ) else ( + assert (List.exists is_rat l); + conv_rat_pred ctx ~ty b l + ) + | _ -> conv_builtin ctx ~ty b l + end | T.Let _ -> assert false (* FIXME *) | T.Match _ -> assert false (* FIXME? *) | T.Multiset _ -> assert false (* FIXME? *) | T.Record _ -> assert false (* FIXME? *) | T.Meta _ -> assert false + + and is_int t = T.Ty.equal T.Ty.int (T.ty_exn t) + and is_rat t = T.Ty.equal T.Ty.rat (T.ty_exn t) + and is_arith t = is_int t || is_rat t + + (* default conv for builtins *) + and conv_builtin ctx ~ty b l = + let ty = of_term ctx ty in + let l = List.map (of_term ctx) l in + app_builtin ~ty b l + + and conv_int_pred ctx ~ty b l : term = + let module O = Int_op in + let op = match b with + | Builtin.Greatereq -> O.Geq0 + | Builtin.Lesseq -> O.Leq0 + | Builtin.Less -> O.Lt0 + | Builtin.Greater -> O.Gt0 + | Builtin.Eq -> O.Eq0 + | Builtin.Neq -> O.Neq0 + | _ -> assert false + in + match l with + | [_; a; b] | [a;b] -> + let a = conv_int_linexp ctx a in + let b = conv_int_linexp ctx b in + int_pred Linexp_int.(a - b) op + | _ -> conv_builtin ctx ~ty b l + + and conv_rat_pred ctx ~ty b l : term = + let module O = Rat_op in + let op = match b with + | Builtin.Greatereq -> O.Geq0 + | Builtin.Lesseq -> O.Leq0 + | Builtin.Less -> O.Lt0 + | Builtin.Greater -> O.Gt0 + | Builtin.Eq -> O.Eq0 + | Builtin.Neq -> O.Neq0 + | _ -> assert false + in + match l with + | [_; a; b] | [a;b] -> + let a = conv_rat_linexp ctx a in + let b = conv_rat_linexp ctx b in + rat_pred Linexp_rat.(a - b) op + | _ -> conv_builtin ctx ~ty b l + + and conv_int_linexp ctx t : Linexp_int.t = match T.view t with + | T.AppBuiltin (Builtin.Int z, []) -> Linexp_int.const z + | T.AppBuiltin (Builtin.Sum, [_;a;b]) -> + Linexp_int.(conv_int_linexp ctx a + conv_int_linexp ctx b) + | T.AppBuiltin (Builtin.Difference, [_;a;b]) -> + Linexp_int.(conv_int_linexp ctx a - conv_int_linexp ctx b) + | T.AppBuiltin (Builtin.Product, [_;a;b]) -> + begin match T.view a, T.view b with + | T.AppBuiltin (Builtin.Int n,[]), _ -> + Linexp_int.(n * conv_int_linexp ctx b) + | _, T.AppBuiltin (Builtin.Int n,[]) -> + Linexp_int.(n * conv_int_linexp ctx a) + | _ -> Linexp_int.monomial1 (of_term ctx t) + end + | _ -> Linexp_int.monomial1 (of_term ctx t) + + and conv_rat_linexp ctx t : Linexp_rat.t = match T.view t with + | T.AppBuiltin (Builtin.Rat z, []) -> Linexp_rat.const z + | T.AppBuiltin (Builtin.Sum, [_;a;b]) -> + Linexp_rat.(conv_rat_linexp ctx a + conv_rat_linexp ctx b) + | T.AppBuiltin (Builtin.Difference, [_;a;b]) -> + Linexp_rat.(conv_rat_linexp ctx a - conv_rat_linexp ctx b) + | T.AppBuiltin (Builtin.Product, [_;a;b]) -> + begin match T.view a, T.view b with + | T.AppBuiltin (Builtin.Rat n,[]), _ -> + Linexp_rat.(n * conv_rat_linexp ctx b) + | _, T.AppBuiltin (Builtin.Rat n,[]) -> + Linexp_rat.(n * conv_rat_linexp ctx a) + | _ -> Linexp_rat.monomial1 (of_term ctx t) + end + | _ -> Linexp_rat.monomial1 (of_term ctx t) end diff --git a/src/proofs/LLTerm.mli b/src/proofs/LLTerm.mli index cf424578e..51740e181 100644 --- a/src/proofs/LLTerm.mli +++ b/src/proofs/LLTerm.mli @@ -9,6 +9,22 @@ type t type var = t HVar.t +module Int_op : sig + type t = Leq0 | Geq0 | Lt0 | Gt0 | Eq0 | Neq0 | Divisible_by of Z.t | Not_div_by of Z.t + val not : t -> t + val equal : t -> t -> bool + val hash : t -> int + val pp : t CCFormat.printer +end + +module Rat_op : sig + type t = Leq0 | Geq0 | Lt0 | Gt0 | Eq0 | Neq0 + val not : t -> t + val equal : t -> t -> bool + val hash : t -> int + val pp : t CCFormat.printer +end + type view = | Type | Const of ID.t @@ -22,10 +38,37 @@ type view = } | AppBuiltin of Builtin.t * t list | Ite of t * t * t + | Int_pred of Z.t linexp * Int_op.t + | Rat_pred of Q.t linexp * Rat_op.t + +and 'a linexp (** linear expression with coeffs of type 'a *) type term = t type ty = t +(** linear expressions *) +module type LINEXP = sig + type num + type t = num linexp + val zero : t + val is_zero : t -> bool + val is_const : t -> bool + val ( + ) : t -> t -> t + val ( - ) : t -> t -> t + val ( * ) : num -> t -> t + val add : num -> term -> t -> t + val const : num -> t + val monomial : num -> term -> t + val monomial1 : term -> t + val equal : t -> t -> bool + val map : (term -> term) -> t -> t + val subterms : t -> term Sequence.t + val pp : term CCFormat.printer -> t CCFormat.printer +end + +module Linexp_int : LINEXP with type num = Z.t +module Linexp_rat : LINEXP with type num = Q.t + val view : t -> view val ty : t -> ty option val ty_exn : t -> ty @@ -46,6 +89,8 @@ val bind : ty:ty -> Binder.t -> ty_var:ty -> t -> t val app_builtin : ty:ty -> Builtin.t -> t list -> t val builtin : ty:ty -> Builtin.t -> t val ite : t -> t -> t -> t +val int_pred : Linexp_int.t -> Int_op.t -> t +val rat_pred : Linexp_rat.t -> Rat_op.t -> t val bool : ty val box_opaque : t -> t @@ -55,6 +100,7 @@ val db_eval : sub:t -> t -> t (** [db_eval ~sub t] replaces De Bruijn 0 in [t] by [sub] *) val pp : t CCFormat.printer +val pp_inner : t CCFormat.printer module Form : sig type t = term @@ -70,6 +116,8 @@ module Form : sig | Atom of t | Eq of t * t | Neq of t * t + | Int_pred of Z.t linexp * Int_op.t + | Rat_pred of Q.t linexp * Rat_op.t | Forall of {ty_var: ty; body: t} | Exists of {ty_var: ty; body: t} @@ -86,6 +134,8 @@ module Form : sig val imply : t -> t -> t val equiv : t -> t -> t val xor : t -> t -> t + val int_pred : Linexp_int.t -> Int_op.t -> t + val rat_pred : Linexp_rat.t -> Rat_op.t -> t val forall : ty_var:ty -> t -> t val exists : ty_var:ty -> t -> t end diff --git a/src/proofs/jbuild b/src/proofs/jbuild new file mode 100644 index 000000000..5948f5bfd --- /dev/null +++ b/src/proofs/jbuild @@ -0,0 +1,17 @@ +; vim:ft=lisp: + +(jbuild_version 1) + +; main lib +(library + ((name logtk_proofs) + (public_name logtk.proofs) + (synopsis "proofs for logtk") + (libraries (containers logtk)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -bin-annot + -unbox-closures -unbox-closures-factor 20)) + )) + + + diff --git a/src/proofs/logtk_proofs.mld b/src/proofs/logtk_proofs.mld new file mode 100644 index 000000000..6a0283ee2 --- /dev/null +++ b/src/proofs/logtk_proofs.mld @@ -0,0 +1,4 @@ + +Low level proof format, plus a simple checker for some proof steps. + +{!modules: Logtk_proofs} diff --git a/src/proofs/logtk_proofs.mldylib b/src/proofs/logtk_proofs.mldylib deleted file mode 100644 index 41a50368d..000000000 --- a/src/proofs/logtk_proofs.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 823c92deb57ab19dbbb090f203b2f8fa) -Logtk_proofs -# OASIS_STOP diff --git a/src/proofs/logtk_proofs.mllib b/src/proofs/logtk_proofs.mllib deleted file mode 100644 index 41a50368d..000000000 --- a/src/proofs/logtk_proofs.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 823c92deb57ab19dbbb090f203b2f8fa) -Logtk_proofs -# OASIS_STOP diff --git a/src/proofs/logtk_proofs.mlpack b/src/proofs/logtk_proofs.mlpack deleted file mode 100644 index 128750941..000000000 --- a/src/proofs/logtk_proofs.mlpack +++ /dev/null @@ -1,7 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: d4500a4d43c1d43158215749472c3648) -LLProof -LLProof_conv -LLProof_check -LLTerm -# OASIS_STOP diff --git a/src/prover/Classify_cst.mli b/src/prover/Classify_cst.mli index 5494eddae..e17fd9b02 100644 --- a/src/prover/Classify_cst.mli +++ b/src/prover/Classify_cst.mli @@ -16,9 +16,9 @@ type res = | Cstor of Ind_ty.constructor * Ind_ty.t | Inductive_cst of Ind_cst.t option | Projector of ID.t - (** projector of some constructor (id: type) *) + (** projector of some constructor (id: type) *) | DefinedCst of int * Statement.definition - (** (recursive) definition of given stratification level + definition *) + (** (recursive) definition of given stratification level + definition *) | Parameter of int | Skolem | Other diff --git a/src/prover/Cut_form.ml b/src/prover/Cut_form.ml index fbaa7f966..4ff3ab92f 100644 --- a/src/prover/Cut_form.ml +++ b/src/prover/Cut_form.ml @@ -169,7 +169,7 @@ module Seq = struct let terms_with_pos ?(subterms=true) f = cs f |> Sequence.of_list - |> Sequence.zip_i |> Sequence.zip + |> Util.seq_zipi |> Sequence.flat_map (fun (i,c) -> Sequence.of_array_i c diff --git a/src/prover/META b/src/prover/META deleted file mode 100644 index 7fd90ae66..000000000 --- a/src/prover/META +++ /dev/null @@ -1,14 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: d146e3a82931b52f33abefa94674eaa7) -version = "1.4" -description = -"Superposition theorem prover, for first order logic with equality." -requires = -"containers sequence unix zarith msat logtk logtk.parsers logtk.proofs" -archive(byte) = "libzipperposition.cma" -archive(byte, plugin) = "libzipperposition.cma" -archive(native) = "libzipperposition.cmxa" -archive(native, plugin) = "libzipperposition.cmxs" -exists_if = "libzipperposition.cma" -# OASIS_STOP - diff --git a/src/prover/SClause.ml b/src/prover/SClause.ml index ae754d456..ff1729944 100644 --- a/src/prover/SClause.ml +++ b/src/prover/SClause.ml @@ -38,9 +38,9 @@ let add_trail_ trail f = then f else F.imply (Trail.to_s_form trail) f -let to_s_form ?(ctx=Term.Conv.create()) c = +let to_s_form ?allow_free_db ?(ctx=Term.Conv.create()) c = let module F = TypedSTerm.Form in - Literals.Conv.to_s_form ~ctx (lits c) + Literals.Conv.to_s_form ?allow_free_db ~ctx (lits c) |> add_trail_ (trail c) |> F.close_forall @@ -149,11 +149,11 @@ let to_s_form_subst ~ctx subst c : _ * _ Var.Subst.t = let module SP = Subst.Projection in let f = Literals.apply_subst (SP.renaming subst) (SP.subst subst) (lits c,SP.scope subst) - |> Literals.Conv.to_s_form ~ctx + |> Literals.Conv.to_s_form ~allow_free_db:true ~ctx |> add_trail_ (trail c) |> F.close_forall and inst_subst = - SP.as_inst ~ctx subst (Literals.vars (lits c)) + SP.as_inst ~allow_free_db:true ~ctx subst (Literals.vars (lits c)) in f, inst_subst @@ -167,7 +167,7 @@ let proof_tc = then if Trail.is_empty (trail c) then `Proof_of_false else `Absurd_lits else `Vanilla) - ~to_form:(fun ~ctx c -> to_s_form ~ctx c) + ~to_form:(fun ~ctx c -> to_s_form ~allow_free_db:true ~ctx c) ~to_form_subst:to_s_form_subst ~pp_in () diff --git a/src/prover/SClause.mli b/src/prover/SClause.mli index 9bd62bcc2..682d86e9a 100644 --- a/src/prover/SClause.mli +++ b/src/prover/SClause.mli @@ -31,7 +31,9 @@ val length : t -> int val update_trail : (Trail.t -> Trail.t) -> t -> t -val to_s_form : ?ctx:Term.Conv.ctx -> t -> TypedSTerm.Form.t +val to_s_form : + ?allow_free_db:bool -> ?ctx:Term.Conv.ctx -> + t -> TypedSTerm.Form.t (** {2 Flags} *) diff --git a/src/prover/const.ml.ab b/src/prover/const.ml.ab deleted file mode 100644 index a41d4dd91..000000000 --- a/src/prover/const.ml.ab +++ /dev/null @@ -1,16 +0,0 @@ - -(* This file is free software, part of Zipperposition. See file "license" for more details. *) - -(** {1 Configuration and Globals} - -{b DO NOT MODIFY "const.ml", IT IS GENERATED FROM "const.ml.ab"} *) - -(* place for storage *) -let home = "$(datadir)/" - -let version = "$(pkg_version)" - -let section = Logtk.Util.Section.(make "zip") - -(* vim:filetype=ocaml: -*) diff --git a/src/prover/env.ml b/src/prover/env.ml index 51872d637..b2ece09f8 100644 --- a/src/prover/env.ml +++ b/src/prover/env.ml @@ -636,7 +636,7 @@ module Make(X : sig if not (is_trivial c) then ( (* add the clause to set of inferred clauses, if it's not the original clause *) if depth > 0 then unary_clauses := c :: !unary_clauses; - if depth < params.Params.param_unary_depth + if depth < params.Params.unary_depth then ( (* infer clauses from c, add them to the queue *) let new_clauses = do_unary_inferences c in diff --git a/src/prover/jbuild b/src/prover/jbuild new file mode 100644 index 000000000..3931ddf0f --- /dev/null +++ b/src/prover/jbuild @@ -0,0 +1,26 @@ +; vim:ft=lisp: + +(jbuild_version 1) + +(rule + ((targets (const.ml)) + (deps ()) + (action + (with-stdout-to ${@} + (progn + (echo "let version = \"${version:zipperposition}\"\n") + (echo "let section = Logtk.Util.Section.make \"zip\"\n")))) + )) + +; main lib +(library + ((name libzipperposition) + (public_name libzipperposition) + (synopsis "library for the Zipperposition theorem prover") + (libraries (containers zarith msat logtk logtk.proofs logtk.parsers)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -bin-annot + -unbox-closures -unbox-closures-factor 20)) + )) + + diff --git a/src/prover/lib/_tags b/src/prover/lib/_tags deleted file mode 100644 index ce94c90ec..000000000 --- a/src/prover/lib/_tags +++ /dev/null @@ -1 +0,0 @@ -<**/*.ml>: -warn_K, -warn_Y, -warn_X diff --git a/src/prover/libzipperposition.mld b/src/prover/libzipperposition.mld new file mode 100644 index 000000000..2429a5a02 --- /dev/null +++ b/src/prover/libzipperposition.mld @@ -0,0 +1,4 @@ + +Library with the core data structures and algorithms for a Superposition prover. + +{!modules: Libzipperposition} diff --git a/src/prover/libzipperposition.mldylib b/src/prover/libzipperposition.mldylib deleted file mode 100644 index b1c6f1371..000000000 --- a/src/prover/libzipperposition.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 588fb5f222ac7d91454195051b1c7249) -Libzipperposition -# OASIS_STOP diff --git a/src/prover/libzipperposition.mllib b/src/prover/libzipperposition.mllib deleted file mode 100644 index b1c6f1371..000000000 --- a/src/prover/libzipperposition.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 588fb5f222ac7d91454195051b1c7249) -Libzipperposition -# OASIS_STOP diff --git a/src/prover/libzipperposition.mlpack b/src/prover/libzipperposition.mlpack deleted file mode 100644 index f2d579b1b..000000000 --- a/src/prover/libzipperposition.mlpack +++ /dev/null @@ -1,52 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: b4057294559122494476c5ec35f921d4) -ClauseQueue -Clause -SClause -Const -Extensions -Ctx -ProofState -Bool_clause -Saturate -Selection -AC -AC_intf -SimplM -Params -Env -Signals -Classify_cst -Ctx_intf -Clause_intf -Env_intf -ProofState_intf -BBox -ClauseContext -ClauseQueue_intf -Bool_lit -Bool_lit_intf -Sat_solver -Sat_solver_intf -Trail -Ind_cst -Cover_set -Cut_form -Phases -Phases_impl -calculi/Avatar -calculi/Avatar_intf -calculi/Induction -calculi/Induction_intf -calculi/Superposition -calculi/Superposition_intf -calculi/Rewriting -calculi/EnumTypes -calculi/Arith_int -calculi/Arith_rat -calculi/Heuristics -calculi/Ind_types -calculi/Fool -calculi/Higher_order -lib/Simplex -# OASIS_STOP diff --git a/src/prover/libzipperposition_prover.mldylib b/src/prover/libzipperposition_prover.mldylib deleted file mode 100644 index ce056bf39..000000000 --- a/src/prover/libzipperposition_prover.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: d30d7e58d92c436ac219bb8a08b8bc82) -Libzipperposition_prover -# OASIS_STOP diff --git a/src/prover/libzipperposition_prover.mllib b/src/prover/libzipperposition_prover.mllib deleted file mode 100644 index ce056bf39..000000000 --- a/src/prover/libzipperposition_prover.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: d30d7e58d92c436ac219bb8a08b8bc82) -Libzipperposition_prover -# OASIS_STOP diff --git a/src/prover/libzipperposition_prover.mlpack b/src/prover/libzipperposition_prover.mlpack deleted file mode 100644 index f2427cb2f..000000000 --- a/src/prover/libzipperposition_prover.mlpack +++ /dev/null @@ -1,59 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: a5af1405ec73f49d461c4a67f3dd4f98) -ClauseQueue -Clause -SClause -Const -Extensions -Literal -Literals -Ctx -ProofStep -ProofPrint -ProofState -Saturate -Selection -AC -AC_intf -SimplM -Compute_prec -Params -Env -Monome -ArithLit -Signals -Multisets -Ctx_intf -Clause_intf -Env_intf -ProofState_intf -BBox -ClauseContext -ClauseQueue_intf -Bool_lit -Bool_lit_intf -Sat_solver -Sat_solver_intf -Trail -Ind_cst -Phases -Phases_impl -Flex_state -Classify_cst -Rewrite_rule -calculi/Avatar -calculi/Avatar_intf -calculi/Induction -calculi/Induction_intf -calculi/Superposition -calculi/Rewriting -calculi/EnumTypes -calculi/ArithInt -calculi/Heuristics -calculi/Ind_types -meta/MetaProverState -meta/MetaProverState_intf -lib/UnionFind -lib/Signal -lib/Simplex -# OASIS_STOP diff --git a/src/prover/params.ml b/src/prover/params.ml index 79ccfd475..f1d6ec0d5 100644 --- a/src/prover/params.ml +++ b/src/prover/params.ml @@ -9,46 +9,71 @@ open Logtk (* TODO: params to enable/disable some preprocessing *) type t = { - param_ord : string; - param_seed : int; - param_steps : int; - param_version : bool; - param_timeout : float; - param_prelude : (string, CCVector.ro) CCVector.t; - param_files : (string, CCVector.ro) CCVector.t; - param_select : string; (** name of the selection function *) - param_dot_file : string option; (** file to print the final state in *) - param_dot_llproof: string option; (** file to print llproof *) - param_dot_sat : bool; (** Print saturated set into DOT? *) - param_dot_all_roots : bool; - param_def_as_rewrite: bool; - param_expand_def : bool; (** expand definitions *) - param_stats : bool; - param_presaturate : bool; (** initial interreduction of proof state? *) - param_unary_depth : int; (** Maximum successive levels of unary inferences *) - param_check: bool; (** check proof *) + ord : string; + seed : int; + steps : int; + version : bool; + timeout : float; + prelude : (string, CCVector.ro) CCVector.t; + files : (string, CCVector.ro) CCVector.t; + select : string; (** name of the selection function *) + dot_file : string option; (** file to print the final state in *) + dot_llproof: string option; (** file to print llproof *) + dot_sat : bool; (** Print saturated set into DOT? *) + dot_all_roots : bool; + dot_check: string option; (** prefix for printing checker proofs *) + def_as_rewrite: bool; + expand_def : bool; (** expand definitions *) + stats : bool; + presaturate : bool; (** initial interreduction of proof state? *) + unary_depth : int; (** Maximum successive levels of unary inferences *) + check: bool; (** check proof *) } -let ord = ref "kbo" -and seed = ref 1928575 -and steps = ref ~-1 -and version = ref false -and timeout = ref 0. -and presaturate = ref false -and dot_file = ref None -and dot_llproof = ref None -and dot_sat = ref false -and dot_all_roots = ref false -and expand_def = ref false -and select = ref "default" -and unary_depth = ref 1 -and def_as_rewrite = ref true -and prelude = CCVector.create() -and files = CCVector.create () -and check = ref false +let default : t = { + ord= "kbo"; + seed = 1928575; + steps = -1; + version= false; + timeout = 0.; + prelude= CCVector.create() |> CCVector.freeze; + files = CCVector.create() |> CCVector.freeze; + select = "default"; + stats= !Options.stats; + def_as_rewrite= true; + presaturate = false; + dot_all_roots= false; + dot_file = None; + dot_llproof= None; + dot_check=None; + unary_depth= 1; + dot_sat= false; + expand_def= false; + check= false; +} + +let select = ref default.select (** parse_args returns parameters *) let parse_args () = + let ord = ref default.ord + and seed = ref default.seed + and steps = ref default.steps + and version = ref default.version + and timeout = ref default.timeout + and presaturate = ref default.presaturate + and dot_file = ref default.dot_file + and dot_llproof = ref default.dot_llproof + and dot_sat = ref default.dot_sat + and dot_all_roots = ref default.dot_all_roots + and dot_check = ref default.dot_check + and expand_def = ref default.expand_def + and unary_depth = ref default.unary_depth + and def_as_rewrite = ref default.def_as_rewrite + and prelude = CCVector.create() + and files = CCVector.create () + and check = ref default.check + in (* special handlers *) let add_file s = CCVector.push files s in (* options list *) @@ -66,6 +91,7 @@ let parse_args () = ; "--dot-llproof", Arg.String (fun s -> dot_llproof := Some s) , " print LLProof to file in DOT" ; "--dot-sat", Arg.Set dot_sat, " print saturated set into DOT" ; "--dot-all-roots", Arg.Set dot_all_roots, " print all empty clauses into DOT" + ; "--dot-check-prefix", Arg.String (fun s-> dot_check :=Some s), " prefix for printing checker proofs in DOT" ; "--color", Arg.Bool CCFormat.set_color_default, " enable/disable ANSI color codes" ; "--seed", Arg.Set_int seed, " set random seed" ; "--unary-depth", Arg.Set_int unary_depth, " maximum depth for successive unary inferences" @@ -87,14 +113,15 @@ let parse_args () = let prelude = CCVector.freeze prelude in let files = CCVector.freeze files in (* return parameter structure *) - { param_ord= !ord; param_seed = !seed; param_steps = !steps; - param_version= !version; param_timeout = !timeout; param_prelude= prelude; - param_files = files; param_select = !select; - param_stats= ! Options.stats; param_def_as_rewrite= !def_as_rewrite; - param_presaturate = !presaturate; param_dot_all_roots= !dot_all_roots; - param_dot_file = !dot_file; param_dot_llproof= !dot_llproof; - param_unary_depth= !unary_depth; param_dot_sat= !dot_sat; - param_expand_def= !expand_def; param_check= !check; } + { ord= !ord; seed = !seed; steps = !steps; + version= !version; timeout = !timeout; prelude= prelude; + files = files; select = !select; + stats= ! Options.stats; def_as_rewrite= !def_as_rewrite; + presaturate = !presaturate; dot_all_roots= !dot_all_roots; + dot_file = !dot_file; dot_llproof= !dot_llproof; + dot_check= !dot_check; + unary_depth= !unary_depth; dot_sat= !dot_sat; + expand_def= !expand_def; check= !check; } let add_opt = Options.add_opt let add_opts = Options.add_opts diff --git a/src/prover/params.mli b/src/prover/params.mli new file mode 100644 index 000000000..a36e564e8 --- /dev/null +++ b/src/prover/params.mli @@ -0,0 +1,37 @@ + +open Logtk + +type t = { + ord : string; + seed : int; + steps : int; + version : bool; + timeout : float; + prelude : (string, CCVector.ro) CCVector.t; + files : (string, CCVector.ro) CCVector.t; + select : string; (** name of the selection function *) + dot_file : string option; (** file to print the final state in *) + dot_llproof: string option; (** file to print llproof *) + dot_sat : bool; (** Print saturated set into DOT? *) + dot_all_roots : bool; + dot_check: string option; (** prefix for printing checker proofs *) + def_as_rewrite: bool; + expand_def : bool; (** expand definitions *) + stats : bool; + presaturate : bool; (** initial interreduction of proof state? *) + unary_depth : int; (** Maximum successive levels of unary inferences *) + check: bool; (** check proof *) +} + +val parse_args : unit -> t + +val default : t + +val add_opt : (string * Arg.spec * string) -> unit +val add_opts : (string * Arg.spec * string) list -> unit + +val key : t Flex_state.key + +(**/**) +val select : string ref +(**/**) diff --git a/src/prover/saturate.ml b/src/prover/saturate.ml index b93396696..82fc55e6f 100644 --- a/src/prover/saturate.ml +++ b/src/prover/saturate.ml @@ -9,7 +9,6 @@ open Logtk module C = Clause module O = Ordering module PS = ProofState -module Sup = Superposition module Sel = Selection let stat_redundant_given = Util.mk_stat "saturate.redundant given clauses" diff --git a/src/prover/calculi/Arith_int.ml b/src/prover_calculi/Arith_int.ml similarity index 99% rename from src/prover/calculi/Arith_int.ml rename to src/prover_calculi/Arith_int.ml index 44132ef75..9e940760d 100644 --- a/src/prover/calculi/Arith_int.ml +++ b/src/prover_calculi/Arith_int.ml @@ -4,6 +4,7 @@ (** {1 Cancellative Inferences} *) open Logtk +open Libzipperposition module T = Term module Lit = Literal @@ -223,12 +224,12 @@ module Make(E : Env.S) : S with module Env = E = struct _idx_unit_ineq := if !enable_trivial_ineq_ || !enable_demod_ineq_ then AL.fold_terms ~subterms:false ~vars:false ~pos ~which:`Max ~ord alit - |> Sequence.fold - (fun acc (t,pos) -> - assert (not (T.is_var t)); - let with_pos = C.WithPos.( {term=t; pos; clause=c;} ) in - f acc t with_pos) - !_idx_unit_ineq + |> Sequence.fold + (fun acc (t,pos) -> + assert (not (T.is_var t)); + let with_pos = C.WithPos.( {term=t; pos; clause=c;} ) in + f acc t with_pos) + !_idx_unit_ineq else !_idx_unit_ineq | [| Lit.Int (AL.Divides d as alit) |] when d.AL.sign -> let pos = Position.(arg 0 stop) in @@ -1809,7 +1810,7 @@ module Make(E : Env.S) : S with module Env = E = struct Lit.pp lit i C.pp c (Lits.is_max ~ord (C.lits c) i) CCBV.print (Lits.maxlits ~ord @@ C.lits c);*) (* FIXME: find why this sometimes fails - assert (Lits.is_max ~ord (C.lits c) i); *) + assert (Lits.is_max ~ord (C.lits c) i); *) let lits = CCArray.except_idx (C.lits c) i in let new_lits = [ Lit.mk_arith_lesseq (M.succ m1) m2 diff --git a/src/prover/calculi/Arith_int.mli b/src/prover_calculi/Arith_int.mli similarity index 99% rename from src/prover/calculi/Arith_int.mli rename to src/prover_calculi/Arith_int.mli index f728d0b2a..271027216 100644 --- a/src/prover/calculi/Arith_int.mli +++ b/src/prover_calculi/Arith_int.mli @@ -7,6 +7,7 @@ congruence classes of terms and literals. Inferences are typically done with "scaled" literals, i.e. literals that are multiplied by numeric coefficients so as to bring the unified terms to the same coefficient. *) +open Libzipperposition val case_switch_limit : int ref (** Positive integer: maximum width of an inequality case switch. Default: 30 *) diff --git a/src/prover/calculi/Arith_rat.ml b/src/prover_calculi/Arith_rat.ml similarity index 99% rename from src/prover/calculi/Arith_rat.ml rename to src/prover_calculi/Arith_rat.ml index 28a4bcb17..56b15f36d 100644 --- a/src/prover/calculi/Arith_rat.ml +++ b/src/prover_calculi/Arith_rat.ml @@ -4,6 +4,7 @@ (** {1 Cancellative Inferences} *) open Logtk +open Libzipperposition module T = Term module Lit = Literal @@ -143,12 +144,12 @@ module Make(E : Env.S) : S with module Env = E = struct _idx_unit_ineq := if !enable_trivial_ineq_ || !enable_demod_ineq_ then AL.fold_terms ~subterms:false ~vars:false ~pos ~which:`Max ~ord alit - |> Sequence.fold - (fun acc (t,pos) -> - assert (not (T.is_var t)); - let with_pos = C.WithPos.( {term=t; pos; clause=c;} ) in - f acc t with_pos) - !_idx_unit_ineq + |> Sequence.fold + (fun acc (t,pos) -> + assert (not (T.is_var t)); + let with_pos = C.WithPos.( {term=t; pos; clause=c;} ) in + f acc t with_pos) + !_idx_unit_ineq else !_idx_unit_ineq | _ -> () end; diff --git a/src/prover/calculi/Arith_rat.mli b/src/prover_calculi/Arith_rat.mli similarity index 97% rename from src/prover/calculi/Arith_rat.mli rename to src/prover_calculi/Arith_rat.mli index a17b1002c..582839206 100644 --- a/src/prover/calculi/Arith_rat.mli +++ b/src/prover_calculi/Arith_rat.mli @@ -10,6 +10,7 @@ "scaled" literals, i.e. literals that are multiplied by numeric coefficients so as to bring the unified terms to the same coefficient. *) +open Libzipperposition module type S = sig module Env : Env.S diff --git a/src/prover/calculi/Higher_order.ml b/src/prover_calculi/Higher_order.ml similarity index 93% rename from src/prover/calculi/Higher_order.ml rename to src/prover_calculi/Higher_order.ml index 0a8bdc901..de1941745 100644 --- a/src/prover/calculi/Higher_order.ml +++ b/src/prover_calculi/Higher_order.ml @@ -4,6 +4,7 @@ (** {1 boolean subterms} *) open Logtk +open Libzipperposition module BV = CCBV module T = Term @@ -27,7 +28,7 @@ let prof_eq_res = Util.mk_profiler "ho.eq_res" let prof_eq_res_syn = Util.mk_profiler "ho.eq_res_syntactic" let prof_ho_unif = Util.mk_profiler "ho.unif" -let _purify_applied_vars = ref false +let _purify_applied_vars = ref `None let _general_ext_pos = ref false let _ext_pos = ref true let _ext_axiom = ref false @@ -145,6 +146,7 @@ module Make(E : Env.S) : S with module Env = E = struct begin match T.view last1, T.view last2 with | T.Var x, T.Var y when HVar.equal Type.equal x y && + not (Type.is_tType (HVar.ty x)) && begin Sequence.of_list [Sequence.doubleton f1 f2; @@ -189,7 +191,7 @@ module Make(E : Env.S) : S with module Env = E = struct *) let ext_pos_general (c:C.t) : C.t list = let eligible = C.Eligible.param c in - (* Remove recursively variables at the end of the liiteral t = s if possible. + (* Remove recursively variables at the end of the literal t = s if possible. e.g. ext_pos_lit (f X Y) (g X Y) other_lits = [f X = g X, f = g] if X and Y do not appear in other_lits *) let rec ext_pos_lit t s other_lits = @@ -197,7 +199,7 @@ module Make(E : Env.S) : S with module Env = E = struct let g, ss = T.as_app s in begin match List.rev tt, List.rev ss with | last_t :: tl_rev_t, last_s :: tl_rev_s -> - if last_t = last_s then + if last_t = last_s && not (T.is_type last_t) then match T.as_var last_t with | Some v -> if not (T.var_occurs ~var:v f) @@ -222,7 +224,7 @@ module Make(E : Env.S) : S with module Env = E = struct let new_clauses = (* iterate over all literals eligible for paramodulation *) C.lits c - |> Sequence.of_array |> Sequence.zip_i |> Sequence.zip + |> Sequence.of_array |> Util.seq_zipi |> Sequence.filter (fun (idx,lit) -> eligible idx lit) |> Sequence.flat_map_l (fun (lit_idx,lit) -> match lit with @@ -246,9 +248,8 @@ module Make(E : Env.S) : S with module Env = E = struct |> Sequence.to_rev_list in if new_clauses<>[] then ( - Util.add_stat stat_complete_eq (List.length new_clauses); Util.debugf ~section 4 - "(@[complete-eq@ :clause %a@ :yields (@[%a@])@])" + "(@[ext-pos-general-eq@ :clause %a@ :yields (@[%a@])@])" (fun k->k C.pp c (Util.pp_list ~sep:" " C.pp) new_clauses); ); new_clauses @@ -259,7 +260,7 @@ module Make(E : Env.S) : S with module Env = E = struct let eligible = C.Eligible.param c in let new_c = C.lits c - |> Sequence.of_array |> Sequence.zip_i |> Sequence.zip + |> Sequence.of_array |> Util.seq_zipi |> Sequence.filter (fun (idx,lit) -> eligible idx lit) |> Sequence.flat_map_l (fun (lit_idx,lit) -> match lit with @@ -576,8 +577,10 @@ module Make(E : Env.S) : S with module Env = E = struct module VarTermMultiMap = CCMultiMap.Make (TVar) (Term) module VTbl = CCHashtbl.Make(TVar) - (* Purify variables with different arguments. - g X = X a \/ X a = b becomes g X = Y a \/ Y a = b \/ X != Y. + (* Purify variables + - if they occur applied and unapplied ("int" mode). + - if they occur with differen argumetns ("ext" mode). + Example: g X = X a \/ X a = b becomes g X = Y a \/ Y a = b \/ X != Y. Literals with only a variable on both sides are not affected. *) let purify_applied_variable c = (* set of new literals *) @@ -606,12 +609,32 @@ module Make(E : Env.S) : S with module Env = E = struct T.Tbl.add cache_replacement_ t v; v in + (* We make the variables of two (variable-headed) terms different if they are + in different classes. + For extensional variable purification, two terms are only in the same class + if they are identical. + For intensional variable purification, two terms are in the same class if + they are both unapplied variables or both applied variables. *) + let same_class t1 t2 = + assert (T.is_var (fst (T.as_app t1))); + assert (T.is_var (fst (T.as_app t2))); + if !_purify_applied_vars == `Ext + then + t1 = t2 + else ( + assert (!_purify_applied_vars == `Int); + match T.view t1, T.view t2 with + | T.Var x, T.Var y when x=y -> true + | T.App (f, _), T.App (g, _) when f=g -> true + | _ -> false + ) + in (* Term should not be purified if - this is the first term we encounter with this variable as head or - it is equal to the first term encountered with this variable as head *) let should_purify t v = try - if t = VTbl.find cache_untouched_ v then ( + if same_class t (VTbl.find cache_untouched_ v) then ( Util.debugf ~section 5 "Leaving untouched: %a" (fun k->k T.pp t);false @@ -679,13 +702,13 @@ module Make(E : Env.S) : S with module Env = E = struct let extensionality_clause = let diff_id = ID.make("zf_ext_diff") in ID.set_payload diff_id (ID.Attr_skolem (ID.K_normal, 2)); (* make the arguments of diff mandatory *) - let alpha = Type.var (HVar.fresh ~ty:Type.tType ()) in - let beta = Type.var (HVar.fresh ~ty:Type.tType ()) in + let alpha = Type.var (HVar.make ~ty:Type.tType 0) in + let beta = Type.var (HVar.make ~ty:Type.tType 1) in let alpha_to_beta = Type.arrow [alpha] beta in let diff_type = Type.arrow [alpha_to_beta; alpha_to_beta] alpha in let diff = Term.const ~ty:diff_type diff_id in - let x = Term.var (HVar.make ~ty:alpha_to_beta 0) in - let y = Term.var (HVar.make ~ty:alpha_to_beta 1) in + let x = Term.var (HVar.make ~ty:alpha_to_beta 2) in + let y = Term.var (HVar.make ~ty:alpha_to_beta 3) in let x_diff = Term.app x [Term.app diff [x; y]] in let y_diff = Term.app y [Term.app diff [x; y]] in let lits = [Literal.mk_eq x y; Literal.mk_neq x_diff y_diff] in @@ -722,7 +745,7 @@ module Make(E : Env.S) : S with module Env = E = struct | mode -> Env.add_unary_inf "ho_prim_enum" (prim_enum ~mode); end; - if !_purify_applied_vars then + if !_purify_applied_vars != `None then Env.add_unary_simplify purify_applied_variable; if !_ext_axiom then Env.ProofState.PassiveSet.add (Sequence.singleton extensionality_clause); @@ -807,6 +830,11 @@ let eta_opt = let l = [ "reduce", `Reduce; "expand", `Expand; "none", `None] in Arg.Symbol (List.map fst l, fun s -> set_ (List.assoc s l)) +let purify_opt = + let set_ n = _purify_applied_vars := n in + let l = [ "ext", `Ext; "int", `Int; "none", `None] in + Arg.Symbol (List.map fst l, fun s -> set_ (List.assoc s l)) + let () = Options.add_opts [ "--ho", Arg.Set enabled_, " enable HO reasoning"; @@ -818,7 +846,9 @@ let () = "--ho-prim-enum", set_prim_mode_, " set HO primitive enum mode"; "--ho-prim-max", Arg.Set_int prim_max_penalty, " max penalty for HO primitive enum"; "--ho-eta", eta_opt, " eta-expansion/reduction"; - "--ho-purify", Arg.Set _purify_applied_vars, " enable purification of applied variables"; + "--ho-purify", purify_opt, " enable purification of applied variables: 'ext' purifies" ^ + " whenever a variable is applied to different arguments." ^ + " 'int' purifies whenever a variable appears applied and unapplied."; "--ho-general-ext-pos", Arg.Set _general_ext_pos, " enable general positive extensionality rule"; "--ho-ext-axiom", Arg.Set _ext_axiom, " enable extensionality axiom"; "--ho-no-ext-pos", Arg.Clear _ext_pos, " disable positive extensionality rule"; diff --git a/src/prover/calculi/Higher_order.mli b/src/prover_calculi/Higher_order.mli similarity index 94% rename from src/prover/calculi/Higher_order.mli rename to src/prover_calculi/Higher_order.mli index 9cdbd0364..82eee0a7d 100644 --- a/src/prover/calculi/Higher_order.mli +++ b/src/prover_calculi/Higher_order.mli @@ -2,6 +2,7 @@ (* This file is free software, part of Zipperposition. See file "license" for more details. *) (** {1 HO} *) +open Libzipperposition module type S = sig module Env : Env.S diff --git a/src/prover/calculi/Rewriting.ml b/src/prover_calculi/Rewriting.ml similarity index 99% rename from src/prover/calculi/Rewriting.ml rename to src/prover_calculi/Rewriting.ml index 362c5094d..6cfdb5341 100644 --- a/src/prover/calculi/Rewriting.ml +++ b/src/prover_calculi/Rewriting.ml @@ -4,6 +4,7 @@ (** {1 Rewriting} *) open Logtk +open Libzipperposition module T = Term module RW = Rewrite diff --git a/src/prover/calculi/Rewriting.mli b/src/prover_calculi/Rewriting.mli similarity index 92% rename from src/prover/calculi/Rewriting.mli rename to src/prover_calculi/Rewriting.mli index 44ccee94e..5e420e9f4 100644 --- a/src/prover/calculi/Rewriting.mli +++ b/src/prover_calculi/Rewriting.mli @@ -4,6 +4,7 @@ (** {1 Rewriting} Deal with definitions as rewrite rules *) +open Libzipperposition module Make(E : Env_intf.S) : sig val setup : ?ctx_narrow:bool -> has_rw:bool -> unit -> unit diff --git a/src/prover/calculi/avatar.ml b/src/prover_calculi/avatar.ml similarity index 99% rename from src/prover/calculi/avatar.ml rename to src/prover_calculi/avatar.ml index f84c5fe40..54c50a357 100644 --- a/src/prover/calculi/avatar.ml +++ b/src/prover_calculi/avatar.ml @@ -4,6 +4,7 @@ (** {1 Basic Splitting à la Avatar} *) open Logtk +open Libzipperposition module T = Term module Lit = Literal @@ -442,9 +443,9 @@ module Make(E : Env.S)(Sat : Sat_solver.S) let add_imply (l:cut_res list) (res:cut_res) (p:Proof.Step.t): unit = let c = res.cut_lit :: List.map (fun cut -> BLit.neg cut.cut_lit) l in - Util.debugf ~section 3 - "(@[<2>add_imply@ :premises (@[%a@])@ :concl %a@ :proof %a@])" - (fun k->k (Util.pp_list pp_cut_res) l pp_cut_res res Proof.Step.pp p); + Util.debugf ~section 3 + "(@[<2>add_imply@ :premises (@[%a@])@ :concl %a@ :proof %a@])" + (fun k->k (Util.pp_list pp_cut_res) l pp_cut_res res Proof.Step.pp p); Solver.add_clause ~proof:p c; () diff --git a/src/prover/calculi/avatar.mli b/src/prover_calculi/avatar.mli similarity index 97% rename from src/prover/calculi/avatar.mli rename to src/prover_calculi/avatar.mli index 4172d4cfb..007d7161a 100644 --- a/src/prover/calculi/avatar.mli +++ b/src/prover_calculi/avatar.mli @@ -13,6 +13,7 @@ *) open Logtk +open Libzipperposition type 'a printer = Format.formatter -> 'a -> unit diff --git a/src/prover/calculi/avatar_intf.ml b/src/prover_calculi/avatar_intf.ml similarity index 99% rename from src/prover/calculi/avatar_intf.ml rename to src/prover_calculi/avatar_intf.ml index d5a122f7f..a9ffb9c63 100644 --- a/src/prover/calculi/avatar_intf.ml +++ b/src/prover_calculi/avatar_intf.ml @@ -2,6 +2,7 @@ (* This file is free software, part of Zipperposition. See file "license" for more details. *) open Logtk +open Libzipperposition module type S = sig module E : Env.S diff --git a/src/prover/calculi/enumTypes.ml b/src/prover_calculi/enumTypes.ml similarity index 99% rename from src/prover/calculi/enumTypes.ml rename to src/prover_calculi/enumTypes.ml index 9bbe3e1a6..9a60e4a22 100644 --- a/src/prover/calculi/enumTypes.ml +++ b/src/prover_calculi/enumTypes.ml @@ -4,6 +4,7 @@ (** {1 Inference and simplification rules for Algebraic types} *) open Logtk +open Libzipperposition module T = Term module S = Subst diff --git a/src/prover/calculi/enumTypes.mli b/src/prover_calculi/enumTypes.mli similarity index 99% rename from src/prover/calculi/enumTypes.mli rename to src/prover_calculi/enumTypes.mli index 96e63a913..2e4584090 100644 --- a/src/prover/calculi/enumTypes.mli +++ b/src/prover_calculi/enumTypes.mli @@ -4,6 +4,7 @@ (** {1 Inference and simplification rules for "Enum Types"} *) open Logtk +open Libzipperposition type term = Term.t diff --git a/src/prover/calculi/fool.ml b/src/prover_calculi/fool.ml similarity index 99% rename from src/prover/calculi/fool.ml rename to src/prover_calculi/fool.ml index 016257c28..56ec6de3d 100644 --- a/src/prover/calculi/fool.ml +++ b/src/prover_calculi/fool.ml @@ -4,6 +4,7 @@ (** {1 boolean subterms} *) open Logtk +open Libzipperposition module T = Term diff --git a/src/prover/calculi/fool.mli b/src/prover_calculi/fool.mli similarity index 96% rename from src/prover/calculi/fool.mli rename to src/prover_calculi/fool.mli index 4bad2d69d..11b6fdcd1 100644 --- a/src/prover/calculi/fool.mli +++ b/src/prover_calculi/fool.mli @@ -5,6 +5,7 @@ open Logtk +open Libzipperposition type term = Term.t diff --git a/src/prover/calculi/heuristics.ml b/src/prover_calculi/heuristics.ml similarity index 75% rename from src/prover/calculi/heuristics.ml rename to src/prover_calculi/heuristics.ml index 9ba65c635..3ee33c61a 100644 --- a/src/prover/calculi/heuristics.ml +++ b/src/prover_calculi/heuristics.ml @@ -4,12 +4,14 @@ (** {1 Heuristics} *) open Logtk +open Libzipperposition module T = Term module Lit = Literal let depth_limit_ = ref None let max_vars = ref 10 +let no_max_vars = ref false let enable_depth_limit i = if i <= 0 then invalid_arg "Heuristics.enable_depth_limit"; @@ -59,20 +61,24 @@ module Make(E : Env.S) = struct ) else false let has_too_many_vars c = - let lits = C.lits c in - (* number of distinct term variables *) - let n_vars = - Literals.vars lits - |> List.filter (fun v -> not (Type.is_tType (HVar.ty v))) - |> List.length - in - if n_vars > !max_vars then ( - Ctx.lost_completeness(); - Util.incr_stat stat_vars; - Util.debugf ~section 5 "@[<2>clause dismissed (%d vars is too much):@ @[%a@]@]" - (fun k->k n_vars C.pp c); - true - ) else false + if !no_max_vars + then false + else ( + let lits = C.lits c in + (* number of distinct term variables *) + let n_vars = + Literals.vars lits + |> List.filter (fun v -> not (Type.is_tType (HVar.ty v))) + |> List.length + in + if n_vars > !max_vars then ( + Ctx.lost_completeness(); + Util.incr_stat stat_vars; + Util.debugf ~section 5 "@[<2>clause dismissed (%d vars is too much):@ @[%a@]@]" + (fun k->k n_vars C.pp c); + true + ) else false + ) let register () = Util.debug ~section 2 "register heuristics..."; @@ -95,6 +101,6 @@ let () = Params.add_opts [ "--depth-limit", Arg.Int enable_depth_limit, " set maximal term depth"; "--max-vars", Arg.Set_int max_vars, " maximum number of variables per clause"; + "--no-max-vars", Arg.Set no_max_vars, " disable maximum number of variables per clause"; ]; () - diff --git a/src/prover/calculi/heuristics.mli b/src/prover_calculi/heuristics.mli similarity index 96% rename from src/prover/calculi/heuristics.mli rename to src/prover_calculi/heuristics.mli index 1e4897c7d..091acdfc6 100644 --- a/src/prover/calculi/heuristics.mli +++ b/src/prover_calculi/heuristics.mli @@ -3,7 +3,7 @@ (** {1 Heuristics} *) -open Logtk +open Libzipperposition val enable_depth_limit : int -> unit (** Set a maximal depth for terms. Any clause with a term deeper than diff --git a/src/prover/calculi/ind_types.ml b/src/prover_calculi/ind_types.ml similarity index 99% rename from src/prover/calculi/ind_types.ml rename to src/prover_calculi/ind_types.ml index df5bacbbd..3d22fabad 100644 --- a/src/prover/calculi/ind_types.ml +++ b/src/prover_calculi/ind_types.ml @@ -2,6 +2,7 @@ (* This file is free software, part of Zipperposition. See file "license" for more details. *) open Logtk +open Libzipperposition module Lits = Literals module T = Term diff --git a/src/prover/calculi/ind_types.mli b/src/prover_calculi/ind_types.mli similarity index 98% rename from src/prover/calculi/ind_types.mli rename to src/prover_calculi/ind_types.mli index 890079cdd..df21ac5b1 100644 --- a/src/prover/calculi/ind_types.mli +++ b/src/prover_calculi/ind_types.mli @@ -33,6 +33,8 @@ [t = cstor1(…) | … | t = cstor_n(…)] with fresh sub-constants in the […]. *) + +open Libzipperposition module Make(E : Env_intf.S) : sig val setup : unit -> unit diff --git a/src/prover/calculi/induction.ml b/src/prover_calculi/induction.ml similarity index 99% rename from src/prover/calculi/induction.ml rename to src/prover_calculi/induction.ml index cc5997e4a..89a81a194 100644 --- a/src/prover/calculi/induction.ml +++ b/src/prover_calculi/induction.ml @@ -4,6 +4,7 @@ (** {1 Induction through Cut} *) open Logtk +open Libzipperposition module Lits = Literals module T = Term @@ -968,7 +969,7 @@ module Make | T_view.T_app_defined (_,c,l) -> let pos = RW.Defined_cst.defined_positions c in Sequence.of_list l - |> Sequence.zip_i |> Sequence.zip + |> Util.seq_zipi |> Sequence.diagonal |> Sequence.filter_map (fun ((i1,t1),(i2,t2)) -> @@ -1187,8 +1188,8 @@ module Make let cut = A.introduce_cut ~penalty ~depth (Goal.form goal) proof ~reason:Fmt.(fun out () -> fprintf out - "(@[prove_ind@ :clauses (@[%a@])@ :on (@[%a@])@])" - (Util.pp_list C.pp) clauses pp_csts generalize_on) + "(@[prove_ind@ :clauses (@[%a@])@ :on (@[%a@])@])" + (Util.pp_list C.pp) clauses pp_csts generalize_on) in A.add_lemma cut )) diff --git a/src/prover/calculi/induction.mli b/src/prover_calculi/induction.mli similarity index 92% rename from src/prover/calculi/induction.mli rename to src/prover_calculi/induction.mli index eda1ccb44..56875d195 100644 --- a/src/prover/calculi/induction.mli +++ b/src/prover_calculi/induction.mli @@ -3,6 +3,8 @@ (** {1 Induction through Cut} *) +open Libzipperposition + module type S = Induction_intf.S module Make diff --git a/src/prover/calculi/induction_intf.ml b/src/prover_calculi/induction_intf.ml similarity index 91% rename from src/prover/calculi/induction_intf.ml rename to src/prover_calculi/induction_intf.ml index bcf4ca2c3..ee4eaa6ed 100644 --- a/src/prover/calculi/induction_intf.ml +++ b/src/prover_calculi/induction_intf.ml @@ -3,6 +3,8 @@ (** {2 Induction} *) +open Libzipperposition + module type S = sig module Env : Env.S diff --git a/src/prover_calculi/jbuild b/src/prover_calculi/jbuild new file mode 100644 index 000000000..f2cd66425 --- /dev/null +++ b/src/prover_calculi/jbuild @@ -0,0 +1,19 @@ +; vim:ft=lisp: + +(jbuild_version 1) + +; main lib +(library + ((name libzipperposition_calculi) + (public_name libzipperposition.calculi) + (synopsis "calculi for the Zipperposition theorem prover") + (libraries (libzipperposition)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -bin-annot + -unbox-closures -unbox-closures-factor 20)) + )) + + + + + diff --git a/src/prover_calculi/libzipperposition_calculi.mld b/src/prover_calculi/libzipperposition_calculi.mld new file mode 100644 index 000000000..4f0a3bcb8 --- /dev/null +++ b/src/prover_calculi/libzipperposition_calculi.mld @@ -0,0 +1,7 @@ + +Superposition calculus (in {!Libzipperposition_calculi.Superposition}) +and other calculi for Zipperposition. A calculus is a set of inference rules +and simplification rules. + +{!modules: Libzipperposition_calculi} + diff --git a/src/prover/lib/simplex.ml b/src/prover_calculi/simplex.ml similarity index 100% rename from src/prover/lib/simplex.ml rename to src/prover_calculi/simplex.ml diff --git a/src/prover/lib/simplex.mli b/src/prover_calculi/simplex.mli similarity index 100% rename from src/prover/lib/simplex.mli rename to src/prover_calculi/simplex.mli diff --git a/src/prover/calculi/superposition.ml b/src/prover_calculi/superposition.ml similarity index 95% rename from src/prover/calculi/superposition.ml rename to src/prover_calculi/superposition.ml index 11537494a..491b91f85 100644 --- a/src/prover/calculi/superposition.ml +++ b/src/prover_calculi/superposition.ml @@ -2,6 +2,7 @@ (* This file is free software, part of Zipperposition. See file "license" for more details. *) open Logtk +open Libzipperposition module BV = CCBV module T = Term @@ -96,7 +97,7 @@ module Make(Env : Env.S) : S with module Env = Env = struct ~eligible:(C.Eligible.res c) (C.lits c) |> Sequence.filter (fun (t, _) -> not (T.is_var t) || T.is_ho_var t) (* TODO: could exclude more variables from the index: - they are not needed if they occur with the same args everywhere in the clause *) + they are not needed if they occur with the same args everywhere in the clause *) |> Sequence.fold (fun tree (t, pos) -> let with_pos = C.WithPos.({term=t; pos; clause=c;}) in @@ -207,22 +208,22 @@ module Make(Env : Env.S) : S with module Env = Env = struct && Array.length t_args >= List.length args (* Check whether the last argument(s) of s and t are equal *) && Array.sub s_args (Array.length s_args - List.length args) (List.length args) = - Array.sub t_args (Array.length t_args - List.length args) (List.length args) + Array.sub t_args (Array.length t_args - List.length args) (List.length args) (* Check whether they are all variables that occur nowhere else *) && CCList.(Array.length s_args - List.length args --^ Array.length s_args) |> List.for_all (fun idx -> - match T.as_var (Array.get s_args idx) with + match T.as_var (Array.get s_args idx) with | Some v -> (* Check whether variable occurs in previous arguments: *) not (CCArray.exists (T.var_occurs ~var:v) (Array.sub s_args 0 idx)) && not (CCArray.exists (T.var_occurs ~var:v) (Array.sub t_args 0 (Array.length t_args - List.length args)) - (* Check whether variable occurs in heads: *) - && not (T.var_occurs ~var:v f) - && not (T.var_occurs ~var:v g) - (* Check whether variable occurs in other literals: *) - && not (List.exists (Literal.var_occurs v) (CCArray.except_idx (C.lits info.active) active_idx))) + (* Check whether variable occurs in heads: *) + && not (T.var_occurs ~var:v f) + && not (T.var_occurs ~var:v g) + (* Check whether variable occurs in other literals: *) + && not (List.exists (Literal.var_occurs v) (CCArray.except_idx (C.lits info.active) active_idx))) | None -> false - ) + ) then (* Calculate the part of t that unifies with the variable *) let t_prefix = T.app g (Array.to_list (Array.sub t_args 0 (Array.length t_args - List.length args))) in @@ -278,7 +279,7 @@ module Make(Env : Env.S) : S with module Env = Env = struct (* Check whether Cσ is >= C[var -> replacement]σ *) let passive'_lits = Lits.apply_subst renaming subst (C.lits info.passive, info.scope_passive) in let subst_t = Unif.FO.update subst (T.as_var_exn var, info.scope_passive) (replacement, info.scope_active) in - let passive_t'_lits = Lits.apply_subst renaming subst_t (C.lits info.passive, info.scope_passive) in + let passive_t'_lits = Lits.apply_subst renaming subst_t (C.lits info.passive, info.scope_passive) in if Lits.compare_multiset ~ord passive'_lits passive_t'_lits = Comp.Gt then ( Util.debugf ~section 5 @@ -343,13 +344,13 @@ module Make(Env : Env.S) : S with module Env = Env = struct if not !_sup_at_vars then assert (not (T.is_var info.u_p)) else if T.is_var info.u_p && not (sup_at_var_condition info info.u_p info.t) then - raise (ExitSuperposition "superposition at variable"); + raise (ExitSuperposition "superposition at variable"); (* Check for hidden superposition at a variable *) if !_restrict_hidden_sup_at_vars then ( match is_hidden_sup_at_var info with | Some (var,replacement) when not (sup_at_var_condition info var replacement) - -> raise (ExitSuperposition "hidden superposition at variable") - | _ -> () + -> raise (ExitSuperposition "hidden superposition at variable") + | _ -> () ); (* ordering constraints are ok *) let lits_a = CCArray.except_idx (C.lits info.active) active_idx in @@ -445,39 +446,39 @@ module Make(Env : Env.S) : S with module Env = Env = struct raise (ExitSuperposition "superposition at variable"); (* Check for hidden superposition at a variable *) match is_hidden_sup_at_var info with - | Some (var,replacement) when not (sup_at_var_condition info var replacement) - -> raise (ExitSuperposition "hidden superposition at variable") - | _ -> (); - (* ordering constraints are ok, build new active lits (excepted s=t) *) - let lits_a = CCArray.except_idx (C.lits info.active) active_idx in - let lits_a = Lit.apply_subst_list renaming subst (lits_a, sc_a) in - (* build passive literals and replace u|p\sigma with t\sigma *) - let u' = S.FO.apply renaming subst (info.u_p, sc_p) in - assert (Type.equal (T.ty u') (T.ty t')); - let lits_p = Array.to_list (C.lits info.passive) in - let lits_p = Lit.apply_subst_list renaming subst (lits_p, sc_p) in - (* assert (T.equal (Lits.Pos.at (Array.of_list lits_p) info.passive_pos) u'); *) - let lits_p = List.map (Lit.map (fun t-> T.replace t ~old:u' ~by:t')) lits_p in - let c_guard = Literal.of_unif_subst renaming us in - let tags = Unif_subst.tags us in - (* build clause *) - let new_lits = c_guard @ lits_a @ lits_p in - let rule = - let name = if Lit.sign passive_lit' then "s_sup+" else "s_sup-" in - Proof.Rule.mk name - in - let proof = - Proof.Step.inference ~rule ~tags - [C.proof_parent_subst renaming (info.active,sc_a) subst; - C.proof_parent_subst renaming (info.passive,sc_p) subst] - and penalty = - C.penalty info.active - + C.penalty info.passive - + (if T.is_var s' then 2 else 0) (* superposition from var = bad *) - in - let new_clause = C.create ~trail:new_trail ~penalty new_lits proof in - Util.debugf ~section 3 "@[... ok, conclusion@ @[%a@]@]" (fun k->k C.pp new_clause); - new_clause :: acc + | Some (var,replacement) when not (sup_at_var_condition info var replacement) + -> raise (ExitSuperposition "hidden superposition at variable") + | _ -> (); + (* ordering constraints are ok, build new active lits (excepted s=t) *) + let lits_a = CCArray.except_idx (C.lits info.active) active_idx in + let lits_a = Lit.apply_subst_list renaming subst (lits_a, sc_a) in + (* build passive literals and replace u|p\sigma with t\sigma *) + let u' = S.FO.apply renaming subst (info.u_p, sc_p) in + assert (Type.equal (T.ty u') (T.ty t')); + let lits_p = Array.to_list (C.lits info.passive) in + let lits_p = Lit.apply_subst_list renaming subst (lits_p, sc_p) in + (* assert (T.equal (Lits.Pos.at (Array.of_list lits_p) info.passive_pos) u'); *) + let lits_p = List.map (Lit.map (fun t-> T.replace t ~old:u' ~by:t')) lits_p in + let c_guard = Literal.of_unif_subst renaming us in + let tags = Unif_subst.tags us in + (* build clause *) + let new_lits = c_guard @ lits_a @ lits_p in + let rule = + let name = if Lit.sign passive_lit' then "s_sup+" else "s_sup-" in + Proof.Rule.mk name + in + let proof = + Proof.Step.inference ~rule ~tags + [C.proof_parent_subst renaming (info.active,sc_a) subst; + C.proof_parent_subst renaming (info.passive,sc_p) subst] + and penalty = + C.penalty info.active + + C.penalty info.passive + + (if T.is_var s' then 2 else 0) (* superposition from var = bad *) + in + let new_clause = C.create ~trail:new_trail ~penalty new_lits proof in + Util.debugf ~section 3 "@[... ok, conclusion@ @[%a@]@]" (fun k->k C.pp new_clause); + new_clause :: acc with ExitSuperposition reason -> Util.debugf ~section 3 "@[... cancel, %s@]" (fun k->k reason); acc @@ -756,7 +757,7 @@ module Make(Env : Env.S) : S with module Env = Env = struct (O.compare ord (S.FO.apply Subst.Renaming.none subst (l,cur_sc)) (S.FO.apply Subst.Renaming.none subst (r,cur_sc)) = Comp.Gt) - (* subst(l) > subst(r) and restriction does not apply, we can rewrite *) + (* subst(l) > subst(r) and restriction does not apply, we can rewrite *) then ( Util.debugf ~section 5 "@[demod:@ @[t=%a[%d],@ l=%a[%d],@ r=%a[%d]@],@ subst=@[%a@]@]" @@ -876,12 +877,11 @@ module Make(Env : Env.S) : S with module Env = Env = struct in (* demodulate every literal *) let lits = Array.mapi demod_lit (C.lits c) in - if Lits.equal_com (C.lits c) lits - then ( + if CCList.is_empty st.demod_clauses then ( (* no rewriting performed *) SimplM.return_same c ) else ( - assert (not (CCList.is_empty st.demod_clauses)); + assert (not (Lits.equal_com lits (C.lits c))); (* construct new clause *) st.demod_clauses <- CCList.uniq ~eq:eq_c_subst st.demod_clauses; let proof = @@ -1097,15 +1097,11 @@ module Make(Env : Env.S) : S with module Env = Env = struct ) ) - let is_distinct_ id = - let s = ID.name id in - String.length s > 2 && s.[0] = '"' && s.[String.length s-1] = '"' - let handle_distinct_constants lit = match lit with | Lit.Equation (l, r, sign) when T.is_const l && T.is_const r -> let s1 = T.head_exn l and s2 = T.head_exn r in - if is_distinct_ s1 && is_distinct_ s2 + if ID.is_distinct_object s1 && ID.is_distinct_object s2 then if sign = (ID.equal s1 s2) then Some (Lit.mk_tauto,[],[Proof.Tag.T_distinct]) (* "a" = "a", or "a" != "b" *) diff --git a/src/prover/calculi/superposition.mli b/src/prover_calculi/superposition.mli similarity index 97% rename from src/prover/calculi/superposition.mli rename to src/prover_calculi/superposition.mli index 8d740aa68..2ce921164 100644 --- a/src/prover/calculi/superposition.mli +++ b/src/prover_calculi/superposition.mli @@ -4,6 +4,7 @@ (** {1 Inference and simplification rules for the superposition calculus} *) open Logtk +open Libzipperposition (** {2 Inference rules} *) diff --git a/src/prover/calculi/superposition_intf.ml b/src/prover_calculi/superposition_intf.ml similarity index 99% rename from src/prover/calculi/superposition_intf.ml rename to src/prover_calculi/superposition_intf.ml index 8a39f9bd2..d594809e7 100644 --- a/src/prover/calculi/superposition_intf.ml +++ b/src/prover_calculi/superposition_intf.ml @@ -2,6 +2,7 @@ (* This file is free software, part of Zipperposition. See file "license" for more details. *) open Logtk +open Libzipperposition module type S = sig module Env : Env.S diff --git a/src/prover_phases/jbuild b/src/prover_phases/jbuild new file mode 100644 index 000000000..ccdf633d8 --- /dev/null +++ b/src/prover_phases/jbuild @@ -0,0 +1,20 @@ +; vim:ft=lisp: + +(jbuild_version 1) + +; main lib +(library + ((name libzipperposition_phases) + (public_name libzipperposition.phases) + (synopsis "main for the Zipperposition theorem prover") + (libraries (libzipperposition libzipperposition.calculi)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -bin-annot + -unbox-closures -unbox-closures-factor 20)) + )) + + + + + + diff --git a/src/prover_phases/libzipperposition_phases.ml b/src/prover_phases/libzipperposition_phases.ml new file mode 100644 index 000000000..686c12cac --- /dev/null +++ b/src/prover_phases/libzipperposition_phases.ml @@ -0,0 +1,14 @@ + +(* This file is free software, part of Zipperposition. See file "license" for more details. *) + +module Phases = Phases +module Phases_impl = Phases_impl + +let main_cli ?setup_gc () = + Phases.run (Phases_impl.main_cli ?setup_gc ()) + |> CCResult.map snd + +let main ?setup_gc ?params file = + Phases.run (Phases_impl.main ?setup_gc ?params file) + |> CCResult.map snd + diff --git a/src/prover_phases/libzipperposition_phases.mld b/src/prover_phases/libzipperposition_phases.mld new file mode 100644 index 000000000..ab70d78e5 --- /dev/null +++ b/src/prover_phases/libzipperposition_phases.mld @@ -0,0 +1,5 @@ + +Main procedure of Zipperposition, as a series of steps that are articulated in +a type-safe way. + +{!modules: Libzipperposition_phases} diff --git a/src/prover_phases/libzipperposition_phases.mli b/src/prover_phases/libzipperposition_phases.mli new file mode 100644 index 000000000..e2729072c --- /dev/null +++ b/src/prover_phases/libzipperposition_phases.mli @@ -0,0 +1,17 @@ + +(* This file is free software, part of Zipperposition. See file "license" for more details. *) + +module Phases = Phases +module Phases_impl = Phases_impl + +val main_cli : + ?setup_gc:bool -> + unit -> + Phases.errcode Phases.or_error + +val main : + ?setup_gc:bool -> + ?params:Libzipperposition.Params.t -> + string -> + Phases.errcode Phases.or_error + diff --git a/src/prover/phases.ml b/src/prover_phases/phases.ml similarity index 99% rename from src/prover/phases.ml rename to src/prover_phases/phases.ml index e0217c0a2..e8cd9cf50 100644 --- a/src/prover/phases.ml +++ b/src/prover_phases/phases.ml @@ -4,6 +4,7 @@ (** {1 Phases of the Prover} *) open Logtk +open Libzipperposition module E = CCResult type filename = string diff --git a/src/prover/phases.mli b/src/prover_phases/phases.mli similarity index 99% rename from src/prover/phases.mli rename to src/prover_phases/phases.mli index 363f16b9c..06957fc73 100644 --- a/src/prover/phases.mli +++ b/src/prover_phases/phases.mli @@ -7,6 +7,7 @@ are used to build values. This module reifies the phases. *) open Logtk +open Libzipperposition type filename = string type 'a or_error = ('a, string) CCResult.t diff --git a/src/prover/phases_impl.ml b/src/prover_phases/phases_impl.ml similarity index 88% rename from src/prover/phases_impl.ml rename to src/prover_phases/phases_impl.ml index d70b1d259..ac13df577 100644 --- a/src/prover/phases_impl.ml +++ b/src/prover_phases/phases_impl.ml @@ -6,7 +6,7 @@ open Logtk open Logtk_parsers open Logtk_proofs -open Params +open Libzipperposition open Phases.Infix @@ -27,7 +27,7 @@ let setup_alarm timeout = (* TODO: move into Zipperposition *) let print_version ~params = - if params.param_version then ( + if params.Params.version then ( Format.printf "zipperposition %s@." Const.version; exit 0 ) @@ -37,6 +37,7 @@ let print_version ~params = FIXME: still too global? *) (* TODO: just use a list, not "register" *) let load_extensions = + let open Libzipperposition_calculi in Phases.start_phase Phases.LoadExtensions >>= fun () -> Extensions.register Superposition.extension; Extensions.register AC.extension; @@ -72,7 +73,7 @@ let start_file file = let parse_prelude (params:Params.t) = Phases.start_phase Phases.Parse_prelude >>= fun () -> - let prelude_files = params.Params.param_prelude in + let prelude_files = params.Params.prelude in let res = if CCVector.is_empty prelude_files then CCResult.return Sequence.empty @@ -101,7 +102,7 @@ let parse_file file = let typing ~file prelude (input,stmts) = Phases.start_phase Phases.Typing >>= fun () -> Phases.get_key Params.key >>= fun params -> - let def_as_rewrite = params.Params.param_def_as_rewrite in + let def_as_rewrite = params.Params.def_as_rewrite in TypeInference.infer_statements ~on_var:(Input_format.on_var input) ~on_undef:(Input_format.on_undef_id input) @@ -159,12 +160,12 @@ let compute_prec stmts = let compute_ord_select precedence = Phases.start_phase Phases.Compute_ord_select >>= fun () -> Phases.get_key Params.key >>= fun params -> - let ord = Ordering.by_name params.param_ord precedence in + let ord = Ordering.by_name params.Params.ord precedence in Util.debugf ~section 2 "@[<2>ordering %s@]" (fun k->k (Ordering.name ord)); - let select = Selection.from_string ~ord params.param_select in + let select = Selection.from_string ~ord params.Params.select in do_extensions ~field:(fun e->e.Extensions.ord_select_actions) ~x:(ord,select) >>= fun () -> - Util.debugf ~section 2 "@[<2>selection function:@ %s@]" (fun k->k params.param_select); + Util.debugf ~section 2 "@[<2>selection function:@ %s@]" (fun k->k params.Params.select); Phases.return_phase (ord, select) let make_ctx ~signature ~ord ~select () = @@ -217,7 +218,7 @@ let print_stats_env (type c) (module Env : Env.S with type C.t = c) = Format.printf "%sproof state stats: {active %d, passive %d, simpl %d}@." comment num_active num_passive num_simpl; in - if Env.params.param_stats then ( + if Env.params.Params.stats then ( print_hashcons_stats "terms" (InnerTerm.hashcons_stats ()); print_state_stats (Env.stats ()); ) @@ -237,7 +238,7 @@ let print_stats () = stats.Gc.minor_collections stats.Gc.major_collections; in Phases.get_key Params.key >>= fun params -> - if params.Params.param_stats then ( + if params.Params.stats then ( print_gc (); Util.print_global_stats ~comment (); ); @@ -250,7 +251,7 @@ let presaturate_clauses (type c) Phases.start_phase Phases.Pre_saturate >>= fun () -> let module Sat = Saturate.Make(Env) in let num_clauses = CCVector.length c_sets.Clause.c_set in - if Env.params.param_presaturate + if Env.params.Params.presaturate then ( Util.debug ~section 1 "presaturate initial clauses"; Env.add_passive (CCVector.to_seq c_sets.Clause.c_set); @@ -279,19 +280,19 @@ let try_to_refute (type c) (module Env : Env.S with type C.t = c) clauses result ); Env.add_active (CCVector.to_seq clauses.Clause.c_sos); Env.add_passive (CCVector.to_seq clauses.Clause.c_set); - let steps = if Env.params.param_steps < 0 + let steps = if Env.params.Params.steps < 0 then None else ( - Util.debugf ~section 1 "run for %d steps" (fun k->k Env.params.param_steps); - Some Env.params.param_steps + Util.debugf ~section 1 "run for %d steps" (fun k->k Env.params.Params.steps); + Some Env.params.Params.steps ) - and timeout = if Env.params.param_timeout = 0. + and timeout = if Env.params.Params.timeout = 0. then None else ( - Util.debugf ~section 1 "run for %.3f s" (fun k->k Env.params.param_timeout); + Util.debugf ~section 1 "run for %.3f s" (fun k->k Env.params.Params.timeout); (* FIXME: only do that for zipperposition, not the library? *) - ignore (setup_alarm Env.params.param_timeout); - Some (Util.total_time_s () +. Env.params.param_timeout -. 0.25) + ignore (setup_alarm Env.params.Params.timeout); + Some (Util.total_time_s () +. Env.params.Params.timeout -. 0.25) ) in Signal.send Env.on_start (); @@ -312,12 +313,12 @@ let print_dots (type c) Phases.start_phase Phases.Print_dot >>= fun () -> Signal.send Signals.on_dot_output (); (* see if we need to print proof state *) - begin match Env.params.param_dot_file, result with + begin match Env.params.Params.dot_file, result with | Some dot_f, Saturate.Unsat proof -> let name = "unsat_graph" in (* print proof of false *) let proof = - if Env.params.param_dot_all_roots + if Env.params.Params.dot_all_roots then Env.(Sequence.append (get_active()) (get_passive())) |> Sequence.filter_map @@ -328,7 +329,7 @@ let print_dots (type c) else Sequence.singleton proof in Proof.S.pp_dot_seq_file ~name dot_f proof - | Some dot_f, (Saturate.Sat | Saturate.Unknown) when Env.params.param_dot_sat -> + | Some dot_f, (Saturate.Sat | Saturate.Unknown) when Env.params.Params.dot_sat -> (* print saturated set *) let name = "sat_set" in let seq = Sequence.append (Env.get_active ()) (Env.get_passive ()) in @@ -398,13 +399,13 @@ let parse_cli = CCFormat.set_color_default true; (* parse arguments *) let params = Params.parse_args () in - let files = CCVector.to_list Params.files in + let files = CCVector.to_list params.Params.files in Phases.set_key Params.key params >>= fun () -> print_version ~params; Phases.return_phase (files, params) (* Process the given file (try to solve it) *) -let process_file (prelude:Phases.prelude) file = +let process_file ?(prelude=Sequence.empty) file = start_file file >>= fun () -> parse_file file >>= fun stmts -> typing ~file prelude stmts >>= fun decls -> @@ -446,23 +447,25 @@ let check res = Phases.get_key Params.key >>= fun params -> let comment = Options.comment() in let errcode = match res with - | Saturate.Unsat p when params.Params.param_check -> + | Saturate.Unsat p when params.Params.check -> (* check proof! *) Util.debug ~section 1 "start checking proof…"; let p' = LLProof_conv.conv p in - (* print proof? *) - begin match params.Params.param_dot_llproof with - | None -> () - | Some file -> - Util.debugf ~section 2 "print LLProof into `%s`"(fun k->k file); - LLProof.Dot.pp_dot_file file p'; - end; (* check *) let start = Util.total_time_s () in - let res, stats = LLProof_check.check p' in + let dot_prefix = params.Params.dot_check in + let res, stats = LLProof_check.check ?dot_prefix p' in let stop = Util.total_time_s () in Format.printf "%s(@[proof_check@ :res %a@ :stats %a :time %.3fs@])@." comment LLProof_check.pp_res res LLProof_check.pp_stats stats (stop-.start); + (* print proof? (do it after check, results are cached) *) + begin match params.Params.dot_llproof with + | None -> () + | Some file -> + Util.debugf ~section 2 "print LLProof into `%s`"(fun k->k file); + LLProof.Dot.pp_dot_file file p'; + end; + (* exit code *) if res = LLProof_check.R_fail then 15 else 0 | _ -> 0 in @@ -492,10 +495,10 @@ let setup_signal = Phases.return_phase () (* process several files, printing the result *) -let process_files_and_print (params:Params.t) files = +let process_files_and_print ?(params=Params.default) files = parse_prelude params >>= fun prelude -> let f file = - process_file prelude file >>= fun (Phases.Env_result (env, res)) -> + process_file ~prelude file >>= fun (Phases.Env_result (env, res)) -> print file env res >>= fun () -> check res in @@ -503,3 +506,29 @@ let process_files_and_print (params:Params.t) files = Phases.run_parallel phases >>= fun r -> print_stats () >>= fun () -> Phases.return r + +let main_cli ?setup_gc:(gc=true) () = + let open Phases.Infix in + (if gc then setup_gc else Phases.return ()) >>= fun () -> + setup_signal >>= fun () -> + parse_cli >>= fun (files, params) -> + load_extensions >>= fun _ -> + process_files_and_print ~params files >>= fun errcode -> + Phases.exit >|= fun () -> + errcode + +let skip_parse_cli ?(params=Params.default) file = + Phases.start_phase Phases.Parse_CLI >>= fun () -> + CCFormat.set_color_default true; + Phases.set_key Params.key params >>= fun () -> + Phases.return_phase ([file], params) + +let main ?setup_gc:(gc=true) ?params file = + let open Phases.Infix in + (if gc then setup_gc else Phases.return ()) >>= fun () -> + (* pseudo-parse *) + skip_parse_cli ?params file >>= fun (files, params) -> + load_extensions >>= fun _ -> + process_files_and_print ~params files >>= fun errcode -> + Phases.exit >|= fun () -> + errcode diff --git a/src/prover/phases_impl.mli b/src/prover_phases/phases_impl.mli similarity index 77% rename from src/prover/phases_impl.mli rename to src/prover_phases/phases_impl.mli index e5f9eeff6..9c1981cb6 100644 --- a/src/prover/phases_impl.mli +++ b/src/prover_phases/phases_impl.mli @@ -5,6 +5,8 @@ See {!Phases} for the list of steps to execute *) +open Libzipperposition + val parse_cli : (Phases.filename list * Params.t, [`Init], [`Parse_cli]) Phases.t (** Parses the file list and parameters, also puts the parameters in @@ -17,7 +19,7 @@ val setup_gc : (unit, [`Init], [`Init]) Phases.t val setup_signal : (unit, [`Init], [`Init]) Phases.t val process_file : - Phases.prelude -> + ?prelude:Phases.prelude -> Phases.filename -> (Phases.env_with_result, [`Parse_prelude], [`Saturate]) Phases.t (** [process_file f] parses [f], does the preprocessing phases, including @@ -36,9 +38,24 @@ val check : (Phases.errcode, [`Print_dot], [`Check_proof]) Phases.t val process_files_and_print : - Params.t -> + ?params:Params.t -> Phases.filename list -> (Phases.errcode, [`LoadExtensions], [`Print_stats]) Phases.t (** Process each file in the list successively, printing the results. *) val print_stats : unit -> (unit, [`Check_proof], [`Print_stats]) Phases.t + +val main_cli : + ?setup_gc:bool -> + unit -> + (Phases.errcode, [`Init], [`Exit]) Phases.t +(** Main for the command-line prover *) + +val main : + ?setup_gc:bool -> + ?params:Params.t -> + string -> (** file *) + (Phases.errcode, [`Init], [`Exit]) Phases.t +(** Main to use from a library *) + +(* TODO: finer-grained APIs *) diff --git a/src/solving/.merlin b/src/solving/.merlin deleted file mode 100644 index d64d369f7..000000000 --- a/src/solving/.merlin +++ /dev/null @@ -1,2 +0,0 @@ -REC -PKG msat diff --git a/src/solving/jbuild b/src/solving/jbuild new file mode 100644 index 000000000..1d630ecdb --- /dev/null +++ b/src/solving/jbuild @@ -0,0 +1,19 @@ + +; vim:ft=lisp: + +(jbuild_version 1) + +; main lib +(library + ((name logtk_solving) + (public_name logtk.solving) + (synopsis "solving constraints") + (optional) + (libraries (containers logtk msat)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -bin-annot + -unbox-closures -unbox-closures-factor 20)) + )) + + + diff --git a/src/solving/libzipperposition_solving.mldylib b/src/solving/libzipperposition_solving.mldylib deleted file mode 100644 index 3336171d8..000000000 --- a/src/solving/libzipperposition_solving.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: dcc3252060a8ada759a6c2f5b4a10814) -Libzipperposition_solving -# OASIS_STOP diff --git a/src/solving/libzipperposition_solving.mllib b/src/solving/libzipperposition_solving.mllib deleted file mode 100644 index 3336171d8..000000000 --- a/src/solving/libzipperposition_solving.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: dcc3252060a8ada759a6c2f5b4a10814) -Libzipperposition_solving -# OASIS_STOP diff --git a/src/solving/libzipperposition_solving.mlpack b/src/solving/libzipperposition_solving.mlpack deleted file mode 100644 index 8471c0fff..000000000 --- a/src/solving/libzipperposition_solving.mlpack +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ee99985f1f7e07a541465139fd83cadc) -Lpo -# OASIS_STOP diff --git a/src/solving/logtk_solving.mldylib b/src/solving/logtk_solving.mldylib deleted file mode 100644 index 138335fb3..000000000 --- a/src/solving/logtk_solving.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 554c708d018168e21407133db0bc5518) -Logtk_solving -# OASIS_STOP diff --git a/src/solving/logtk_solving.mllib b/src/solving/logtk_solving.mllib deleted file mode 100644 index 138335fb3..000000000 --- a/src/solving/logtk_solving.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 554c708d018168e21407133db0bc5518) -Logtk_solving -# OASIS_STOP diff --git a/src/solving/logtk_solving.mlpack b/src/solving/logtk_solving.mlpack deleted file mode 100644 index 8471c0fff..000000000 --- a/src/solving/logtk_solving.mlpack +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ee99985f1f7e07a541465139fd83cadc) -Lpo -# OASIS_STOP diff --git a/src/tools/.merlin b/src/tools/.merlin deleted file mode 100644 index e1f1bac04..000000000 --- a/src/tools/.merlin +++ /dev/null @@ -1,8 +0,0 @@ -REC -PKG msat -PKG qcheck -S orient -S hysteresis -B ../_build/src/tools/ -B ../_build/src/tools/orient/ -B ../_build/src/tools/hysteresis/ diff --git a/src/tools/app_encode.ml b/src/tools/app_encode.ml index 7fc66b685..2c307f112 100644 --- a/src/tools/app_encode.ml +++ b/src/tools/app_encode.ml @@ -99,7 +99,7 @@ let rec app_encode_term toplevel t = | T.Bind (Binder.ForallTy, var, t) -> assert (is_type arg); let arg' = app_encode_ty arg in - let t' = T.Subst.eval (Var.Subst.singleton var arg) t in + let t' = T.Subst.eval (Var.Subst.singleton var arg') t in T.app ~ty:t' term [arg'] | _ -> failwith "Not implemented" ) @@ -154,17 +154,17 @@ let extensionality_axiom = let x = Var.make ~ty:fun_alpha_beta (ID.make "x") in let y = Var.make ~ty:fun_alpha_beta (ID.make "y") in let z = Var.make ~ty:(T.var alpha) (ID.make "z") in - let xz = T.app ~ty:(T.var beta) app_const [T.var x; T.var z] in - let yz = T.app ~ty:(T.var beta) app_const [T.var y; T.var z] in + let xz = T.app ~ty:(T.var beta) app_const [T.var alpha; T.var beta; T.var x; T.var z] in + let yz = T.app ~ty:(T.var beta) app_const [T.var alpha; T.var beta; T.var y; T.var z] in let prop = T.builtin ~ty:T.tType Builtin.Prop in Statement.assert_ ~proof:Proof.Step.trivial (T.bind_list ~ty:prop Binder.forall [x; y] - (T.app_builtin ~ty:prop Builtin.Imply [ - T.bind ~ty:prop Binder.forall z - (T.app_builtin ~ty:prop Builtin.Eq [xz; yz]); - T.app_builtin ~ty:prop Builtin.Eq [T.var x; T.var y] - ] - ) + (T.app_builtin ~ty:prop Builtin.Imply [ + T.bind ~ty:prop Binder.forall z + (T.app_builtin ~ty:prop Builtin.Eq [xz; yz]); + T.app_builtin ~ty:prop Builtin.Eq [T.var x; T.var y] + ] + ) ) let process file = diff --git a/src/tools/fo_detector.ml b/src/tools/fo_detector.ml new file mode 100644 index 000000000..591d43d3e --- /dev/null +++ b/src/tools/fo_detector.ml @@ -0,0 +1,59 @@ + +(* This file is free software, part of Zipperposition. See file "license" for more details. *) + +(** {1 Find applied variables in a problem } *) + +open Logtk +open Logtk_parsers + +module T = TypedSTerm + +(** encode a term *) +let rec detect_term t = + match T.view t with + | T.App (f, args) -> T.is_var(f) || CCList.exists detect_term args + | T.AppBuiltin (_, args) -> CCList.exists detect_term args + | T.Bind (b, v, t) -> detect_term t + | _ -> false + +(** encode a statement *) +let detect_stmt stmt = + match Statement.view stmt with + | Statement.Def _ -> failwith "Not implemented" + | Statement.Rewrite _ -> failwith "Not implemented" + | Statement.Data _ -> failwith "Not implemented" + | Statement.Lemma _ -> failwith "Not implemented" + | Statement.Goal f -> detect_term f + | Statement.NegatedGoal (_,_) -> failwith "Not implemented" + | Statement.Assert f -> detect_term f + | Statement.TyDecl (_, _) -> false + +let process file = + let input = Input_format.I_tptp in + let parse = Util_tptp.parse_file ~recursive:true file in + Util.debugf 5 "Parse: %s" (fun k -> k (match parse with | CCResult.Error e -> e | CCResult.Ok _ -> "OK")); + let ast = Sequence.map Util_tptp.to_ast (CCResult.get_exn parse) in + let typed_ast = TypeInference.infer_statements ?ctx:None + ~on_var:(Input_format.on_var input) + ~on_undef:(Input_format.on_undef_id input) + ~on_shadow:(Input_format.on_shadow input) + ~implicit_ty_args:false ast in + Util.debugf 5 "Parse: %s" (fun k -> k (match typed_ast with | CCResult.Error e -> e | CCResult.Ok _ -> "OK")); + let typed_ast = CCVector.to_list (CCResult.get_exn typed_ast) in + let detected = CCList.exists detect_stmt typed_ast in + detected + +let options = + Options.make() + +let () = + CCFormat.set_color_default true; + let files = ref [] in + let add_file f = files := f :: !files in + Arg.parse (Arg.align options) add_file "fo-detector [options] [files]"; + let number = CCList.fold_left (fun n file -> + let detected = process file in + Format.printf "%s: %b\n" file detected; + if detected then n+1 else n + ) 0 !files in + Format.printf "Total HO: %d/%d\n" number (List.length !files); diff --git a/src/tools/jbuild b/src/tools/jbuild new file mode 100644 index 000000000..0790cb642 --- /dev/null +++ b/src/tools/jbuild @@ -0,0 +1,12 @@ + +; vim:ft=lisp: + +(jbuild_version 1) + +(executables + ((names (type_check cnf_of app_encode tptp_to_zf proof_check_tstp fo_detector)) + (libraries (logtk logtk.parsers)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -color always)) + (ocamlopt_flags (:standard -O3 -color always + -unbox-closures -unbox-closures-factor 20)) + )) diff --git a/tests/.merlin b/tests/.merlin deleted file mode 100644 index bdee20459..000000000 --- a/tests/.merlin +++ /dev/null @@ -1,8 +0,0 @@ -REC -S tests/ -S src/arbitrary/ -B _build/tests/ -B _build/src/arbitrary -PKG oUnit -PKG qcheck -PKG benchmark diff --git a/tests/conf.toml b/tests/conf.toml index 3caf1125a..7f77866e2 100644 --- a/tests/conf.toml +++ b/tests/conf.toml @@ -40,11 +40,3 @@ sat = "SZS status (CounterSatisfiable|Satisfiable)" timeout = "SZS status ResourceOut" version = "git:." -[hornet] - -binary = "./hornet.native" -cmd = "./hornet.native $file -t $timeout --max-depth 200" -unsat = "UNSAT" -sat = "^SAT" -timeout = "SZS status ResourceOut" -version = "git:." diff --git a/tests/jbuild b/tests/jbuild new file mode 100644 index 000000000..f204de83a --- /dev/null +++ b/tests/jbuild @@ -0,0 +1,13 @@ + +(executable + ((name run_tests) + (libraries (logtk logtk.parsers logtk.arbitrary qcheck oUnit)) + (flags (:standard -w +a-4-29-42-44-48-50-58-32-60@8 -color always)))) + +(alias + ((name runtest) + (deps (run_tests.exe)) + (action (run ${<} --verbose)))) + + + diff --git a/tests/run_tests.ml b/tests/run_tests.ml index 5df952733..30d7aae4b 100644 --- a/tests/run_tests.ml +++ b/tests/run_tests.ml @@ -26,5 +26,6 @@ let suite = ] let () = + CCFormat.set_color_default true; ignore (OUnit.run_test_tt suite); QCheck_runner.run_tests_main props diff --git a/tests/testCongruence.ml b/tests/testCongruence.ml index 5bd1deb1a..0b9507d9f 100644 --- a/tests/testCongruence.ml +++ b/tests/testCongruence.ml @@ -126,7 +126,7 @@ end = struct end let check_ref = - let gen = QCheck.(list_of_size Gen.(3--16) (list_of_size Gen.(1--8) ArTerm.default)) in + let gen = QCheck.(list_of_size Gen.(3--8) (list_of_size Gen.(1--6) ArTerm.default)) in let prop classes = let cc1 = _cc_of_classes classes in let cc2 = CC_ref.of_classes classes in diff --git a/tests/testIndex.ml b/tests/testIndex.ml index 19c05b77c..91d2df32a 100644 --- a/tests/testIndex.ml +++ b/tests/testIndex.ml @@ -208,37 +208,40 @@ module TestTerm(I : TermIndex) = struct let _count = 100 let _limit = _count + 100 + let arb_low_ = 10 + let arb_high_ = 100 + let check_retrieved_unify = let prop = _check_all_retrieved_satisfy I.retrieve_unifiables Unif.FO.unify_syn in let name = CCFormat.sprintf "index(%s)_retrieve_imply_unify" I.name in - QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb 10 150) prop + QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb arb_low_ arb_high_) prop let check_retrieved_specializations = let prop = _check_all_retrieved_satisfy I.retrieve_specializations (fun t1 t2 -> Unif.FO.matching ~pattern:t1 t2) in let name = CCFormat.sprintf "index(%s)_retrieve_imply_specializations" I.name in - QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb 10 150) prop + QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb arb_low_ arb_high_) prop let check_retrieved_generalizations = let prop = _check_all_retrieved_satisfy I.retrieve_generalizations _match_flip in let name = CCFormat.sprintf "index(%s)_retrieve_imply_generalizations" I.name in - QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb 10 150) prop + QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb arb_low_ arb_high_) prop let check_retrieve_all_unify = let prop = _check_all_satisfying_are_retrieved I.retrieve_unifiables Unif.FO.unify_syn in let name = CCFormat.sprintf "index(%s)_retrieve_imply_unify" I.name in - QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb 10 150) prop + QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb arb_low_ arb_high_) prop let check_retrieve_all_specializations = let prop = _check_all_satisfying_are_retrieved I.retrieve_specializations (fun t1 t2 -> Unif.FO.matching ~pattern:t1 t2) in let name = CCFormat.sprintf "index(%s)_retrieve_imply_specializations" I.name in - QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb 10 150) prop + QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb arb_low_ arb_high_) prop let check_retrieve_all_generalizations = let prop = _check_all_satisfying_are_retrieved I.retrieve_generalizations _match_flip in let name = CCFormat.sprintf "index(%s)_retrieve_imply_generalizations" I.name in - QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb 10 150) prop + QCheck.Test.make ~name ~count:_count ~max_gen:_limit (arb arb_low_ arb_high_) prop (* check the matching of generalization *) let props = diff --git a/tests/testMultiset.ml b/tests/testMultiset.ml index ba4da4a51..0457be3ac 100644 --- a/tests/testMultiset.ml +++ b/tests/testMultiset.ml @@ -121,7 +121,7 @@ let compare_partial_trans = let max_seq_correct = let prop m = - let l1 = M.max_seq partial_ord m |> Sequence.zip |> Sequence.map fst |> Sequence.to_list in + let l1 = M.max_seq partial_ord m |> Sequence.map fst |> Sequence.to_list in let l2 = M.to_list m |> List.map fst |> List.filter (fun x -> M.is_max partial_ord x m) in if l1=l2 then true else Q.Test.fail_reportf "@[max_seq %a,@ max %a@]" diff --git a/tests/testTerm.ml b/tests/testTerm.ml index 6742f3e1f..46cf3c21c 100644 --- a/tests/testTerm.ml +++ b/tests/testTerm.ml @@ -75,12 +75,24 @@ let test_whnf2 () = assert_equal ~cmp:T.equal ~printer:T.to_string t1 t'; () +let test_polymorphic_app () = + (* Π α. α *) + let polyty = Type.forall_fvars [HVar.make ~ty:Type.tType 0] (Type.var_of_int 0) in + let f_poly = Term.const ~ty:polyty (ID.make "f_poly") in + (* ty → ty *) + let funty = Type.([ty] ==> ty) in + (* apply term of type `Π α. α` to terms of type `ty → ty` and `ty`: *) + let result = Term.app f_poly [Term.of_ty funty; a] in + assert_equal ~cmp:Type.equal ~printer:Type.to_string (Term.ty result) ty; + () + let suite = "test_term" >::: [ "test_db_shift" >:: test_db_shift ; "test_db_unshift" >:: test_db_unshift ; "test_whnf1" >:: test_whnf1 ; "test_whnf2" >:: test_whnf2 + ; "test_polymorphic_app" >:: test_polymorphic_app ] (** Properties *) diff --git a/tests/testUnif.ml b/tests/testUnif.ml index f8a1c7565..069e1f689 100644 --- a/tests/testUnif.ml +++ b/tests/testUnif.ml @@ -6,6 +6,7 @@ open OUnit open Logtk open Logtk_arbitrary +open Logtk_parsers module Fmt = CCFormat module T = Term @@ -15,7 +16,7 @@ module Q = QCheck (** {2 Unit Tests} *) let psterm, pstmt, pstmt_l, clear_scope, unif_ty = - let tyctx = TypeInference.Ctx.create ~implicit_ty_args:true () in + let tyctx = TypeInference.Ctx.create ~implicit_ty_args:false () in let pt s = let t = Parse_zf.parse_term Lex_zf.token (Lexing.from_string s) in let t = TypeInference.infer_exn tyctx t in @@ -29,7 +30,7 @@ let psterm, pstmt, pstmt_l, clear_scope, unif_ty = and pst_l s = let l = Parse_zf.parse_statement_list Lex_zf.token (Lexing.from_string s) in let l = TypeInference.infer_statements_exn - ~on_var:`Default ~ctx:tyctx ~implicit_ty_args:true + ~on_var:`Default ~ctx:tyctx ~implicit_ty_args:false (Sequence.of_list l) in (* TypeInference.Ctx.exit_scope tyctx; *) CCVector.to_list l @@ -56,39 +57,91 @@ let () = val r : term -> prop. val s : prop. val f_ho2: (term -> term ) -> (term -> term) -> term. + val g_ho: (term -> term -> term) -> term. val p_ho2: (term -> term ) -> (term -> term) -> prop. + val a_poly : pi a. a -> a. + val f_poly : pi a b. (a -> b) -> (a -> b) -> a. ") let tyctx = T.Conv.create() (* parse Term.t *) -let pterm = +let pterm_ = fun ?ty s -> let t = psterm s in let ty = CCOpt.map psterm ty in CCOpt.iter (fun ty -> TypedSTerm.unify ty (TypedSTerm.ty_exn t)) ty; T.Conv.of_simple_term_exn tyctx t +let pterm ?ty s = + try pterm_ ?ty s + with e -> + Format.printf "%s@." (Util.err_spf "pterm %s" s); + raise e + (* parse two terms of same type *) let pterm2 = - fun ?ty s1 s2 -> + fun ?(unif_types=true) ?ty s1 s2 -> let t1 = psterm s1 in let t2 = psterm s2 in - unif_ty t1 t2; + if unif_types then ( + unif_ty t1 t2; + ); let ty = CCOpt.map psterm ty in CCOpt.iter (fun ty -> TypedSTerm.unify ty (TypedSTerm.ty_exn t1)) ty; + CCOpt.iter (fun ty -> TypedSTerm.unify ty (TypedSTerm.ty_exn t2)) ty; T.Conv.of_simple_term_exn tyctx t1, T.Conv.of_simple_term_exn tyctx t2 -let ppair = function - | `With_ty (ty, `Unif (t,u)) -> pterm2 ~ty t u - | `Unif (t,u) -> pterm2 t u +module Task : sig + type t + val mk_unif : ?negated:bool -> ?unif_types:bool -> ?with_ty:string -> string -> string -> t + val set_with_ty : string -> t -> t + val set_unif_types : bool -> t -> t + val is_negated : t -> bool + val pp : t CCFormat.printer + val parse : t -> T.t * T.t +end = struct + type t = + | Unif of { + t1: string; + t2: string; + unif_types: bool; + with_ty: string option; + negated: bool; + } + + let mk_unif ?(negated=false) ?(unif_types=true) ?with_ty t1 t2 : t = + Unif {t1;t2;unif_types; with_ty; negated} + + let set_with_ty ty = function + | Unif r -> Unif {r with with_ty=Some ty} + + let set_unif_types b = function + | Unif r -> Unif {r with unif_types=b} + + let is_negated = function + | Unif {negated; _} -> negated + + let pp out = function + | Unif {t1; t2; with_ty=None; _} -> Format.fprintf out "(%s, %s)" t1 t2 + | Unif {t1; t2; with_ty=Some ty; _} -> Format.fprintf out "(%s, %s) : %s" t1 t2 ty + + let parse_ = function + | Unif {with_ty; t1; t2; unif_types; _} -> pterm2 ~unif_types ?ty:with_ty t1 t2 + + let parse p = + try parse_ p + with e -> + print_endline (Util.err_spf "cannot parse/typecheck pair %a@." pp p); + raise e +end let check_variant t u = if Unif.FO.are_variant t u then () else ( let msg = - CCFormat.sprintf "@[<2>`%a`@ and `%a`@ should be variant@]@." + Util.err_spf "@[<2>`%a`@ and `%a`@ should be variant@]@." T.ZF.pp t T.ZF.pp u in OUnit.assert_failure msg @@ -98,7 +151,7 @@ let check_matches t u = if Unif.FO.matches ~pattern:t u then () else ( let msg = - CCFormat.sprintf "@[<2>`%a`@ should match@ `%a`@]@." + Util.err_spf "@[<2>`%a`@ should match@ `%a`@]@." T.ZF.pp t T.ZF.pp u in OUnit.assert_failure msg @@ -108,28 +161,34 @@ let check_eq t1 t2 = OUnit.assert_equal ~printer:T.ZF.to_string ~cmp:T.equal t1 t2 let unifier2 t u = - try - let subst = Unif.FO.unify_syn (t,0)(u,0) in + let subst = Unif.FO.unify_syn (t,0)(u,1) in let renaming = Subst.Renaming.create() in Subst.FO.apply renaming subst (t,0) |> Lambda.snf, - Subst.FO.apply renaming subst (u,0) |> Lambda.snf, + Subst.FO.apply renaming subst (u,1) |> Lambda.snf, renaming, subst - with Unif.Fail -> - let msg = CCFormat.sprintf "@[<2>`%a`@ and `%a`@ should be unifiable@]@." - T.ZF.pp t T.ZF.pp u in - OUnit.assert_failure msg let unifier t u = let t', u', _, _ = unifier2 t u in OUnit.assert_equal ~printer:T.ZF.to_string ~cmp:T.equal t' u'; t' -let check_unifiable t u = +let check_unifiable ?(negated=false) t u = let name = Fmt.sprintf "(@[unifiable `%a`@ `%a`@])" T.ZF.pp t T.ZF.pp u in name >:: fun () -> - let _ = unifier2 t u in - () + try + let _ = unifier2 t u in + if negated then ( + let msg = CCFormat.sprintf "@[<2>`%a`[0]@ and `%a`[1]@ should not be unifiable@]@." + T.ZF.pp t T.ZF.pp u in + OUnit.assert_failure msg + ) + with Unif.Fail -> + if not negated then ( + let msg = CCFormat.sprintf "@[<2>`%a`[0]@ and `%a`[1]@ should be unifiable@]@." + T.ZF.pp t T.ZF.pp u in + OUnit.assert_failure msg + ) let check_unify_correct t u = let name = Fmt.sprintf "(@[unify_correct `%a`@ `%a`@])" T.ZF.pp t T.ZF.pp u in @@ -150,71 +209,107 @@ let check_unifier_matches t u = check_matches t t'; check_matches u t' -let check_same t u t1 t2 = - let name = Fmt.sprintf "(@[unify `%a`@ `%a`@ :makes-eq `%a`@ `%a`@])" - T.ZF.pp t T.ZF.pp u T.ZF.pp t1 T.ZF.pp t2 in +let check_same t u t1 sc1 t2 sc2 = + let name = Fmt.sprintf "(@[unify `%a`@ `%a`@ :makes-eq @[`%a`[%d]@ and `%a`[%d]@]@])" + T.ZF.pp t T.ZF.pp u T.ZF.pp t1 sc1 T.ZF.pp t2 sc2 in name >:: fun () -> let _, _, renaming, subst = unifier2 t u in - let t1 = Subst.FO.apply renaming subst (t1,0) |> Lambda.snf in - let t2 = Subst.FO.apply renaming subst (t2,0) |> Lambda.snf in + let t1 = Subst.FO.apply renaming subst (t1,sc1) |> Lambda.snf in + let t2 = Subst.FO.apply renaming subst (t2,sc2) |> Lambda.snf in check_eq t1 t2 -(* parse action *) -let paction = function - | `With_ty (ty, `Yield r) -> `Yield (pterm ~ty r) - | `Yield r -> `Yield (pterm r) - | `Eq (s1,s2) -> - let t1, t2 = pterm2 s1 s2 in - `Eq (t1,t2) - | `With_ty (ty, `Eq (s1,s2)) -> - let t1, t2 = pterm2 ~ty s1 s2 in - `Eq (t1,t2) - -let check_action t u a = match a with - | `Yield res -> check_unifier t u ~res - | `Eq (t1,t2) -> check_same t u t1 t2 +module Action : sig + type 'a t = private + | Yield of {t: 'a ; ty: 'a option} + | Eq of {t1: 'a; sc1:int; t2: 'a; sc2: int; ty: 'a option} + + val yield : string -> string t + val eq : string -> int -> string -> int -> string t + val set_with_ty : 'a -> 'a t -> 'a t + val parse : string t -> T.t t + val check : T.t -> T.t -> T.t t -> OUnit.test +end = struct + type 'a t = + | Yield of {t: 'a ; ty: 'a option} + | Eq of {t1: 'a; sc1:int; t2: 'a; sc2: int; ty: 'a option} + + let eq t1 sc1 t2 sc2 = Eq{t1;t2;sc1;sc2;ty=None} + let yield t = Yield{t; ty=None} + + let set_with_ty ty = function + | Yield r -> Yield {r with ty=Some ty} + | Eq r -> Eq {r with ty=Some ty} + + (* parse action *) + let parse : string t -> T.t t = function + | Yield r -> + let t = pterm ?ty:r.ty r.t in + Yield {t; ty=None} + | Eq r -> + let t1, t2 = pterm2 ~unif_types:false ?ty:r.ty r.t1 r.t2 in + Eq {t1; t2; sc1=r.sc1; sc2=r.sc2; ty=None} + + let check t u a = match a with + | Yield {t=res;_} -> check_unifier t u ~res + | Eq {t1;t2;sc1;sc2;_} -> check_same t u t1 sc1 t2 sc2 +end let suite_unif1 : OUnit.test list = - let (=?=) a b = `Unif (a,b) in (* unif pair *) - let (>->) a b = `With_ty (b, a) in (* specify return type *) + let (=?=) a b = Task.mk_unif a b in (* unif pair *) + let () a b = Task.mk_unif ~negated:true a b in (* unif pair *) + let (>->) a b = Task.set_with_ty b a in (* specify return type *) + let (>?->) a b = Action.set_with_ty b a in (* specify return type *) let mk_tests (pair,actions) = - let t, u = ppair pair in - let actions = List.map paction actions in + let t, u = Task.parse pair in + let actions = List.map Action.parse actions in clear_scope(); - check_unifiable t u :: + if Task.is_negated pair then + check_unifiable ~negated:true t u :: + List.map (Action.check t u) actions + else ( + check_unifiable t u :: check_unify_correct t u :: check_unifier_matches t u :: - List.map (check_action t u) actions + List.map (Action.check t u) actions + ) in CCList.flat_map mk_tests [ "f X b" =?= "f a Y", [ - `Yield "f a b"; - `Eq ("X", "a"); - `Eq ("Y", "b"); + Action.yield "f a b"; + Action.eq "X" 0 "a" 0; + Action.eq "Y" 1 "b" 0; ]; "F a" =?= "f a (g (g a))", [ - `Yield "f a (g (g a))"; - `Eq ("F", "fun (x:term). f x (g (g x))"); + Action.yield "f a (g (g a))"; + Action.eq "F" 0 "fun (x:term). f x (g (g x))" 0; ]; ("fun (x y:term). F x" =?= "fun x y. G x y") >-> "term -> term -> term", [ - `Yield "fun x y. H x" >-> "term -> term -> term"; - `Eq ("G", "fun x y. F x") >-> "term -> term -> term"; + Action.yield "fun x y. H x" >?-> "term -> term -> term"; + Action.eq "G" 1 "fun x y. F x" 0 >?-> "term -> term -> term"; ]; ("fun (x y z:term). F x" =?= "fun x y z. G x y z") >-> "term -> term -> term -> term", [ - `Yield "fun x y z. H x" >-> "term -> term -> term -> term"; - `Eq ("G", "fun x y z. F x") >-> "term -> term -> term -> term"; + Action.yield "fun x y z. H x" >?-> "term -> term -> term -> term"; + Action.eq "G" 1 "fun x y z. F x" 0 >?-> "term -> term -> term -> term"; ]; ("X" =?= "(fun Y. X1) (fun (x y:term). c)") >-> "term", [ - `Yield "Y" >-> "term"; + Action.yield "Y" >?-> "term"; ]; ("p_ho2 (fun a. F1 a) (fun a. F2 a)" =?= "p_ho2 (fun a. G a) (fun a. G a)"), [ - `Yield "p_ho2 (fun a. G a) (fun a. G a)"; - `Eq ("F1", "G") >-> "term -> term"; - `Eq ("F2", "G") >-> "term -> term"; + Action.yield "p_ho2 (fun a. G a) (fun a. G a)"; + Action.eq "F1" 0 "G" 1 >?-> "term -> term"; + Action.eq "F2" 0 "G" 1 >?-> "term -> term"; ]; ("p_ho2 (fun Y0. d) (fun Y0. F1 Y0)" =?= "p_ho2 (fun Y0. d) (fun Y0. (f_ho2 (fun Y1. Y1) (fun Y2. X)))"), [ ]; + ("f (f a b) X" =?= "F1 (f_poly A1 A2 F1 F2)") |> Task.set_unif_types false, [ + Action.eq "f (f a b)" 0 "F1" 1; + Action.yield "f (f a b) (f_poly _ _ (f (f a b)) F_renamed)"; + (* FIXME + Action.eq "X" 1 "f_poly _ _ (f (f a b)) F2" 0; + *) + ]; + ( "F (g_ho F)" "a_poly A") |> Task.set_unif_types false, []; ] let reg_matching1 () = diff --git a/zipperposition.native b/zipperposition.native new file mode 120000 index 000000000..0a19965d2 --- /dev/null +++ b/zipperposition.native @@ -0,0 +1 @@ +_build/default/src/main/zipperposition.exe \ No newline at end of file diff --git a/zipperposition.opam b/zipperposition.opam new file mode 100644 index 000000000..94aff9b1c --- /dev/null +++ b/zipperposition.opam @@ -0,0 +1,25 @@ +opam-version: "1.2" +maintainer: "simon.cruanes.2007@m4x.org" +author: "Simon Cruanes" +homepage: "https://github.com/c-cube/zipperposition" +version: "1.5" +build: ["jbuilder" "build" "@install"] +build-doc: ["jbuilder" "build" "@doc"] +depends: [ + "ocamlfind" { build } + "base-bytes" + "base-unix" + "zarith" + "containers" { >= "1.0" } + "sequence" { >= "0.4" } + "jbuilder" { build } + "msat" { >= "0.5" < "1.0" } + "menhir" {build} +] +available: [ + ocaml-version >= "4.03.0" +] +tags: [ "logic" "unification" "term" "superposition" "prover" ] +bug-reports: "https://github.com/c-cube/zipperposition/issues" +dev-repo: "https://github.com/c-cube/zipperposition.git" +