From ec86d23f8c057f51af36015628b2414ad9441781 Mon Sep 17 00:00:00 2001 From: kfp Date: Thu, 25 Feb 2016 19:05:29 +0100 Subject: [PATCH] 20120808-r022 --- INSTALL | 53 + LICENSE | 453 ++++++ README | 95 ++ compile | 4 + examples/BOO002-1+rm_eq_rstfp.kif | 47 + examples/COL003-1+rm_eq_rstfp.kif | 53 + examples/COL049-1+rm_eq_rstfp.kif | 52 + examples/GRP001-1+rm_eq_rstfp.kif | 78 + examples/GRP002-1+rm_eq_rstfp.kif | 98 ++ examples/GRP002-3+rm_eq_rstfp.kif | 53 + examples/GRP014-1+rm_eq_rstfp.kif | 38 + examples/LCL024-1+rm_eq_rstfp.kif | 44 + examples/LCL038-1+rm_eq_rstfp.kif | 42 + examples/LCL109-2+rm_eq_rstfp.kif | 54 + examples/LCL111-1.tptp | 55 + examples/LCL114-1+rm_eq_rstfp.kif | 53 + examples/PUZ031+1.kif | 155 ++ examples/RNG008-6+rm_eq_rstfp.kif | 129 ++ examples/RNG009-5+rm_eq_rstfp.kif | 60 + examples/RNG010-5+rm_eq_rstfp.kif | 117 ++ examples/RNG011-5+rm_eq_rstfp.kif | 97 ++ examples/ROB005-1+rm_eq_rstfp.kif | 53 + examples/coder-examples.lisp | 362 +++++ examples/front-last-example.lisp | 82 + examples/hot-drink-example.lisp | 130 ++ examples/latin-squares.lisp | 121 ++ examples/overbeek-test.lisp | 359 ++++ examples/ramsey-examples.lisp | 191 +++ examples/reverse-example.lisp | 51 + examples/snark-test | 19 + examples/steamroller-example.lisp | 82 + make-snark-ccl | 6 + make-snark-ccl64 | 6 + make-snark-sbcl | 6 + make-snark-sbcl64 | 6 + run-snark | 55 + snark-agenda.asd | 14 + snark-auxiliary-packages.asd | 12 + snark-deque.asd | 12 + snark-dpll.asd | 11 + snark-examples.asd | 18 + snark-feature.asd | 12 + snark-implementation.asd | 92 ++ snark-infix-reader.asd | 13 + snark-lisp.asd | 18 + snark-loads.asd | 11 + snark-numbering.asd | 11 + snark-pkg.asd | 12 + snark-sparse-array.asd | 14 + snark-system.lisp | 160 ++ snark.asd | 13 + src/ac-rpo.lisp | 304 ++++ src/agenda-system.lisp | 36 + src/agenda.lisp | 234 +++ src/alists.lisp | 121 ++ src/argument-bag-ac.lisp | 82 + src/argument-list-a1.lisp | 145 ++ src/assertion-analysis.lisp | 502 ++++++ src/assertion-file.lisp | 262 +++ src/auxiliary-packages.lisp | 199 +++ src/clocks.lisp | 169 ++ src/closure1.lisp | 66 + src/code-for-bags4.lisp | 116 ++ src/code-for-lists2.lisp | 34 + src/code-for-numbers3.lisp | 505 ++++++ src/code-for-strings2.lisp | 62 + src/coder.lisp | 714 ++++++++ src/collectors.lisp | 143 ++ src/connectives.lisp | 550 +++++++ src/constants.lisp | 305 ++++ src/constraint-purify.lisp | 151 ++ src/constraints.lisp | 335 ++++ src/counters.lisp | 90 + src/date-reasoning2.lisp | 347 ++++ src/davis-putnam3.lisp | 2344 ++++++++++++++++++++++++++ src/deque-system.lisp | 38 + src/deque2.lisp | 228 +++ src/dp-refute.lisp | 250 +++ src/dpll-system.lisp | 46 + src/equal.lisp | 115 ++ src/eval.lisp | 350 ++++ src/feature-system.lisp | 37 + src/feature-vector-index.lisp | 157 ++ src/feature-vector-trie.lisp | 76 + src/feature-vector.lisp | 153 ++ src/feature.lisp | 831 ++++++++++ src/functions.lisp | 414 +++++ src/globals.lisp | 352 ++++ src/infix-operators.lisp | 105 ++ src/infix-reader-system.lisp | 31 + src/infix-reader.lisp | 441 +++++ src/input.lisp | 984 +++++++++++ src/interactive.lisp | 140 ++ src/jepd-relations-tables.lisp | 511 ++++++ src/jepd-relations.lisp | 731 +++++++++ src/knuth-bendix-ordering2.lisp | 205 +++ src/lisp-system.lisp | 102 ++ src/lisp.lisp | 566 +++++++ src/loads.lisp | 30 + src/main.lisp | 2528 +++++++++++++++++++++++++++++ src/map-file.lisp | 85 + src/multiset-ordering.lisp | 349 ++++ src/mvlet.lisp | 251 +++ src/nonhorn-magic-set.lisp | 131 ++ src/numbering-system.lisp | 32 + src/numbering.lisp | 82 + src/options.lisp | 395 +++++ src/output.lisp | 506 ++++++ src/patches.lisp | 26 + src/path-index.lisp | 870 ++++++++++ src/pattern-match.lisp | 45 + src/posets.lisp | 69 + src/progc.lisp | 288 ++++ src/recursive-path-ordering.lisp | 292 ++++ src/resolve-code-tables.lisp | 154 ++ src/resolve-code.lisp | 193 +++ src/rewrite-code.lisp | 402 +++++ src/rewrite.lisp | 488 ++++++ src/row-contexts.lisp | 184 +++ src/rows.lisp | 387 +++++ src/simplification-ordering.lisp | 356 ++++ src/snark-pkg.lisp | 308 ++++ src/solve-sum.lisp | 95 ++ src/sorts-functions.lisp | 81 + src/sorts-interface.lisp | 180 ++ src/sorts.lisp | 284 ++++ src/sparse-array-system.lisp | 49 + src/sparse-array.lisp | 465 ++++++ src/sparse-vector-expression.lisp | 343 ++++ src/sparse-vector5.lisp | 982 +++++++++++ src/subst.lisp | 611 +++++++ src/substitute.lisp | 201 +++ src/subsume-bag.lisp | 192 +++ src/subsume-clause.lisp | 349 ++++ src/subsume.lisp | 503 ++++++ src/symbol-definitions.lisp | 184 +++ src/symbol-ordering.lisp | 251 +++ src/symbol-table2.lisp | 397 +++++ src/term-hash.lisp | 250 +++ src/term-memory.lisp | 286 ++++ src/terms2.lisp | 231 +++ src/topological-sort.lisp | 81 + src/tptp-symbols.lisp | 98 ++ src/tptp.lisp | 645 ++++++++ src/trie-index.lisp | 574 +++++++ src/trie.lisp | 101 ++ src/unify-bag.lisp | 859 ++++++++++ src/unify-vector.lisp | 135 ++ src/unify.lisp | 234 +++ src/useful.lisp | 167 ++ src/variables.lisp | 77 + src/variant.lisp | 148 ++ src/weight.lisp | 197 +++ src/wffs.lisp | 680 ++++++++ version | 1 + 155 files changed, 36843 insertions(+) create mode 100644 INSTALL create mode 100644 LICENSE create mode 100644 README create mode 100644 compile create mode 100644 examples/BOO002-1+rm_eq_rstfp.kif create mode 100644 examples/COL003-1+rm_eq_rstfp.kif create mode 100644 examples/COL049-1+rm_eq_rstfp.kif create mode 100644 examples/GRP001-1+rm_eq_rstfp.kif create mode 100644 examples/GRP002-1+rm_eq_rstfp.kif create mode 100644 examples/GRP002-3+rm_eq_rstfp.kif create mode 100644 examples/GRP014-1+rm_eq_rstfp.kif create mode 100644 examples/LCL024-1+rm_eq_rstfp.kif create mode 100644 examples/LCL038-1+rm_eq_rstfp.kif create mode 100644 examples/LCL109-2+rm_eq_rstfp.kif create mode 100644 examples/LCL111-1.tptp create mode 100644 examples/LCL114-1+rm_eq_rstfp.kif create mode 100644 examples/PUZ031+1.kif create mode 100644 examples/RNG008-6+rm_eq_rstfp.kif create mode 100644 examples/RNG009-5+rm_eq_rstfp.kif create mode 100644 examples/RNG010-5+rm_eq_rstfp.kif create mode 100644 examples/RNG011-5+rm_eq_rstfp.kif create mode 100644 examples/ROB005-1+rm_eq_rstfp.kif create mode 100644 examples/coder-examples.lisp create mode 100644 examples/front-last-example.lisp create mode 100644 examples/hot-drink-example.lisp create mode 100644 examples/latin-squares.lisp create mode 100644 examples/overbeek-test.lisp create mode 100644 examples/ramsey-examples.lisp create mode 100644 examples/reverse-example.lisp create mode 100644 examples/snark-test create mode 100644 examples/steamroller-example.lisp create mode 100755 make-snark-ccl create mode 100755 make-snark-ccl64 create mode 100755 make-snark-sbcl create mode 100755 make-snark-sbcl64 create mode 100755 run-snark create mode 100644 snark-agenda.asd create mode 100644 snark-auxiliary-packages.asd create mode 100644 snark-deque.asd create mode 100644 snark-dpll.asd create mode 100644 snark-examples.asd create mode 100644 snark-feature.asd create mode 100644 snark-implementation.asd create mode 100644 snark-infix-reader.asd create mode 100644 snark-lisp.asd create mode 100644 snark-loads.asd create mode 100644 snark-numbering.asd create mode 100644 snark-pkg.asd create mode 100644 snark-sparse-array.asd create mode 100644 snark-system.lisp create mode 100644 snark.asd create mode 100644 src/ac-rpo.lisp create mode 100644 src/agenda-system.lisp create mode 100644 src/agenda.lisp create mode 100644 src/alists.lisp create mode 100644 src/argument-bag-ac.lisp create mode 100644 src/argument-list-a1.lisp create mode 100644 src/assertion-analysis.lisp create mode 100644 src/assertion-file.lisp create mode 100644 src/auxiliary-packages.lisp create mode 100644 src/clocks.lisp create mode 100644 src/closure1.lisp create mode 100644 src/code-for-bags4.lisp create mode 100644 src/code-for-lists2.lisp create mode 100644 src/code-for-numbers3.lisp create mode 100644 src/code-for-strings2.lisp create mode 100644 src/coder.lisp create mode 100644 src/collectors.lisp create mode 100644 src/connectives.lisp create mode 100644 src/constants.lisp create mode 100644 src/constraint-purify.lisp create mode 100644 src/constraints.lisp create mode 100644 src/counters.lisp create mode 100644 src/date-reasoning2.lisp create mode 100644 src/davis-putnam3.lisp create mode 100644 src/deque-system.lisp create mode 100644 src/deque2.lisp create mode 100644 src/dp-refute.lisp create mode 100644 src/dpll-system.lisp create mode 100644 src/equal.lisp create mode 100644 src/eval.lisp create mode 100644 src/feature-system.lisp create mode 100644 src/feature-vector-index.lisp create mode 100644 src/feature-vector-trie.lisp create mode 100644 src/feature-vector.lisp create mode 100644 src/feature.lisp create mode 100644 src/functions.lisp create mode 100644 src/globals.lisp create mode 100644 src/infix-operators.lisp create mode 100644 src/infix-reader-system.lisp create mode 100644 src/infix-reader.lisp create mode 100644 src/input.lisp create mode 100644 src/interactive.lisp create mode 100644 src/jepd-relations-tables.lisp create mode 100644 src/jepd-relations.lisp create mode 100644 src/knuth-bendix-ordering2.lisp create mode 100644 src/lisp-system.lisp create mode 100644 src/lisp.lisp create mode 100644 src/loads.lisp create mode 100644 src/main.lisp create mode 100644 src/map-file.lisp create mode 100644 src/multiset-ordering.lisp create mode 100644 src/mvlet.lisp create mode 100644 src/nonhorn-magic-set.lisp create mode 100644 src/numbering-system.lisp create mode 100644 src/numbering.lisp create mode 100644 src/options.lisp create mode 100644 src/output.lisp create mode 100644 src/patches.lisp create mode 100644 src/path-index.lisp create mode 100644 src/pattern-match.lisp create mode 100644 src/posets.lisp create mode 100644 src/progc.lisp create mode 100644 src/recursive-path-ordering.lisp create mode 100644 src/resolve-code-tables.lisp create mode 100644 src/resolve-code.lisp create mode 100644 src/rewrite-code.lisp create mode 100644 src/rewrite.lisp create mode 100644 src/row-contexts.lisp create mode 100644 src/rows.lisp create mode 100644 src/simplification-ordering.lisp create mode 100644 src/snark-pkg.lisp create mode 100644 src/solve-sum.lisp create mode 100644 src/sorts-functions.lisp create mode 100644 src/sorts-interface.lisp create mode 100644 src/sorts.lisp create mode 100644 src/sparse-array-system.lisp create mode 100644 src/sparse-array.lisp create mode 100644 src/sparse-vector-expression.lisp create mode 100644 src/sparse-vector5.lisp create mode 100644 src/subst.lisp create mode 100644 src/substitute.lisp create mode 100644 src/subsume-bag.lisp create mode 100644 src/subsume-clause.lisp create mode 100644 src/subsume.lisp create mode 100644 src/symbol-definitions.lisp create mode 100644 src/symbol-ordering.lisp create mode 100644 src/symbol-table2.lisp create mode 100644 src/term-hash.lisp create mode 100644 src/term-memory.lisp create mode 100644 src/terms2.lisp create mode 100644 src/topological-sort.lisp create mode 100644 src/tptp-symbols.lisp create mode 100644 src/tptp.lisp create mode 100644 src/trie-index.lisp create mode 100644 src/trie.lisp create mode 100644 src/unify-bag.lisp create mode 100644 src/unify-vector.lisp create mode 100644 src/unify.lisp create mode 100644 src/useful.lisp create mode 100644 src/variables.lisp create mode 100644 src/variant.lisp create mode 100644 src/weight.lisp create mode 100644 src/wffs.lisp create mode 100644 version diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..aff6738 --- /dev/null +++ b/INSTALL @@ -0,0 +1,53 @@ +SNARK is run regularly in + Macintosh Common Lisp on Mac OS X + Steel Bank Common Lisp (SBCL) on Mac OS X + Clozure Common Lisp (CCL nee OpenMCL) on Mac OS X +and has been run in other ANSI Common Lisp systems + +After editing for the correct name and location of the SBCL Lisp system in the appropriate make-xxx file +a 32-bit executable of SNARK in SBCL named snark can be made by ./make-snark-sbcl; +a 64-bit executable of SNARK in SBCL named snark64 can be make by ./make-snark-sbcl64. + +After editing for the correct name and location of the CCL Lisp system in the appropriate make-xxx file +a 32-bit executable of SNARK in CCL named snark-ccl can be made by ./make-snark-ccl; +a 64-bit executable of SNARK in CCL named snark-ccl64 can be maded by ./make-snark-ccl64 + + + +Older detailed instructions: + +(replace "yyyymmdd" by the SNARK version date) + +Installing SNARK: + + tar xfz snark-yyyymmdd.tar.gz + cd snark-yyyymmdd + lisp + (load "snark-system.lisp") + (make-snark-system t) ;t specifies compilation + (make-snark-system t) ;compile again for more inlining (optional) + ;can use :optimize instead of t to compile for + ;higher speed at the expense of less error checking + (quit) + +Running SNARK: + + lisp + (load "snark-system.lisp") + (make-snark-system) ;loads SNARK files compiled above + : + +The lengthy load process in running SNARK can be eliminated +for CCL, SBCL, CMUCL, Allegro Common Lisp, or CLISP by doing + lisp + (load "snark-system.lisp") + (make-snark-system) + (save-snark-system) +after installing SNARK as above. +(save-snark-system) will print instructions for running +the resulting Lisp core image with SNARK preloaded. + +In the case of SBCL, (save-snark-system) can be replaced by +(save-snark-system :name "snark" :executable t) +to create a standalone SNARK executable. This is done +by the make-snark-sbcl and make-snark-sbcl64 scripts. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..7da89f9 --- /dev/null +++ b/LICENSE @@ -0,0 +1,453 @@ + MOZILLA PUBLIC LICENSE + Version 1.1 + + --------------- + +1. Definitions. + + 1.0.1. "Commercial Use" means distribution or otherwise making the + Covered Code available to a third party. + + 1.1. "Contributor" means each entity that creates or contributes to + the creation of Modifications. + + 1.2. "Contributor Version" means the combination of the Original + Code, prior Modifications used by a Contributor, and the Modifications + made by that particular Contributor. + + 1.3. "Covered Code" means the Original Code or Modifications or the + combination of the Original Code and Modifications, in each case + including portions thereof. + + 1.4. "Electronic Distribution Mechanism" means a mechanism generally + accepted in the software development community for the electronic + transfer of data. + + 1.5. "Executable" means Covered Code in any form other than Source + Code. + + 1.6. "Initial Developer" means the individual or entity identified + as the Initial Developer in the Source Code notice required by Exhibit + A. + + 1.7. "Larger Work" means a work which combines Covered Code or + portions thereof with code not governed by the terms of this License. + + 1.8. "License" means this document. + + 1.8.1. "Licensable" means having the right to grant, to the maximum + extent possible, whether at the time of the initial grant or + subsequently acquired, any and all of the rights conveyed herein. + + 1.9. "Modifications" means any addition to or deletion from the + substance or structure of either the Original Code or any previous + Modifications. When Covered Code is released as a series of files, a + Modification is: + A. Any addition to or deletion from the contents of a file + containing Original Code or previous Modifications. + + B. Any new file that contains any part of the Original Code or + previous Modifications. + + 1.10. "Original Code" means Source Code of computer software code + which is described in the Source Code notice required by Exhibit A as + Original Code, and which, at the time of its release under this + License is not already Covered Code governed by this License. + + 1.10.1. "Patent Claims" means any patent claim(s), now owned or + hereafter acquired, including without limitation, method, process, + and apparatus claims, in any patent Licensable by grantor. + + 1.11. "Source Code" means the preferred form of the Covered Code for + making modifications to it, including all modules it contains, plus + any associated interface definition files, scripts used to control + compilation and installation of an Executable, or source code + differential comparisons against either the Original Code or another + well known, available Covered Code of the Contributor's choice. The + Source Code can be in a compressed or archival form, provided the + appropriate decompression or de-archiving software is widely available + for no charge. + + 1.12. "You" (or "Your") means an individual or a legal entity + exercising rights under, and complying with all of the terms of, this + License or a future version of this License issued under Section 6.1. + For legal entities, "You" includes any entity which controls, is + controlled by, or is under common control with You. For purposes of + this definition, "control" means (a) the power, direct or indirect, + to cause the direction or management of such entity, whether by + contract or otherwise, or (b) ownership of more than fifty percent + (50%) of the outstanding shares or beneficial ownership of such + entity. + +2. Source Code License. + + 2.1. The Initial Developer Grant. + The Initial Developer hereby grants You a world-wide, royalty-free, + non-exclusive license, subject to third party intellectual property + claims: + (a) under intellectual property rights (other than patent or + trademark) Licensable by Initial Developer to use, reproduce, + modify, display, perform, sublicense and distribute the Original + Code (or portions thereof) with or without Modifications, and/or + as part of a Larger Work; and + + (b) under Patents Claims infringed by the making, using or + selling of Original Code, to make, have made, use, practice, + sell, and offer for sale, and/or otherwise dispose of the + Original Code (or portions thereof). + + (c) the licenses granted in this Section 2.1(a) and (b) are + effective on the date Initial Developer first distributes + Original Code under the terms of this License. + + (d) Notwithstanding Section 2.1(b) above, no patent license is + granted: 1) for code that You delete from the Original Code; 2) + separate from the Original Code; or 3) for infringements caused + by: i) the modification of the Original Code or ii) the + combination of the Original Code with other software or devices. + + 2.2. Contributor Grant. + Subject to third party intellectual property claims, each Contributor + hereby grants You a world-wide, royalty-free, non-exclusive license + + (a) under intellectual property rights (other than patent or + trademark) Licensable by Contributor, to use, reproduce, modify, + display, perform, sublicense and distribute the Modifications + created by such Contributor (or portions thereof) either on an + unmodified basis, with other Modifications, as Covered Code + and/or as part of a Larger Work; and + + (b) under Patent Claims infringed by the making, using, or + selling of Modifications made by that Contributor either alone + and/or in combination with its Contributor Version (or portions + of such combination), to make, use, sell, offer for sale, have + made, and/or otherwise dispose of: 1) Modifications made by that + Contributor (or portions thereof); and 2) the combination of + Modifications made by that Contributor with its Contributor + Version (or portions of such combination). + + (c) the licenses granted in Sections 2.2(a) and 2.2(b) are + effective on the date Contributor first makes Commercial Use of + the Covered Code. + + (d) Notwithstanding Section 2.2(b) above, no patent license is + granted: 1) for any code that Contributor has deleted from the + Contributor Version; 2) separate from the Contributor Version; + 3) for infringements caused by: i) third party modifications of + Contributor Version or ii) the combination of Modifications made + by that Contributor with other software (except as part of the + Contributor Version) or other devices; or 4) under Patent Claims + infringed by Covered Code in the absence of Modifications made by + that Contributor. + +3. Distribution Obligations. + + 3.1. Application of License. + The Modifications which You create or to which You contribute are + governed by the terms of this License, including without limitation + Section 2.2. The Source Code version of Covered Code may be + distributed only under the terms of this License or a future version + of this License released under Section 6.1, and You must include a + copy of this License with every copy of the Source Code You + distribute. You may not offer or impose any terms on any Source Code + version that alters or restricts the applicable version of this + License or the recipients' rights hereunder. However, You may include + an additional document offering the additional rights described in + Section 3.5. + + 3.2. Availability of Source Code. + Any Modification which You create or to which You contribute must be + made available in Source Code form under the terms of this License + either on the same media as an Executable version or via an accepted + Electronic Distribution Mechanism to anyone to whom you made an + Executable version available; and if made available via Electronic + Distribution Mechanism, must remain available for at least twelve (12) + months after the date it initially became available, or at least six + (6) months after a subsequent version of that particular Modification + has been made available to such recipients. You are responsible for + ensuring that the Source Code version remains available even if the + Electronic Distribution Mechanism is maintained by a third party. + + 3.3. Description of Modifications. + You must cause all Covered Code to which You contribute to contain a + file documenting the changes You made to create that Covered Code and + the date of any change. You must include a prominent statement that + the Modification is derived, directly or indirectly, from Original + Code provided by the Initial Developer and including the name of the + Initial Developer in (a) the Source Code, and (b) in any notice in an + Executable version or related documentation in which You describe the + origin or ownership of the Covered Code. + + 3.4. Intellectual Property Matters + (a) Third Party Claims. + If Contributor has knowledge that a license under a third party's + intellectual property rights is required to exercise the rights + granted by such Contributor under Sections 2.1 or 2.2, + Contributor must include a text file with the Source Code + distribution titled "LEGAL" which describes the claim and the + party making the claim in sufficient detail that a recipient will + know whom to contact. If Contributor obtains such knowledge after + the Modification is made available as described in Section 3.2, + Contributor shall promptly modify the LEGAL file in all copies + Contributor makes available thereafter and shall take other steps + (such as notifying appropriate mailing lists or newsgroups) + reasonably calculated to inform those who received the Covered + Code that new knowledge has been obtained. + + (b) Contributor APIs. + If Contributor's Modifications include an application programming + interface and Contributor has knowledge of patent licenses which + are reasonably necessary to implement that API, Contributor must + also include this information in the LEGAL file. + + (c) Representations. + Contributor represents that, except as disclosed pursuant to + Section 3.4(a) above, Contributor believes that Contributor's + Modifications are Contributor's original creation(s) and/or + Contributor has sufficient rights to grant the rights conveyed by + this License. + + 3.5. Required Notices. + You must duplicate the notice in Exhibit A in each file of the Source + Code. If it is not possible to put such notice in a particular Source + Code file due to its structure, then You must include such notice in a + location (such as a relevant directory) where a user would be likely + to look for such a notice. If You created one or more Modification(s) + You may add your name as a Contributor to the notice described in + Exhibit A. You must also duplicate this License in any documentation + for the Source Code where You describe recipients' rights or ownership + rights relating to Covered Code. You may choose to offer, and to + charge a fee for, warranty, support, indemnity or liability + obligations to one or more recipients of Covered Code. However, You + may do so only on Your own behalf, and not on behalf of the Initial + Developer or any Contributor. You must make it absolutely clear than + any such warranty, support, indemnity or liability obligation is + offered by You alone, and You hereby agree to indemnify the Initial + Developer and every Contributor for any liability incurred by the + Initial Developer or such Contributor as a result of warranty, + support, indemnity or liability terms You offer. + + 3.6. Distribution of Executable Versions. + You may distribute Covered Code in Executable form only if the + requirements of Section 3.1-3.5 have been met for that Covered Code, + and if You include a notice stating that the Source Code version of + the Covered Code is available under the terms of this License, + including a description of how and where You have fulfilled the + obligations of Section 3.2. The notice must be conspicuously included + in any notice in an Executable version, related documentation or + collateral in which You describe recipients' rights relating to the + Covered Code. You may distribute the Executable version of Covered + Code or ownership rights under a license of Your choice, which may + contain terms different from this License, provided that You are in + compliance with the terms of this License and that the license for the + Executable version does not attempt to limit or alter the recipient's + rights in the Source Code version from the rights set forth in this + License. If You distribute the Executable version under a different + license You must make it absolutely clear that any terms which differ + from this License are offered by You alone, not by the Initial + Developer or any Contributor. You hereby agree to indemnify the + Initial Developer and every Contributor for any liability incurred by + the Initial Developer or such Contributor as a result of any such + terms You offer. + + 3.7. Larger Works. + You may create a Larger Work by combining Covered Code with other code + not governed by the terms of this License and distribute the Larger + Work as a single product. In such a case, You must make sure the + requirements of this License are fulfilled for the Covered Code. + +4. Inability to Comply Due to Statute or Regulation. + + If it is impossible for You to comply with any of the terms of this + License with respect to some or all of the Covered Code due to + statute, judicial order, or regulation then You must: (a) comply with + the terms of this License to the maximum extent possible; and (b) + describe the limitations and the code they affect. Such description + must be included in the LEGAL file described in Section 3.4 and must + be included with all distributions of the Source Code. Except to the + extent prohibited by statute or regulation, such description must be + sufficiently detailed for a recipient of ordinary skill to be able to + understand it. + +5. Application of this License. + + This License applies to code to which the Initial Developer has + attached the notice in Exhibit A and to related Covered Code. + +6. Versions of the License. + + 6.1. New Versions. + Netscape Communications Corporation ("Netscape") may publish revised + and/or new versions of the License from time to time. Each version + will be given a distinguishing version number. + + 6.2. Effect of New Versions. + Once Covered Code has been published under a particular version of the + License, You may always continue to use it under the terms of that + version. You may also choose to use such Covered Code under the terms + of any subsequent version of the License published by Netscape. No one + other than Netscape has the right to modify the terms applicable to + Covered Code created under this License. + + 6.3. Derivative Works. + If You create or use a modified version of this License (which you may + only do in order to apply it to code which is not already Covered Code + governed by this License), You must (a) rename Your license so that + the phrases "Mozilla", "MOZILLAPL", "MOZPL", "Netscape", + "MPL", "NPL" or any confusingly similar phrase do not appear in your + license (except to note that your license differs from this License) + and (b) otherwise make it clear that Your version of the license + contains terms which differ from the Mozilla Public License and + Netscape Public License. (Filling in the name of the Initial + Developer, Original Code or Contributor in the notice described in + Exhibit A shall not of themselves be deemed to be modifications of + this License.) + +7. DISCLAIMER OF WARRANTY. + + COVERED CODE IS PROVIDED UNDER THIS LICENSE ON AN "AS IS" BASIS, + WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, + WITHOUT LIMITATION, WARRANTIES THAT THE COVERED CODE IS FREE OF + DEFECTS, MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE OR NON-INFRINGING. + THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE COVERED CODE + IS WITH YOU. SHOULD ANY COVERED CODE PROVE DEFECTIVE IN ANY RESPECT, + YOU (NOT THE INITIAL DEVELOPER OR ANY OTHER CONTRIBUTOR) ASSUME THE + COST OF ANY NECESSARY SERVICING, REPAIR OR CORRECTION. THIS DISCLAIMER + OF WARRANTY CONSTITUTES AN ESSENTIAL PART OF THIS LICENSE. NO USE OF + ANY COVERED CODE IS AUTHORIZED HEREUNDER EXCEPT UNDER THIS DISCLAIMER. + +8. TERMINATION. + + 8.1. This License and the rights granted hereunder will terminate + automatically if You fail to comply with terms herein and fail to cure + such breach within 30 days of becoming aware of the breach. All + sublicenses to the Covered Code which are properly granted shall + survive any termination of this License. Provisions which, by their + nature, must remain in effect beyond the termination of this License + shall survive. + + 8.2. If You initiate litigation by asserting a patent infringement + claim (excluding declatory judgment actions) against Initial Developer + or a Contributor (the Initial Developer or Contributor against whom + You file such action is referred to as "Participant") alleging that: + + (a) such Participant's Contributor Version directly or indirectly + infringes any patent, then any and all rights granted by such + Participant to You under Sections 2.1 and/or 2.2 of this License + shall, upon 60 days notice from Participant terminate prospectively, + unless if within 60 days after receipt of notice You either: (i) + agree in writing to pay Participant a mutually agreeable reasonable + royalty for Your past and future use of Modifications made by such + Participant, or (ii) withdraw Your litigation claim with respect to + the Contributor Version against such Participant. If within 60 days + of notice, a reasonable royalty and payment arrangement are not + mutually agreed upon in writing by the parties or the litigation claim + is not withdrawn, the rights granted by Participant to You under + Sections 2.1 and/or 2.2 automatically terminate at the expiration of + the 60 day notice period specified above. + + (b) any software, hardware, or device, other than such Participant's + Contributor Version, directly or indirectly infringes any patent, then + any rights granted to You by such Participant under Sections 2.1(b) + and 2.2(b) are revoked effective as of the date You first made, used, + sold, distributed, or had made, Modifications made by that + Participant. + + 8.3. If You assert a patent infringement claim against Participant + alleging that such Participant's Contributor Version directly or + indirectly infringes any patent where such claim is resolved (such as + by license or settlement) prior to the initiation of patent + infringement litigation, then the reasonable value of the licenses + granted by such Participant under Sections 2.1 or 2.2 shall be taken + into account in determining the amount or value of any payment or + license. + + 8.4. In the event of termination under Sections 8.1 or 8.2 above, + all end user license agreements (excluding distributors and resellers) + which have been validly granted by You or any distributor hereunder + prior to termination shall survive termination. + +9. LIMITATION OF LIABILITY. + + UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, WHETHER TORT + (INCLUDING NEGLIGENCE), CONTRACT, OR OTHERWISE, SHALL YOU, THE INITIAL + DEVELOPER, ANY OTHER CONTRIBUTOR, OR ANY DISTRIBUTOR OF COVERED CODE, + OR ANY SUPPLIER OF ANY OF SUCH PARTIES, BE LIABLE TO ANY PERSON FOR + ANY INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES OF ANY + CHARACTER INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF GOODWILL, + WORK STOPPAGE, COMPUTER FAILURE OR MALFUNCTION, OR ANY AND ALL OTHER + COMMERCIAL DAMAGES OR LOSSES, EVEN IF SUCH PARTY SHALL HAVE BEEN + INFORMED OF THE POSSIBILITY OF SUCH DAMAGES. THIS LIMITATION OF + LIABILITY SHALL NOT APPLY TO LIABILITY FOR DEATH OR PERSONAL INJURY + RESULTING FROM SUCH PARTY'S NEGLIGENCE TO THE EXTENT APPLICABLE LAW + PROHIBITS SUCH LIMITATION. SOME JURISDICTIONS DO NOT ALLOW THE + EXCLUSION OR LIMITATION OF INCIDENTAL OR CONSEQUENTIAL DAMAGES, SO + THIS EXCLUSION AND LIMITATION MAY NOT APPLY TO YOU. + +10. U.S. GOVERNMENT END USERS. + + The Covered Code is a "commercial item," as that term is defined in + 48 C.F.R. 2.101 (Oct. 1995), consisting of "commercial computer + software" and "commercial computer software documentation," as such + terms are used in 48 C.F.R. 12.212 (Sept. 1995). Consistent with 48 + C.F.R. 12.212 and 48 C.F.R. 227.7202-1 through 227.7202-4 (June 1995), + all U.S. Government End Users acquire Covered Code with only those + rights set forth herein. + +11. MISCELLANEOUS. + + This License represents the complete agreement concerning subject + matter hereof. If any provision of this License is held to be + unenforceable, such provision shall be reformed only to the extent + necessary to make it enforceable. This License shall be governed by + California law provisions (except to the extent applicable law, if + any, provides otherwise), excluding its conflict-of-law provisions. + With respect to disputes in which at least one party is a citizen of, + or an entity chartered or registered to do business in the United + States of America, any litigation relating to this License shall be + subject to the jurisdiction of the Federal Courts of the Northern + District of California, with venue lying in Santa Clara County, + California, with the losing party responsible for costs, including + without limitation, court costs and reasonable attorneys' fees and + expenses. The application of the United Nations Convention on + Contracts for the International Sale of Goods is expressly excluded. + Any law or regulation which provides that the language of a contract + shall be construed against the drafter shall not apply to this + License. + +12. RESPONSIBILITY FOR CLAIMS. + + As between Initial Developer and the Contributors, each party is + responsible for claims and damages arising, directly or indirectly, + out of its utilization of rights under this License and You agree to + work with Initial Developer and Contributors to distribute such + responsibility on an equitable basis. Nothing herein is intended or + shall be deemed to constitute any admission of liability. + +13. MULTIPLE-LICENSED CODE. + + Initial Developer may designate portions of the Covered Code as + "Multiple-Licensed". "Multiple-Licensed" means that the Initial + Developer permits you to utilize portions of the Covered Code under + Your choice of the NPL or the alternative licenses, if any, specified + by the Initial Developer in the file described in Exhibit A. + +EXHIBIT A -Mozilla Public License. + + ``The contents of this file are subject to the Mozilla Public License + Version 1.1 (the "License"); you may not use this file except in + compliance with the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL/ + + Software distributed under the License is distributed on an "AS IS" + basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the + License for the specific language governing rights and limitations + under the License. + + The Original Code is SNARK. + + The Initial Developer of the Original Code is SRI International. + Portions created by the Initial Developer are Copyright (C) 1981-2011. + All Rights Reserved. + + Contributor(s): Mark E. Stickel . diff --git a/README b/README new file mode 100644 index 0000000..46f9aa5 --- /dev/null +++ b/README @@ -0,0 +1,95 @@ +===== +SNARK +===== + +SNARK, SRI's New Automated Reasoning Kit, is a theorem prover intended for +applications in artificial intelligence and software engineering. SNARK is +geared toward dealing with large sets of assertions; it can be specialized +with strategic controls that tune its performance; and it has facilities +for integrating special-purpose reasoning procedures with general-purpose +inference. + + +-------- +Overview +-------- + +SNARK is an automated theorem-proving program being developed in Common Lisp. +Its principal inference rules are resolution and paramodulation. SNARK's style +of theorem proving is similar to Otter's. + +Some distinctive features of SNARK are its support for special unification +algorithms, sorts, answer construction for program synthesis, procedural +attachment, and extensibility by Lisp code. + +SNARK has been used as the reasoning component of SRI's High Performance +Knowledge Base (HPKB) system, which deduces answers to questions based on +large repositories of information, and as the deductive core of NASA's Amphion +system, which composes software from components to meet users' specifications, +e.g., to perform computations in planetary astronomy. SNARK has also been +connected to Kestrel's SPECWARE environment for software development. + + +Selected Publications + +Stickel, M., R. Waldinger, M. Lowry, T. Pressburger, and I. Underwood. +Deductive composition of astronomical software from subroutine libraries. +Proceedings of the Twelfth International Conference on Automated Deduction +(CADE-12), Nancy, France, June 1994, 341-355. + + +--------------------- +Links & Documentation +--------------------- + +SNARK tutorial ... http://www.ai.sri.com/snark/tutorial/tutorial.html +SNARK paper ...... http://www.sri.com/work/publications/guide-snark +SNARK home ....... http://www.ai.sri.com/~stickel/snark.html +SNARK author ..... https://en.wikipedia.org/wiki/Mark_E._Stickel + + +---------------- +Obtaining SNARK: +---------------- + + SNARK can be downloaded from the SNARK web page + http://www.ai.sri.com/~stickel/snark.html + +See INSTALL file for installation instructions + +Running SNARK: + + lisp + (load "snark-system.lisp") + (make-snark-system) + : + +Examples: + + (overbeek-test) in overbeek-test.lisp + some standard theorem-proving examples, some time-consuming + + (steamroller-example) in steamroller-example.lisp + illustrates sorts + + (front-last-example) in front-last-example.lisp + illustrates program synthesis + + (reverse-example) in reverse-example.lisp + illustrates logic programming style usage + +A guide to SNARK has been written: + + http://www.ai.sri.com/snark/tutorial/tutorial.html + +but has not been updated yet to reflect changes in SNARK, +especially for temporal and spatial reasoning. + +----- +NOTES +----- +This repository is based on the latest version 20120808-r022 from the +download site and the '.asd' files from https://github.com/hoelzl/Snark. +The goal is to get SNARK installable by QuickLisp. + + diff --git a/compile b/compile new file mode 100644 index 0000000..59884f7 --- /dev/null +++ b/compile @@ -0,0 +1,4 @@ +(load "snark-system.lisp") +(make-snark-system t) +(make-snark-system :optimize) +(quit) diff --git a/examples/BOO002-1+rm_eq_rstfp.kif b/examples/BOO002-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..558a5c4 --- /dev/null +++ b/examples/BOO002-1+rm_eq_rstfp.kif @@ -0,0 +1,47 @@ +;-------------------------------------------------------------------------- +; File : BOO002-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Boolean Algebra (Ternary) +; Problem : In B3 algebra, X * X^-1 * Y = Y +; Version : [OTTER] (equality) axioms : Reduced > Incomplete. +; English : + +; Refs : [LO85] Lusk & Overbeek (1985), Reasoning about Equality +; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [Ove90] +; Names : Problem 5 [LO85] +; : CADE-11 Competition Eq-3 [Ove90] +; : THEOREM EQ-3 [LM93] +; : PROBLEM 3 [Zha93] + +; Status : unsatisfiable +; Rating : 0.33 v2.2.0, 0.43 v2.1.0, 0.38 v2.0.0 +; Syntax : Number of clauses : 5 ( 0 non-Horn; 5 unit; 1 RR) +; Number of literals : 5 ( 5 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 4 ( 2 constant; 0-3 arity) +; Number of variables : 11 ( 2 singleton) +; Maximal term depth : 3 ( 2 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp BOO002-1.p +;-------------------------------------------------------------------------- +; associativity, axiom. +(or (= (multiply (multiply ?A ?B ?C) ?D (multiply ?A ?B ?E)) (multiply ?A ?B (multiply ?C ?D ?E)))) + +; ternary_multiply_1, axiom. +(or (= (multiply ?A ?B ?B) ?B)) + +; ternary_multiply_2, axiom. +(or (= (multiply ?A ?A ?B) ?A)) + +; left_inverse, axiom. +(or (= (multiply (inverse ?A) ?A ?B) ?B)) + +; prove_equation, conjecture. +(or (/= (multiply a (inverse a) b) b)) + +;-------------------------------------------------------------------------- diff --git a/examples/COL003-1+rm_eq_rstfp.kif b/examples/COL003-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..edc3293 --- /dev/null +++ b/examples/COL003-1+rm_eq_rstfp.kif @@ -0,0 +1,53 @@ +;-------------------------------------------------------------------------- +; File : COL003-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Combinatory Logic +; Problem : Strong fixed point for B and W +; Version : [WM88] (equality) axioms. +; English : The strong fixed point property holds for the set +; P consisting of the combinators B and W alone, where ((Bx)y)z +; = x(yz) and (Wx)y = (xy)y. + +; Refs : [Smu85] Smullyan (1978), To Mock a Mocking Bird and Other Logi +; : [MW87] McCune & Wos (1987), A Case Study in Automated Theorem +; : [WM88] Wos & McCune (1988), Challenge Problems Focusing on Eq +; : [Wos88] Wos (1988), Automated Reasoning - 33 Basic Research Pr +; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [LW92] Lusk & Wos (1992), Benchmark Problems in Which Equalit +; : [Wos93] Wos (1993), The Kernel Strategy and Its Use for the St +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [WM88] +; Names : C2 [WM88] +; : Test Problem 17 [Wos88] +; : Sages and Combinatory Logic [Wos88] +; : CADE-11 Competition Eq-8 [Ove90] +; : CL2 [LW92] +; : THEOREM EQ-8 [LM93] +; : Question 3 [Wos93] +; : Question 5 [Wos93] +; : PROBLEM 8 [Zha93] + +; Status : unknown +; Rating : 1.00 v2.0.0 +; Syntax : Number of clauses : 3 ( 0 non-Horn; 3 unit; 1 RR) +; Number of literals : 3 ( 3 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 4 ( 2 constant; 0-2 arity) +; Number of variables : 6 ( 0 singleton) +; Maximal term depth : 4 ( 3 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp COL003-1.p +;-------------------------------------------------------------------------- +; b_definition, axiom. +(or (= (apply (apply (apply b ?A) ?B) ?C) (apply ?A (apply ?B ?C)))) + +; w_definition, axiom. +(or (= (apply (apply w ?A) ?B) (apply (apply ?A ?B) ?B))) + +; prove_strong_fixed_point, conjecture. +(or (/= (apply ?A (f ?A)) (apply (f ?A) (apply ?A (f ?A))))) + +;-------------------------------------------------------------------------- diff --git a/examples/COL049-1+rm_eq_rstfp.kif b/examples/COL049-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..f9b2587 --- /dev/null +++ b/examples/COL049-1+rm_eq_rstfp.kif @@ -0,0 +1,52 @@ +;-------------------------------------------------------------------------- +; File : COL049-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Combinatory Logic +; Problem : Strong fixed point for B, W, and M +; Version : [WM88] (equality) axioms. +; English : The strong fixed point property holds for the set +; P consisting of the combinators B, W, and M, where ((Bx)y)z +; = x(yz), (Wx)y = (xy)y, Mx = xx. + +; Refs : [Smu85] Smullyan (1978), To Mock a Mocking Bird and Other Logi +; : [MW87] McCune & Wos (1987), A Case Study in Automated Theorem +; : [WM88] Wos & McCune (1988), Challenge Problems Focusing on Eq +; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [LW92] Lusk & Wos (1992), Benchmark Problems in Which Equalit +; : [Wos93] Wos (1993), The Kernel Strategy and Its Use for the St +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [Ove90] +; Names : Problem 2 [WM88] +; : CADE-11 Competition Eq-6 [Ove90] +; : CL1 [LW92] +; : THEOREM EQ-6 [LM93] +; : Question 2 [Wos93] +; : PROBLEM 6 [Zha93] + +; Status : unsatisfiable +; Rating : 0.22 v2.2.0, 0.14 v2.1.0, 0.62 v2.0.0 +; Syntax : Number of clauses : 4 ( 0 non-Horn; 4 unit; 1 RR) +; Number of literals : 4 ( 4 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 5 ( 3 constant; 0-2 arity) +; Number of variables : 7 ( 0 singleton) +; Maximal term depth : 4 ( 3 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp COL049-1.p +;-------------------------------------------------------------------------- +; b_definition, axiom. +(or (= (apply (apply (apply b ?A) ?B) ?C) (apply ?A (apply ?B ?C)))) + +; w_definition, axiom. +(or (= (apply (apply w ?A) ?B) (apply (apply ?A ?B) ?B))) + +; m_definition, axiom. +(or (= (apply m ?A) (apply ?A ?A))) + +; prove_strong_fixed_point, conjecture. +(or (/= (apply ?A (f ?A)) (apply (f ?A) (apply ?A (f ?A))))) + +;-------------------------------------------------------------------------- diff --git a/examples/GRP001-1+rm_eq_rstfp.kif b/examples/GRP001-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..f99f349 --- /dev/null +++ b/examples/GRP001-1+rm_eq_rstfp.kif @@ -0,0 +1,78 @@ +;-------------------------------------------------------------------------- +; File : GRP001-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Group Theory +; Problem : X^2 = identity => commutativity +; Version : [MOW76] axioms. +; English : If the square of every element is the identity, the system +; is commutative. + +; Refs : [Rob63] Robinson (1963), Theorem Proving on the Computer +; : [Wos65] Wos (1965), Unpublished Note +; : [MOW76] McCharen et al. (1976), Problems and Experiments for a +; : [WM76] Wilson & Minker (1976), Resolution, Refinements, and S +; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; Source : [MOW76] +; Names : - [Rob63] +; : wos10 [WM76] +; : G1 [MOW76] +; : CADE-11 Competition 1 [Ove90] +; : THEOREM 1 [LM93] +; : xsquared.ver1.in [ANL] + +; Status : unsatisfiable +; Rating : 0.00 v2.0.0 +; Syntax : Number of clauses : 11 ( 0 non-Horn; 8 unit; 5 RR) +; Number of literals : 19 ( 1 equality) +; Maximal clause size : 4 ( 1 average) +; Number of predicates : 2 ( 0 propositional; 2-3 arity) +; Number of functors : 6 ( 4 constant; 0-2 arity) +; Number of variables : 23 ( 0 singleton) +; Maximal term depth : 2 ( 1 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp GRP001-1.p +;-------------------------------------------------------------------------- +; left_identity, axiom. +(or (product identity ?A ?A)) + +; right_identity, axiom. +(or (product ?A identity ?A)) + +; left_inverse, axiom. +(or (product (inverse ?A) ?A identity)) + +; right_inverse, axiom. +(or (product ?A (inverse ?A) identity)) + +; total_function1, axiom. +(or (product ?A ?B (multiply ?A ?B))) + +; total_function2, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?A ?B ?D)) + (= ?C ?D)) + +; associativity1, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?B ?D ?E)) + (not (product ?C ?D ?F)) + (product ?A ?E ?F)) + +; associativity2, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?B ?D ?E)) + (not (product ?A ?E ?F)) + (product ?C ?D ?F)) + +; square_element, hypothesis. +(or (product ?A ?A identity)) + +; a_times_b_is_c, hypothesis. +(or (product a b c)) + +; prove_b_times_a_is_c, conjecture. +(or (not (product b a c))) + +;-------------------------------------------------------------------------- diff --git a/examples/GRP002-1+rm_eq_rstfp.kif b/examples/GRP002-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..650f6e8 --- /dev/null +++ b/examples/GRP002-1+rm_eq_rstfp.kif @@ -0,0 +1,98 @@ +;-------------------------------------------------------------------------- +; File : GRP002-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Group Theory +; Problem : Commutator equals identity in groups of order 3 +; Version : [MOW76] axioms. +; English : In a group, if (for all x) the cube of x is the identity +; (i.e. a group of order 3), then the equation [[x,y],y]= +; identity holds, where [x,y] is the product of x, y, the +; inverse of x and the inverse of y (i.e. the commutator +; of x and y). + +; Refs : [MOW76] McCharen et al. (1976), Problems and Experiments for a +; : [OMW76] Overbeek et al. (1976), Complexity and Related Enhance +; : [Wos88] Wos (1988), Automated Reasoning - 33 Basic Research Pr +; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; Source : [MOW76] +; Names : G6 [MOW76] +; : Theorem 1 [OMW76] +; : Test Problem 2 [Wos88] +; : Commutator Theorem [Wos88] +; : CADE-11 Competition 2 [Ove90] +; : THEOREM 2 [LM93] +; : commutator.ver1.in [ANL] + +; Status : unsatisfiable +; Rating : 0.67 v2.2.0, 0.71 v2.1.0, 1.00 v2.0.0 +; Syntax : Number of clauses : 16 ( 0 non-Horn; 11 unit; 11 RR) +; Number of literals : 26 ( 1 equality) +; Maximal clause size : 4 ( 1 average) +; Number of predicates : 2 ( 0 propositional; 2-3 arity) +; Number of functors : 10 ( 8 constant; 0-2 arity) +; Number of variables : 26 ( 0 singleton) +; Maximal term depth : 2 ( 1 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp GRP002-1.p +;-------------------------------------------------------------------------- +; left_identity, axiom. +(or (product identity ?A ?A)) + +; right_identity, axiom. +(or (product ?A identity ?A)) + +; left_inverse, axiom. +(or (product (inverse ?A) ?A identity)) + +; right_inverse, axiom. +(or (product ?A (inverse ?A) identity)) + +; total_function1, axiom. +(or (product ?A ?B (multiply ?A ?B))) + +; total_function2, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?A ?B ?D)) + (= ?C ?D)) + +; associativity1, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?B ?D ?E)) + (not (product ?C ?D ?F)) + (product ?A ?E ?F)) + +; associativity2, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?B ?D ?E)) + (not (product ?A ?E ?F)) + (product ?C ?D ?F)) + +; x_cubed_is_identity_1, hypothesis. +(or (not (product ?A ?A ?B)) + (product ?A ?B identity)) + +; x_cubed_is_identity_2, hypothesis. +(or (not (product ?A ?A ?B)) + (product ?B ?A identity)) + +; a_times_b_is_c, conjecture. +(or (product a b c)) + +; c_times_inverse_a_is_d, conjecture. +(or (product c (inverse a) d)) + +; d_times_inverse_b_is_h, conjecture. +(or (product d (inverse b) h)) + +; h_times_b_is_j, conjecture. +(or (product h b j)) + +; j_times_inverse_h_is_k, conjecture. +(or (product j (inverse h) k)) + +; prove_k_times_inverse_b_is_e, conjecture. +(or (not (product k (inverse b) identity))) + +;-------------------------------------------------------------------------- diff --git a/examples/GRP002-3+rm_eq_rstfp.kif b/examples/GRP002-3+rm_eq_rstfp.kif new file mode 100644 index 0000000..e1ec0f8 --- /dev/null +++ b/examples/GRP002-3+rm_eq_rstfp.kif @@ -0,0 +1,53 @@ +;-------------------------------------------------------------------------- +; File : GRP002-3 : TPTP v2.2.0. Released v1.0.0. +; Domain : Group Theory +; Problem : Commutator equals identity in groups of order 3 +; Version : [Ove90] (equality) axioms : Incomplete. +; English : In a group, if (for all x) the cube of x is the identity +; (i.e. a group of order 3), then the equation [[x,y],y]= +; identity holds, where [x,y] is the product of x, y, the +; inverse of x and the inverse of y (i.e. the commutator +; of x and y). + +; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [Ove90] +; Names : CADE-11 Competition Eq-1 [Ove90] +; : THEOREM EQ-1 [LM93] +; : PROBLEM 1 [Zha93] +; : comm.in [OTTER] + +; Status : unsatisfiable +; Rating : 0.33 v2.2.0, 0.43 v2.1.0, 0.25 v2.0.0 +; Syntax : Number of clauses : 6 ( 0 non-Horn; 6 unit; 1 RR) +; Number of literals : 6 ( 6 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 6 ( 3 constant; 0-2 arity) +; Number of variables : 8 ( 0 singleton) +; Maximal term depth : 5 ( 2 average) + +; Comments : Uses an explicit formulation of the commutator. +; : tptp2X -f kif -t rm_equality:rstfp GRP002-3.p +;-------------------------------------------------------------------------- +; left_identity, axiom. +(or (= (multiply identity ?A) ?A)) + +; left_inverse, axiom. +(or (= (multiply (inverse ?A) ?A) identity)) + +; associativity, axiom. +(or (= (multiply (multiply ?A ?B) ?C) (multiply ?A (multiply ?B ?C)))) + +; commutator, axiom. +(or (= (commutator ?A ?B) (multiply ?A (multiply ?B (multiply (inverse ?A) (inverse ?B)))))) + +; x_cubed_is_identity, hypothesis. +(or (= (multiply ?A (multiply ?A ?A)) identity)) + +; prove_commutator, conjecture. +(or (/= (commutator (commutator a b) b) identity)) + +;-------------------------------------------------------------------------- diff --git a/examples/GRP014-1+rm_eq_rstfp.kif b/examples/GRP014-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..8b863e8 --- /dev/null +++ b/examples/GRP014-1+rm_eq_rstfp.kif @@ -0,0 +1,38 @@ +;-------------------------------------------------------------------------- +; File : GRP014-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Group Theory +; Problem : Product is associative in this group theory +; Version : [Ove90] (equality) axioms : Incomplete. +; English : The group theory specified by the axiom given implies the +; associativity of multiply. + +; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [Ove90] +; Names : CADE-11 Competition Eq-4 [Ove90] +; : THEOREM EQ-4 [LM93] +; : PROBLEM 4 [Zha93] + +; Status : unsatisfiable +; Rating : 0.33 v2.2.0, 0.43 v2.1.0, 0.50 v2.0.0 +; Syntax : Number of clauses : 2 ( 0 non-Horn; 2 unit; 1 RR) +; Number of literals : 2 ( 2 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 5 ( 3 constant; 0-2 arity) +; Number of variables : 4 ( 0 singleton) +; Maximal term depth : 9 ( 4 average) + +; Comments : The group_axiom is in fact a single axiom for group theory +; [LM93]. +; : tptp2X -f kif -t rm_equality:rstfp GRP014-1.p +;-------------------------------------------------------------------------- +; group_axiom, axiom. +(or (= (multiply ?A (inverse (multiply (multiply (inverse (multiply (inverse ?B) (multiply (inverse ?A) ?C))) ?D) (inverse (multiply ?B ?D))))) ?C)) + +; prove_associativity, conjecture. +(or (/= (multiply a (multiply b c)) (multiply (multiply a b) c))) + +;-------------------------------------------------------------------------- diff --git a/examples/LCL024-1+rm_eq_rstfp.kif b/examples/LCL024-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..5cbf043 --- /dev/null +++ b/examples/LCL024-1+rm_eq_rstfp.kif @@ -0,0 +1,44 @@ +;-------------------------------------------------------------------------- +; File : LCL024-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Logic Calculi (Equivalential) +; Problem : PYO depends on XGK +; Version : [Ove90] axioms. +; English : Show that Kalman's shortest single axiom for the +; equivalential calculus, XGK, can be derived from the Meredith +; single axiom PYO. + +; Refs : [Wos88] Wos (1988), Automated Reasoning - 33 Basic Research Pr +; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; Source : [Ove90] +; Names : Test Problem 16 [Wos88] +; : XGK and Equivalential Calculus [Wos88] +; : CADE-11 Competition 4 [Ove90] +; : THEOREM 4 [LM93] + +; Status : unsatisfiable +; Rating : 0.78 v2.2.0, 0.89 v2.1.0, 0.75 v2.0.0 +; Syntax : Number of clauses : 3 ( 0 non-Horn; 2 unit; 2 RR) +; Number of literals : 5 ( 0 equality) +; Maximal clause size : 3 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 1-1 arity) +; Number of functors : 4 ( 3 constant; 0-2 arity) +; Number of variables : 5 ( 0 singleton) +; Maximal term depth : 5 ( 2 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp LCL024-1.p +;-------------------------------------------------------------------------- +; condensed_detachment, axiom. +(or (not (is_a_theorem (equivalent ?A ?B))) + (not (is_a_theorem ?A)) + (is_a_theorem ?B)) + +; prove_xgk, axiom. +(or (is_a_theorem (equivalent ?A (equivalent (equivalent ?B (equivalent ?C ?A)) (equivalent ?C ?B))))) + +; prove_pyo, conjecture. +(or (not (is_a_theorem (equivalent (equivalent (equivalent a (equivalent b c)) c) (equivalent b a))))) + +;-------------------------------------------------------------------------- diff --git a/examples/LCL038-1+rm_eq_rstfp.kif b/examples/LCL038-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..39b99ef --- /dev/null +++ b/examples/LCL038-1+rm_eq_rstfp.kif @@ -0,0 +1,42 @@ +;-------------------------------------------------------------------------- +; File : LCL038-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Logic Calculi (Implication/Falsehood 2 valued sentential) +; Problem : C0-1 depends on a single axiom +; Version : [McC92] axioms. +; English : An axiomatisation for the Implication/Falsehood 2 valued +; sentential calculus is {C0-1,C0-2,C0-3,C0-4} +; by Tarski-Bernays. Show that C0-1 can be derived from this +; suspected single axiom. + +; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; Source : [Ove90] +; Names : CADE-11 Competition 5 [Ove90] +; : THEOREM 5 [LM93] + +; Status : unsatisfiable +; Rating : 0.89 v2.2.0, 1.00 v2.0.0 +; Syntax : Number of clauses : 3 ( 0 non-Horn; 2 unit; 2 RR) +; Number of literals : 5 ( 0 equality) +; Maximal clause size : 3 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 1-1 arity) +; Number of functors : 4 ( 3 constant; 0-2 arity) +; Number of variables : 6 ( 2 singleton) +; Maximal term depth : 4 ( 2 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp LCL038-1.p +;-------------------------------------------------------------------------- +; condensed_detachment, axiom. +(or (not (is_a_theorem (implies ?A ?B))) + (not (is_a_theorem ?A)) + (is_a_theorem ?B)) + +; single_axiom, axiom. +(or (is_a_theorem (implies (implies (implies ?A ?B) ?C) (implies (implies ?C ?A) (implies ?D ?A))))) + +; prove_c0_1, conjecture. +(or (not (is_a_theorem (implies (implies a b) (implies (implies b c) (implies a c)))))) + +;-------------------------------------------------------------------------- diff --git a/examples/LCL109-2+rm_eq_rstfp.kif b/examples/LCL109-2+rm_eq_rstfp.kif new file mode 100644 index 0000000..be3990f --- /dev/null +++ b/examples/LCL109-2+rm_eq_rstfp.kif @@ -0,0 +1,54 @@ +;-------------------------------------------------------------------------- +; File : LCL109-2 : TPTP v2.2.0. Released v1.0.0. +; Domain : Logic Calculi (Many valued sentential) +; Problem : MV-4 depends on the Merideth system +; Version : [Ove90] axioms. +; Theorem formulation : Wajsberg algebra formulation. +; English : An axiomatisation of the many valued sentential calculus +; is {MV-1,MV-2,MV-3,MV-5} by Meredith. Wajsberg provided +; a different axiomatisation. Show that MV-4 depends on the +; Wajsberg system. + +; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [LM92] Lusk & McCune (1992), Experiments with ROO, a Parallel +; : [LW92] Lusk & Wos (1992), Benchmark Problems in Which Equalit +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [Ove90] +; Names : CADE-11 Competition Eq-5 [Ove90] +; : Luka-5 [LM92] +; : MV4 [LW92] +; : THEOREM EQ-5 [LM93] +; : PROBLEM 5 [Zha93] + +; Status : unsatisfiable +; Rating : 0.56 v2.2.0, 0.71 v2.1.0, 1.00 v2.0.0 +; Syntax : Number of clauses : 5 ( 0 non-Horn; 5 unit; 1 RR) +; Number of literals : 5 ( 5 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 5 ( 3 constant; 0-2 arity) +; Number of variables : 8 ( 0 singleton) +; Maximal term depth : 4 ( 2 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp LCL109-2.p +; ; 'true' renamed to 'true0' - MES +;-------------------------------------------------------------------------- +; wajsberg_1, axiom. +(or (= (implies true0 ?A) ?A)) + +; wajsberg_2, axiom. +(or (= (implies (implies ?A ?B) (implies (implies ?B ?C) (implies ?A ?C))) true0)) + +; wajsberg_3, axiom. +(or (= (implies (implies ?A ?B) ?B) (implies (implies ?B ?A) ?A))) + +; wajsberg_4, axiom. +(or (= (implies (implies (not ?A) (not ?B)) (implies ?B ?A)) true0)) + +; prove_wajsberg_mv_4, conjecture. +(or (/= (implies (implies (implies a b) (implies b a)) (implies b a)) true0)) + +;-------------------------------------------------------------------------- diff --git a/examples/LCL111-1.tptp b/examples/LCL111-1.tptp new file mode 100644 index 0000000..19ad2e8 --- /dev/null +++ b/examples/LCL111-1.tptp @@ -0,0 +1,55 @@ +%------------------------------------------------------------------------------ +% File : LCL111-1 : TPTP v3.0.0. Released v1.0.0. +% Domain : Logic Calculi (Many valued sentential) +% Problem : MV-25 depends on the Merideth system +% Version : [McC92] axioms. +% English : An axiomatisation of the many valued sentential calculus +% is {MV-1,MV-2,MV-3,MV-5} by Meredith. Show that MV-25 depends +% on the Meredith system. + +% Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +% : [MW92] McCune & Wos (1992), Experiments in Automated Deductio +% : [McC92] McCune (1992), Email to G. Sutcliffe +% : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +% : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +% Source : [McC92] +% Names : CADE-11 Competition 6 [Ove90] +% : MV-57 [MW92] +% : THEOREM 6 [LM93] +% : mv.in part 2 [OTTER] +% : mv25.in [OTTER] +% : ovb6 [SETHEO] + +% Status : Unsatisfiable +% Rating : 0.00 v2.4.0, 0.43 v2.3.0, 0.14 v2.2.1, 0.11 v2.2.0, 0.22 v2.1.0, 0.25 v2.0.0 +% Syntax : Number of clauses : 6 ( 0 non-Horn; 5 unit; 2 RR) +% Number of atoms : 8 ( 0 equality) +% Maximal clause size : 3 ( 1 average) +% Number of predicates : 1 ( 0 propositional; 1-1 arity) +% Number of functors : 5 ( 3 constant; 0-2 arity) +% Number of variables : 11 ( 1 singleton) +% Maximal term depth : 4 ( 3 average) + +% Comments : +% : tptp2X -f tptp:short LCL111-1.p +%------------------------------------------------------------------------------ +cnf(condensed_detachment,axiom,( + ~ is_a_theorem(implies(X,Y)) + | ~ is_a_theorem(X) + | is_a_theorem(Y) )). + +cnf(mv_1,axiom,( + is_a_theorem(implies(X,implies(Y,X))) )). + +cnf(mv_2,axiom,( + is_a_theorem(implies(implies(X,Y),implies(implies(Y,Z),implies(X,Z)))) )). + +cnf(mv_3,axiom,( + is_a_theorem(implies(implies(implies(X,Y),Y),implies(implies(Y,X),X))) )). + +cnf(mv_5,axiom,( + is_a_theorem(implies(implies(not(X),not(Y)),implies(Y,X))) )). + +cnf(prove_mv_25,negated_conjecture,( + ~ is_a_theorem(implies(implies(a,b),implies(implies(c,a),implies(c,b)))) )). +%------------------------------------------------------------------------------ diff --git a/examples/LCL114-1+rm_eq_rstfp.kif b/examples/LCL114-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..0b064da --- /dev/null +++ b/examples/LCL114-1+rm_eq_rstfp.kif @@ -0,0 +1,53 @@ +;-------------------------------------------------------------------------- +; File : LCL114-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Logic Calculi (Many valued sentential) +; Problem : MV-36 depnds on the Merideth system +; Version : [McC92] axioms. +; English : An axiomatisation of the many valued sentential calculus +; is {MV-1,MV-2,MV-3,MV-5} by Meredith. Show that 36 depends +; on the Meredith system. + +; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [MW92] McCune & Wos (1992), Experiments in Automated Deductio +; : [McC92] McCune (1992), Email to G. Sutcliffe +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; Source : [McC92] +; Names : CADE-11 Competition 7 [Ove90] +; : MV-60 [MW92] +; : THEOREM 7 [LM93] + +; Status : unsatisfiable +; Rating : 0.89 v2.1.0, 0.88 v2.0.0 +; Syntax : Number of clauses : 6 ( 0 non-Horn; 5 unit; 2 RR) +; Number of literals : 8 ( 0 equality) +; Maximal clause size : 3 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 1-1 arity) +; Number of functors : 4 ( 2 constant; 0-2 arity) +; Number of variables : 11 ( 1 singleton) +; Maximal term depth : 4 ( 2 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp LCL114-1.p +;-------------------------------------------------------------------------- +; condensed_detachment, axiom. +(or (not (is_a_theorem (implies ?A ?B))) + (not (is_a_theorem ?A)) + (is_a_theorem ?B)) + +; mv_1, axiom. +(or (is_a_theorem (implies ?A (implies ?B ?A)))) + +; mv_2, axiom. +(or (is_a_theorem (implies (implies ?A ?B) (implies (implies ?B ?C) (implies ?A ?C))))) + +; mv_3, axiom. +(or (is_a_theorem (implies (implies (implies ?A ?B) ?B) (implies (implies ?B ?A) ?A)))) + +; mv_5, axiom. +(or (is_a_theorem (implies (implies (not ?A) (not ?B)) (implies ?B ?A)))) + +; prove_mv_36, conjecture. +(or (not (is_a_theorem (implies (implies a b) (implies (not b) (not a)))))) + +;-------------------------------------------------------------------------- diff --git a/examples/PUZ031+1.kif b/examples/PUZ031+1.kif new file mode 100644 index 0000000..0e451e4 --- /dev/null +++ b/examples/PUZ031+1.kif @@ -0,0 +1,155 @@ +;-------------------------------------------------------------------------- +; File : PUZ031+1 : TPTP v2.2.0. Released v2.0.0. +; Domain : Puzzles +; Problem : Schubert's Steamroller +; Version : Especial. +; English : Wolves, foxes, birds, caterpillars, and snails are animals, and +; there are some of each of them. Also there are some grains, and +; grains are plants. Every animal either likes to eat all plants +; or all animals much smaller than itself that like to eat some +; plants. Caterpillars and snails are much smaller than birds, +; which are much smaller than foxes, which in turn are much +; smaller than wolves. Wolves do not like to eat foxes or grains, +; while birds like to eat caterpillars but not snails. +; Caterpillars and snails like to eat some plants. Therefore +; there is an animal that likes to eat a grain eating animal. + +; Refs : [Pel86] Pelletier (1986), Seventy-five Problems for Testing Au +; : [Hah94] Haehnle (1994), Email to G. Sutcliffe +; Source : [Hah94] +; Names : Pelletier 47 [Pel86] + +; Status : theorem +; Rating : 0.00 v2.1.0 +; Syntax : Number of formulae : 21 ( 6 unit) +; Number of atoms : 55 ( 0 equality) +; Maximal formula depth : 9 ( 3 average) +; Number of connectives : 36 ( 2 ~ ; 4 |; 14 &) +; ( 0 <=>; 16 =>; 0 <=) +; ( 0 <~>; 0 ~|; 0 ~&) +; Number of predicates : 10 ( 0 propositional; 1-2 arity) +; Number of functors : 0 ( 0 constant; --- arity) +; Number of variables : 33 ( 0 singleton; 22 !; 11 ?) +; Maximal term depth : 1 ( 1 average) + +; Comments : This problem is named after Len Schubert. +; : tptp2X -f kif PUZ031+1.p +;-------------------------------------------------------------------------- +; pel47_1_1, axiom. + (forall (?A) + (=> (wolf ?A) + (animal ?A) ) ) + +; pel47_1_2, axiom. + (exists (?A)(wolf ?A) ) + +; pel47_2_1, axiom. + (forall (?A) + (=> (fox ?A) + (animal ?A) ) ) + +; pel47_2_2, axiom. + (exists (?A)(fox ?A) ) + +; pel47_3_1, axiom. + (forall (?A) + (=> (bird ?A) + (animal ?A) ) ) + +; pel47_3_2, axiom. + (exists (?A)(bird ?A) ) + +; pel47_4_1, axiom. + (forall (?A) + (=> (caterpillar ?A) + (animal ?A) ) ) + +; pel47_4_2, axiom. + (exists (?A)(caterpillar ?A) ) + +; pel47_5_1, axiom. + (forall (?A) + (=> (snail ?A) + (animal ?A) ) ) + +; pel47_5_2, axiom. + (exists (?A)(snail ?A) ) + +; pel47_6_1, axiom. + (exists (?A)(grain ?A) ) + +; pel47_6_2, axiom. + (forall (?A) + (=> (grain ?A) + (plant ?A) ) ) + +; pel47_7, axiom. + (forall (?A) + (=> (animal ?A) + (or (forall (?B) + (=> (plant ?B) + (eats ?A ?B) ) ) + (forall (?C) + (=> (and (and (animal ?C) + (much_smaller ?C ?A) ) + (exists (?D) + (and (plant ?D) + (eats ?C ?D) ) ) ) + (eats ?A ?C) ) ) ) ) ) + +; pel47_8, axiom. + (forall (?A ?B) + (=> (and (bird ?B) + (or (snail ?A) + (caterpillar ?A) ) ) + (much_smaller ?A ?B) ) ) + +; pel47_9, axiom. + (forall (?A ?B) + (=> (and (bird ?A) + (fox ?B) ) + (much_smaller ?A ?B) ) ) + +; pel47_10, axiom. + (forall (?A ?B) + (=> (and (fox ?A) + (wolf ?B) ) + (much_smaller ?A ?B) ) ) + +; pel47_11, axiom. + (forall (?A ?B) + (=> (and (wolf ?A) + (or (fox ?B) + (grain ?B) ) ) + (not (eats ?A ?B) ) ) ) + +; pel47_12, axiom. + (forall (?A ?B) + (=> (and (bird ?A) + (caterpillar ?B) ) + (eats ?A ?B) ) ) + +; pel47_13, axiom. + (forall (?A ?B) + (=> (and (bird ?A) + (snail ?B) ) + (not (eats ?A ?B) ) ) ) + +; pel47_14, axiom. + (forall (?A) + (=> (or (caterpillar ?A) + (snail ?A) ) + (exists (?B) + (and (plant ?B) + (eats ?A ?B) ) ) ) ) + +; pel47, conjecture. + (not (exists (?A ?B) + (and (and (animal ?A) + (animal ?B) ) + (exists (?C) + (and (and (grain ?C) + (eats ?B ?C) ) + (eats ?A ?B) ) ) ) ) ) + +;-------------------------------------------------------------------------- diff --git a/examples/RNG008-6+rm_eq_rstfp.kif b/examples/RNG008-6+rm_eq_rstfp.kif new file mode 100644 index 0000000..7bf412e --- /dev/null +++ b/examples/RNG008-6+rm_eq_rstfp.kif @@ -0,0 +1,129 @@ +;-------------------------------------------------------------------------- +; File : RNG008-6 : TPTP v2.2.0. Released v1.0.0. +; Domain : Ring Theory +; Problem : Boolean rings are commutative +; Version : [MOW76] axioms : Augmented. +; English : Given a ring in which for all x, x * x = x, prove that for +; all x and y, x * y = y * x. + +; Refs : [MOW76] McCharen et al. (1976), Problems and Experiments for a +; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; Source : [Ove90] +; Names : CADE-11 Competition 3 [Ove90] +; : THEOREM 3 [LM93] + +; Status : unsatisfiable +; Rating : 0.67 v2.2.0, 0.71 v2.1.0, 0.75 v2.0.0 +; Syntax : Number of clauses : 22 ( 0 non-Horn; 11 unit; 13 RR) +; Number of literals : 55 ( 2 equality) +; Maximal clause size : 5 ( 2 average) +; Number of predicates : 3 ( 0 propositional; 2-3 arity) +; Number of functors : 7 ( 4 constant; 0-2 arity) +; Number of variables : 74 ( 2 singleton) +; Maximal term depth : 2 ( 1 average) + +; Comments : Supplies multiplication to identity as lemmas +; : tptp2X -f kif -t rm_equality:rstfp RNG008-6.p +;-------------------------------------------------------------------------- +; additive_identity1, axiom. +(or (sum additive_identity ?A ?A)) + +; additive_identity2, axiom. +(or (sum ?A additive_identity ?A)) + +; closure_of_multiplication, axiom. +(or (product ?A ?B (multiply ?A ?B))) + +; closure_of_addition, axiom. +(or (sum ?A ?B (add ?A ?B))) + +; left_inverse, axiom. +(or (sum (additive_inverse ?A) ?A additive_identity)) + +; right_inverse, axiom. +(or (sum ?A (additive_inverse ?A) additive_identity)) + +; associativity_of_addition1, axiom. +(or (not (sum ?A ?B ?C)) + (not (sum ?B ?D ?E)) + (not (sum ?C ?D ?F)) + (sum ?A ?E ?F)) + +; associativity_of_addition2, axiom. +(or (not (sum ?A ?B ?C)) + (not (sum ?B ?D ?E)) + (not (sum ?A ?E ?F)) + (sum ?C ?D ?F)) + +; commutativity_of_addition, axiom. +(or (not (sum ?A ?B ?C)) + (sum ?B ?A ?C)) + +; associativity_of_multiplication1, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?B ?D ?E)) + (not (product ?C ?D ?F)) + (product ?A ?E ?F)) + +; associativity_of_multiplication2, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?B ?D ?E)) + (not (product ?A ?E ?F)) + (product ?C ?D ?F)) + +; distributivity1, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?A ?D ?E)) + (not (sum ?B ?D ?F)) + (not (product ?A ?F ?G)) + (sum ?C ?E ?G)) + +; distributivity2, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?A ?D ?E)) + (not (sum ?B ?D ?F)) + (not (sum ?C ?E ?G)) + (product ?A ?F ?G)) + +; distributivity3, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?D ?B ?E)) + (not (sum ?A ?D ?F)) + (not (product ?F ?B ?G)) + (sum ?C ?E ?G)) + +; distributivity4, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?D ?B ?E)) + (not (sum ?A ?D ?F)) + (not (sum ?C ?E ?G)) + (product ?F ?B ?G)) + +; addition_is_well_defined, axiom. +(or (not (sum ?A ?B ?C)) + (not (sum ?A ?B ?D)) + (= ?C ?D)) + +; multiplication_is_well_defined, axiom. +(or (not (product ?A ?B ?C)) + (not (product ?A ?B ?D)) + (= ?C ?D)) + +; x_times_identity_x_is_identity, axiom. +(or (product ?A additive_identity additive_identity)) + +; identity_times_x_is_identity, axiom. +(or (product additive_identity ?A additive_identity)) + +; x_squared_is_x, hypothesis. +(or (product ?A ?A ?A)) + +; a_times_b_is_c, hypothesis. +(or (product a b c)) + +; prove_b_times_a_is_c, conjecture. +(or (not (product b a c))) + +;-------------------------------------------------------------------------- diff --git a/examples/RNG009-5+rm_eq_rstfp.kif b/examples/RNG009-5+rm_eq_rstfp.kif new file mode 100644 index 0000000..a15f09e --- /dev/null +++ b/examples/RNG009-5+rm_eq_rstfp.kif @@ -0,0 +1,60 @@ +;-------------------------------------------------------------------------- +; File : RNG009-5 : TPTP v2.2.0. Released v1.0.0. +; Domain : Ring Theory +; Problem : If X*X*X = X then the ring is commutative +; Version : [Peterson & Stickel,1981] (equality) axioms : +; Reduced > Incomplete. +; English : Given a ring in which for all x, x * x * x = x, prove that +; for all x and y, x * y = y * x. + +; Refs : [PS81] Peterson & Stickel (1981), Complete Sets of Reductions +; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [Ove90] +; Names : CADE-11 Competition Eq-7 [Ove90] +; : THEOREM EQ-7 [LM93] +; : PROBLEM 7 [Zha93] + +; Status : unsatisfiable +; Rating : 0.67 v2.2.0, 0.71 v2.1.0, 1.00 v2.0.0 +; Syntax : Number of clauses : 9 ( 0 non-Horn; 9 unit; 1 RR) +; Number of literals : 9 ( 9 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 6 ( 3 constant; 0-2 arity) +; Number of variables : 17 ( 0 singleton) +; Maximal term depth : 3 ( 2 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp RNG009-5.p +;-------------------------------------------------------------------------- +; right_identity, axiom. +(or (= (add ?A additive_identity) ?A)) + +; right_additive_inverse, axiom. +(or (= (add ?A (additive_inverse ?A)) additive_identity)) + +; distribute1, axiom. +(or (= (multiply ?A (add ?B ?C)) (add (multiply ?A ?B) (multiply ?A ?C)))) + +; distribute2, axiom. +(or (= (multiply (add ?A ?B) ?C) (add (multiply ?A ?C) (multiply ?B ?C)))) + +; associative_addition, axiom. +(or (= (add (add ?A ?B) ?C) (add ?A (add ?B ?C)))) + +; commutative_addition, axiom. +(or (= (add ?A ?B) (add ?B ?A))) + +; associative_multiplication, axiom. +(or (= (multiply (multiply ?A ?B) ?C) (multiply ?A (multiply ?B ?C)))) + +; x_cubed_is_x, hypothesis. +(or (= (multiply ?A (multiply ?A ?A)) ?A)) + +; prove_commutativity, conjecture. +(or (/= (multiply a b) (multiply b a))) + +;-------------------------------------------------------------------------- diff --git a/examples/RNG010-5+rm_eq_rstfp.kif b/examples/RNG010-5+rm_eq_rstfp.kif new file mode 100644 index 0000000..a2f2f71 --- /dev/null +++ b/examples/RNG010-5+rm_eq_rstfp.kif @@ -0,0 +1,117 @@ +;-------------------------------------------------------------------------- +; File : RNG010-5 : TPTP v2.2.0. Released v1.0.0. +; Domain : Ring Theory (Right alternative) +; Problem : Skew symmetry of the auxilliary function +; Version : [Ove90] (equality) axioms : +; Incomplete > Augmented > Incomplete. +; English : The three Moufang identities imply the skew symmetry +; of s(W,X,Y,Z) = (W*X,Y,Z) - X*(W,Y,Z) - (X,Y,Z)*W. +; Recall that skew symmetry means that the function sign +; changes when any two arguments are swapped. This problem +; proves the case for swapping the first two arguments. + +; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [Ove90] +; Names : CADE-11 Competition Eq-9 [Ove90] +; : THEOREM EQ-9 [LM93] +; : PROBLEM 9 [Zha93] + +; Status : unknown +; Rating : 1.00 v2.0.0 +; Syntax : Number of clauses : 27 ( 0 non-Horn; 27 unit; 2 RR) +; Number of literals : 27 ( 27 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 11 ( 5 constant; 0-4 arity) +; Number of variables : 52 ( 2 singleton) +; Maximal term depth : 6 ( 2 average) + +; Comments : I copied this directly. I think the Moufang identities may +; be wrong. At least they're in another form. +; : tptp2X -f kif -t rm_equality:rstfp RNG010-5.p +;-------------------------------------------------------------------------- +; commutative_addition, axiom. +(or (= (add ?A ?B) (add ?B ?A))) + +; associative_addition, axiom. +(or (= (add (add ?A ?B) ?C) (add ?A (add ?B ?C)))) + +; right_identity, axiom. +(or (= (add ?A additive_identity) ?A)) + +; left_identity, axiom. +(or (= (add additive_identity ?A) ?A)) + +; right_additive_inverse, axiom. +(or (= (add ?A (additive_inverse ?A)) additive_identity)) + +; left_additive_inverse, axiom. +(or (= (add (additive_inverse ?A) ?A) additive_identity)) + +; additive_inverse_identity, axiom. +(or (= (additive_inverse additive_identity) additive_identity)) + +; property_of_inverse_and_add, axiom. +(or (= (add ?A (add (additive_inverse ?A) ?B)) ?B)) + +; distribute_additive_inverse, axiom. +(or (= (additive_inverse (add ?A ?B)) (add (additive_inverse ?A) (additive_inverse ?B)))) + +; additive_inverse_additive_inverse, axiom. +(or (= (additive_inverse (additive_inverse ?A)) ?A)) + +; multiply_additive_id1, axiom. +(or (= (multiply ?A additive_identity) additive_identity)) + +; multiply_additive_id2, axiom. +(or (= (multiply additive_identity ?A) additive_identity)) + +; product_of_inverse, axiom. +(or (= (multiply (additive_inverse ?A) (additive_inverse ?B)) (multiply ?A ?B))) + +; multiply_additive_inverse1, axiom. +(or (= (multiply ?A (additive_inverse ?B)) (additive_inverse (multiply ?A ?B)))) + +; multiply_additive_inverse2, axiom. +(or (= (multiply (additive_inverse ?A) ?B) (additive_inverse (multiply ?A ?B)))) + +; distribute1, axiom. +(or (= (multiply ?A (add ?B ?C)) (add (multiply ?A ?B) (multiply ?A ?C)))) + +; distribute2, axiom. +(or (= (multiply (add ?A ?B) ?C) (add (multiply ?A ?C) (multiply ?B ?C)))) + +; right_alternative, axiom. +(or (= (multiply (multiply ?A ?B) ?B) (multiply ?A (multiply ?B ?B)))) + +; associator, axiom. +(or (= (associator ?A ?B ?C) (add (multiply (multiply ?A ?B) ?C) (additive_inverse (multiply ?A (multiply ?B ?C)))))) + +; commutator, axiom. +(or (= (commutator ?A ?B) (add (multiply ?B ?A) (additive_inverse (multiply ?A ?B))))) + +; middle_associator, axiom. +(or (= (multiply (multiply (associator ?A ?A ?B) ?A) (associator ?A ?A ?B)) additive_identity)) + +; left_alternative, axiom. +(or (= (multiply (multiply ?A ?A) ?B) (multiply ?A (multiply ?A ?B)))) + +; defines_s, axiom. +(or (= (s ?A ?B ?C ?D) (add (add (associator (multiply ?A ?B) ?C ?D) (additive_inverse (multiply ?B (associator ?A ?C ?D)))) (additive_inverse (multiply (associator ?B ?C ?D) ?A))))) + +; right_moufang, hypothesis. +(or (= (multiply ?A (multiply ?B (multiply ?C ?B))) (multiply (commutator (multiply ?A ?B) ?C) ?B))) + +; left_moufang, hypothesis. +(or (= (multiply (multiply ?A (multiply ?B ?A)) ?C) (multiply ?A (commutator ?B (multiply ?A ?C))))) + +; middle_moufang, hypothesis. +(or (= (multiply (multiply ?A ?B) (multiply ?C ?A)) (multiply (multiply ?A (multiply ?B ?C)) ?A))) + +; prove_skew_symmetry, conjecture. +(or (/= (s a b c d) (additive_inverse (s b a c d)))) + +;-------------------------------------------------------------------------- diff --git a/examples/RNG011-5+rm_eq_rstfp.kif b/examples/RNG011-5+rm_eq_rstfp.kif new file mode 100644 index 0000000..2f0e049 --- /dev/null +++ b/examples/RNG011-5+rm_eq_rstfp.kif @@ -0,0 +1,97 @@ +;-------------------------------------------------------------------------- +; File : RNG011-5 : TPTP v2.2.0. Released v1.0.0. +; Domain : Ring Theory +; Problem : In a right alternative ring (((X,X,Y)*X)*(X,X,Y)) = Add Id +; Version : [Ove90] (equality) axioms : +; Incomplete > Augmented > Incomplete. +; English : + +; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [Ove90] +; Names : CADE-11 Competition Eq-10 [Ove90] +; : THEOREM EQ-10 [LM93] +; : PROBLEM 10 [Zha93] + +; Status : unsatisfiable +; Rating : 0.00 v2.0.0 +; Syntax : Number of clauses : 22 ( 0 non-Horn; 22 unit; 2 RR) +; Number of literals : 22 ( 22 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 8 ( 3 constant; 0-3 arity) +; Number of variables : 37 ( 2 singleton) +; Maximal term depth : 5 ( 2 average) + +; Comments : +; : tptp2X -f kif -t rm_equality:rstfp RNG011-5.p +;-------------------------------------------------------------------------- +; commutative_addition, axiom. +(or (= (add ?A ?B) (add ?B ?A))) + +; associative_addition, axiom. +(or (= (add (add ?A ?B) ?C) (add ?A (add ?B ?C)))) + +; right_identity, axiom. +(or (= (add ?A additive_identity) ?A)) + +; left_identity, axiom. +(or (= (add additive_identity ?A) ?A)) + +; right_additive_inverse, axiom. +(or (= (add ?A (additive_inverse ?A)) additive_identity)) + +; left_additive_inverse, axiom. +(or (= (add (additive_inverse ?A) ?A) additive_identity)) + +; additive_inverse_identity, axiom. +(or (= (additive_inverse additive_identity) additive_identity)) + +; property_of_inverse_and_add, axiom. +(or (= (add ?A (add (additive_inverse ?A) ?B)) ?B)) + +; distribute_additive_inverse, axiom. +(or (= (additive_inverse (add ?A ?B)) (add (additive_inverse ?A) (additive_inverse ?B)))) + +; additive_inverse_additive_inverse, axiom. +(or (= (additive_inverse (additive_inverse ?A)) ?A)) + +; multiply_additive_id1, axiom. +(or (= (multiply ?A additive_identity) additive_identity)) + +; multiply_additive_id2, axiom. +(or (= (multiply additive_identity ?A) additive_identity)) + +; product_of_inverse, axiom. +(or (= (multiply (additive_inverse ?A) (additive_inverse ?B)) (multiply ?A ?B))) + +; multiply_additive_inverse1, axiom. +(or (= (multiply ?A (additive_inverse ?B)) (additive_inverse (multiply ?A ?B)))) + +; multiply_additive_inverse2, axiom. +(or (= (multiply (additive_inverse ?A) ?B) (additive_inverse (multiply ?A ?B)))) + +; distribute1, axiom. +(or (= (multiply ?A (add ?B ?C)) (add (multiply ?A ?B) (multiply ?A ?C)))) + +; distribute2, axiom. +(or (= (multiply (add ?A ?B) ?C) (add (multiply ?A ?C) (multiply ?B ?C)))) + +; right_alternative, axiom. +(or (= (multiply (multiply ?A ?B) ?B) (multiply ?A (multiply ?B ?B)))) + +; associator, axiom. +(or (= (associator ?A ?B ?C) (add (multiply (multiply ?A ?B) ?C) (additive_inverse (multiply ?A (multiply ?B ?C)))))) + +; commutator, axiom. +(or (= (commutator ?A ?B) (add (multiply ?B ?A) (additive_inverse (multiply ?A ?B))))) + +; middle_associator, axiom. +(or (= (multiply (multiply (associator ?A ?A ?B) ?A) (associator ?A ?A ?B)) additive_identity)) + +; prove_equality, conjecture. +(or (/= (multiply (multiply (associator a a b) a) (associator a a b)) additive_identity)) + +;-------------------------------------------------------------------------- diff --git a/examples/ROB005-1+rm_eq_rstfp.kif b/examples/ROB005-1+rm_eq_rstfp.kif new file mode 100644 index 0000000..2b70356 --- /dev/null +++ b/examples/ROB005-1+rm_eq_rstfp.kif @@ -0,0 +1,53 @@ +;-------------------------------------------------------------------------- +; File : ROB005-1 : TPTP v2.2.0. Released v1.0.0. +; Domain : Robbins Algebra +; Problem : c + c=c => Boolean +; Version : [Win90] (equality) axioms. +; English : If there is an element c such that c+c=c, then the algebra +; is Boolean. + +; Refs : [HMT71] Henkin et al. (1971), Cylindrical Algebras +; : [Win90] Winker (1990), Robbins Algebra: Conditions that make a +; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10 +; : [LW92] Lusk & Wos (1992), Benchmark Problems in Which Equalit +; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal +; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11 +; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in +; Source : [Ove90] +; Names : CADE-11 Competition Eq-2 [Ove90] +; : Lemma 2.4 [Win90] +; : RA3 [LW92] +; : THEOREM EQ-2 [LM93] +; : PROBLEM 2 [Zha93] +; : robbins.occ.in [OTTER] + +; Status : unsatisfiable +; Rating : 0.67 v2.2.0, 0.71 v2.1.0, 0.88 v2.0.0 +; Syntax : Number of clauses : 5 ( 0 non-Horn; 5 unit; 2 RR) +; Number of literals : 5 ( 5 equality) +; Maximal clause size : 1 ( 1 average) +; Number of predicates : 1 ( 0 propositional; 2-2 arity) +; Number of functors : 5 ( 3 constant; 0-2 arity) +; Number of variables : 7 ( 0 singleton) +; Maximal term depth : 6 ( 2 average) + +; Comments : Commutativity, associativity, and Huntington's axiom +; axiomatize Boolean algebra. +; : tptp2X -f kif -t rm_equality:rstfp ROB005-1.p +;-------------------------------------------------------------------------- +; commutativity_of_add, axiom. +(or (= (add ?A ?B) (add ?B ?A))) + +; associativity_of_add, axiom. +(or (= (add (add ?A ?B) ?C) (add ?A (add ?B ?C)))) + +; robbins_axiom, axiom. +(or (= (negate (add (negate (add ?A ?B)) (negate (add ?A (negate ?B))))) ?A)) + +; idempotence, hypothesis. +(or (= (add c c) c)) + +; prove_huntingtons_axiom, conjecture. +(or (/= (add (negate (add a (negate b))) (negate (add (negate a) (negate b)))) b)) + +;-------------------------------------------------------------------------- diff --git a/examples/coder-examples.lisp b/examples/coder-examples.lisp new file mode 100644 index 0000000..6646063 --- /dev/null +++ b/examples/coder-examples.lisp @@ -0,0 +1,362 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: coder-examples.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2004. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +(defun coder-test () + (time (coder-overbeek6)) + (time (coder-ycl-rst)) + (time (coder-ycl-rst-together)) + (time (coder-veroff-5-2)) + (time (coder-veroff-4-1 :all-proofs t)) + (time (coder-ex7b)) + (time (coder-ex9 :max-syms 18 :max-vars 2)) + nil) + +(defun coder-xcb-reflex (&rest options) + ;; 10-step proof + ;; 11-step proof by (coder-xcb-reflex :max-syms 35) + ;; 13-step proof by (coder-xcb-reflex :max-syms 31) + (apply + 'coder + '((e ?x (e (e (e ?x ?y) (e ?z ?y)) ?z))) + '(e a a) + options)) + +(defun coder-overbeek6 (&rest options) + ;; 5-step proof + (apply + 'coder + '("i(a,i(b,a))" ;Prolog style with declared variables + "i(i(X,Y),i(i(Y,?z),i(X,?z)))" ;Prolog style with explicit variables (capitalized-or ?-prefix) + (i (i (i a b) b) (i (i b a) a)) ;Lisp style with declared variables + (i (i (n ?x) (n ?y)) (i ?y ?x))) ;Lisp style with explicit variables + "i(i(a,b),i(i(c,a),i(c,b)))" ;variable declarations don't apply to target + :variables '(a b c) + options)) + +(defun coder-overbeek4 (&rest options) + ;; 10-step proof + (apply + 'coder + '((e ?x (e (e ?y (e ?z ?x)) (e ?z ?y)))) + '(e (e (e a (e b c)) c) (e b a)) + options)) + +(defun coder-ycl-rst (&rest options) + ;; prove reflexivity (4-step proof), + ;; symmetry (5-step proof), + ;; and transitivity (6-step proof) from ycl + ;; coder searches until all have been found + (apply + 'coder + '((e (e ?x ?y) (e (e ?z ?y) (e ?x ?z)))) + '(and + (e a a) + (e (e a b) (e b a)) + (e (e a b) (e (e b c) (e a c)))) + options)) + +(defun coder-ycl-rst-together (&rest options) + ;; prove reflexivity, symmetry, and transitivity from ycl in a single derivation + ;; 9-step proof + (apply + 'coder + '((e (e ?x ?y) (e (e ?z ?y) (e ?x ?z)))) + '(together + (e a a) + (e (e a b) (e b a)) + (e (e a b) (e (e b c) (e a c)))) + options)) + +(defun coder-veroff-5-2 (&rest options) + ;; problem from + ;; Robert Veroff, "Finding Shortest Proofs: An Application of Linked Inference Rules", + ;; JAR 27,2 (August 2001), 123-129 + ;; 8-step proof + (apply + 'coder + '((i ?x (i ?y ?x)) + (i (i ?x (i ?y ?z)) (i (i ?x ?y) (i ?x ?z)))) + '(i (i a (i b c)) (i b (i a c))) + options)) + +(defun coder-veroff-4-1 (&rest options) + ;; converse (because there's a typo) of problem from + ;; Robert Veroff, "Finding Shortest Proofs: An Application of Linked Inference Rules", + ;; JAR 27,2 (August 2001), 123-129 + ;; 7 6-step proofs, just like Veroff reported + (apply + 'coder + '((i (i (i ?v1 ?v2) ?v3) (i (i ?v2 (i ?v3 ?v5)) (i ?v4 (i ?v2 ?v5))))) + '(i (i v2 (i v3 v5)) (i (i (i v1 v2) v3) (i v4 (i v2 v5)))) + options)) + +(defun ii-schema () + '(i ?x (i ?y ?x))) + +(defun id-schema () + '(i (i ?x (i ?y ?z)) (i (i ?x ?y) (i ?x ?z)))) + +(defun cr-schema1 () + '(i (i ?x (n ?y)) (i (i ?x ?y) (n ?x)))) + +(defun cr-schema2 () + '(i (i (n ?x) (n ?y)) (i (i (n ?x) ?y) ?x))) + +(defun eq-schema1 () + '(i (e ?x ?y) (i ?x ?y))) + +(defun eq-schema2 () + '(i (e ?x ?y) (i ?y ?x))) + +(defun eq-schema3 () + '(i (i ?x ?y) (i (i ?y ?x) (e ?y ?x)))) + +(defun or-schema () + '(e (o ?x ?y) (i (n ?x) ?y))) + +(defun and-schema () + '(e (a ?x ?y) (n (o (n ?x) (n ?y))))) + +(defun alt-and-schema () + '(e (a ?x ?y) (n (i ?x (n ?y))))) + +(defun coder-ex1 (&rest options) + ;; from Genesereth chapter 4 + ;; 3-step proof + (apply + 'coder + (list (ii-schema) + (id-schema) + '(i p q) + '(i q r)) + '(i p r) + options)) + +(defun coder-ex2 (&rest options) + ;; from Genesereth chapter 4 exercise + ;; 6-step proof + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + '(i p q) + '(i q r)) + '(i (i p (n r)) (n p)) + options)) + +(defun coder-ex3 (&rest options) + ;; from Genesereth chapter 4 exercise + ;; 5-step proof + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + '(n (n p))) + 'p + options)) + +(defun coder-ex4 (&rest options) + ;; 5-step proof + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + 'p) + '(n (n p)) + options)) + +(defun coder-ex5 (&rest options) + ;; 4-step proof + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + (eq-schema1) + (eq-schema2) + (eq-schema3)) + '(e p p) + options)) + +(defun coder-ex6 (&rest options) + ;; 4-step proof + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + (eq-schema1) + (eq-schema2) + (eq-schema3) + '(e p q)) + '(e q p) + options)) + +(defun coder-ex6a (&rest options) + ;; 5-step proof + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + (eq-schema1) + (eq-schema2) + (eq-schema3)) + '(i (e p q) (e q p)) + options)) + +(defun coder-ex6b (&rest options) + ;; 7-step proof + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + (eq-schema1) + (eq-schema2) + (eq-schema3)) + '(e (e p q) (e q p)) + options)) + +(defun coder-ex7a () + ;; 5-step proof, 5-step proof, 2-step proof + (coder (list (ii-schema) + (id-schema) + (eq-schema1) + (eq-schema2) + (eq-schema3) + '(e p q) + '(e q r)) + '(i p r) + :must-use '(6 7)) + (coder (list (ii-schema) + (id-schema) + (eq-schema1) + (eq-schema2) + (eq-schema3) + '(e p q) + '(e q r)) + '(i r p) + :must-use '(6 7)) + (coder (list (ii-schema) + (id-schema) + (eq-schema1) + (eq-schema2) + (eq-schema3) + '(i p r) + '(i r p)) + '(e p r) + :must-use '(6 7))) + +(defun coder-ex7b () + ;; 12-step proof + (coder (list (ii-schema) + (id-schema) + (eq-schema1) + (eq-schema2) + (eq-schema3) + '(e p q) + '(e q r)) + '(together (e p r) (i p q) (i q r) (i p r) (i r q) (i q p) (i r p)) + :must-use t + :max-syms 7)) + +(defun coder-ex8 (&rest options) + ;; 3-step proof + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + (eq-schema1) + (eq-schema2) + (eq-schema3) + (or-schema) + 'q) + '(o p q) + options)) + +(defun coder-ex9 (&rest options) + ;; no 1,...,8-step proof + ;; 9-step proof by (coder-ex9 :max-syms 18 :max-vars 2) + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + (eq-schema1) + (eq-schema2) + (eq-schema3) + (or-schema) + 'p) + '(o p q) + options)) + +(defun coder-ex10 (&rest options) + ;; no 1,...,8-step proof + ;; 13-step proof by (coder-ex10 :max-syms 18 :max-vars 2 :must-use '(1 2 3 4 5 6 8 9 10 11)) + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + (eq-schema1) + (eq-schema2) + (eq-schema3) + (or-schema) + (and-schema) + 'p + 'q) + '(a p q) + options)) + +(defun coder-ex11 (&rest options) + ;; no 1,...,8-step proof + ;; 9-step proof by (coder-ex11 :max-syms 16 :max-vars 2) + (apply + 'coder + (list (ii-schema) + (id-schema) + (cr-schema1) + (cr-schema2) + (eq-schema1) + (eq-schema2) + (eq-schema3) + (alt-and-schema) + 'p + 'q) + '(a p q) + options)) + +;;; coder-examples.lisp EOF diff --git a/examples/front-last-example.lisp b/examples/front-last-example.lisp new file mode 100644 index 0000000..756fb49 --- /dev/null +++ b/examples/front-last-example.lisp @@ -0,0 +1,82 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: front-last-example.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2002. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +;;; Let L be a nonempty list. +;;; Synthesize a program to compute the FRONT and LAST +;;; of the list where LAST of a list is its last element +;;; and FRONT is the list of all elements except the last. +;;; +;;; The program specification is +;;; (EXISTS (Y Z) (= L (APPEND Y (CONS Z NIL)))) +;;; i.e., find Y and Z such that L can be formed by +;;; appending Y (the FRONT of L) and a single element list +;;; containing Z (the LAST of L). +;;; +;;; The appropriate inductive axiom is given explicitly in the axiom +;;; named induction. +;;; +;;; Necessary properties of APPEND, CONS, HEAD, and TAIL are given +;;; in the axioms named append-nil, append-cons, and cons-definition. +;;; +;;; A proof of the query is found and the program +;;; defined by the values found for variables Y and Z +;;; in the specification. +;;; +;;; Resolution and paramodulation (for equality) are the inference +;;; rules used. + +(defun front-last-example () + ;; Waldinger program synthesis example 1989-12-14 + (initialize) + (use-resolution) + (use-paramodulation) + (use-literal-ordering-with-resolution 'literal-ordering-p) + (use-literal-ordering-with-paramodulation 'literal-ordering-p) + (use-conditional-answer-creation) + (declare-constant 'nil) + (declare-constant 'l) + (declare-function 'head 1) + (declare-function 'tail 1) + (declare-function 'cons 2) + (declare-function 'append 2) + (declare-function 'front 1) + (declare-function 'last 1) + (declare-ordering-greaterp 'l 'nil) + (declare-ordering-greaterp 'head 'l) + (declare-ordering-greaterp 'tail 'l) + (declare-ordering-greaterp 'cons 'head) + (declare-ordering-greaterp 'cons 'tail) + (declare-ordering-greaterp 'append 'cons) +;;(assert '(forall (x) (= x x))) + (assert '(/= l nil) + :name 'l-nonempty) + (assert '(implies (and (/= l nil) (/= (tail l) nil)) + (= (tail l) (append (front (tail l)) (cons (last (tail l)) nil)))) + :name 'induction) + (assert '(forall (u) (= (append nil u) u)) + :name 'append-nil) + (assert '(forall (u v w) (= (append (cons u v) w) (cons u (append v w)))) + :name 'append-cons) + (assert '(forall (x) (implied-by (= x (cons (head x) (tail x))) (/= x nil))) + :name 'cons-definition) + (prove '(= l (append ?y (cons ?z nil))) :answer '(values ?y ?z))) + +;;; front-last-example.lisp EOF diff --git a/examples/hot-drink-example.lisp b/examples/hot-drink-example.lisp new file mode 100644 index 0000000..75d9566 --- /dev/null +++ b/examples/hot-drink-example.lisp @@ -0,0 +1,130 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: hot-drink-example.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2005. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +;;; this is a simple example of one way of implementing partitions in SNARK +;;; rows are annotated with the partitions they're in and inferences are +;;; restricted to rows in the same partitions +;;; +;;; a partition communication table is used to augment the annotation +;;; of derived rows in case the row should be included in a neighboring +;;; partition too +;;; +;;; the partition communication table computation is invoked by including +;;; it as a pruning test +;;; +;;; this code is more illustrative than definitive + +;;; partition communication table is a set of triples +;;; (from-partition to-partition relation-names) like +;;; (1 2 (water)) +;;; (2 3 (steam)) + +(defun row-predicate-names (row) + (row-relation-names row)) + +(defun row-relation-names (row) + ;; returns list of relation names in formula part + ;; (but not answer, constraint, etc. parts) of a row + (let ((names nil)) + (prog-> + (snark::map-atoms-in-wff (row-wff row) ->* atom polarity) + (declare (ignore polarity)) + (dereference + atom nil + :if-constant (pushnew (constant-name atom) names) + :if-compound (pushnew (function-name (head atom)) names))) + names)) + +(defun partition-communication (row) + ;; could try to refine the context for added partitions + (when (use-partitions?) + (let ((table (partition-communication-table?)) + (preds (row-relation-names row)) + (context (snark::row-context row)) + (more-context nil)) + (flet ((message-passing-from (x) + (prog-> + (car x -> part1) + (sparse-matrix-row table part1 ->nonnil row) + (cdr x -> ctxt1) + (map-sparse-vector-with-indexes row ->* preds2 part2) + (when (and (null (assoc part2 context)) + (null (assoc part2 more-context)) + (subsetp preds preds2)) + (push (cons part2 ctxt1) more-context) + nil)))) + (mapc #'message-passing-from context) + (do () + ((null more-context)) + (push (pop more-context) context) + (message-passing-from (first context))) + (setf (snark::row-context row) context)))) + nil) + +(defun hot-drink-example (&key (use-partitions t) (use-ordering nil)) + ;; Amir & McIlraith partition-based reasoning example + (initialize) + (when use-partitions + (use-partitions '(1 2 3)) + (partition-communication-table + (let ((pct (make-sparse-matrix))) + (setf (sparef pct 1 2) '(water) + (sparef pct 2 3) '(steam)) + pct)) + (pruning-tests (append (pruning-tests?) '(partition-communication)))) + (cond + (use-ordering + (use-resolution t) + (use-literal-ordering-with-resolution 'literal-ordering-a) + (declare-proposition 'ok_pump) + (declare-proposition 'on_pump) + (declare-proposition 'man_fill) + (declare-proposition 'water) + (declare-proposition 'ok_boiler) + (declare-proposition 'on_boiler) + (declare-proposition 'steam) + (declare-proposition 'coffee) + (declare-proposition 'hot_drink) + (declare-ordering-greaterp '(ok_pump on_pump man_fill) 'water) + (declare-ordering-greaterp '(water ok_boiler on_boiler) 'steam) + (declare-ordering-greaterp 'coffee 'hot_drink)) + (t + (use-hyperresolution t))) + (dolist (wff '((or (not ok_pump) (not on_pump) water) + (or (not man_fill) water) + (or (not man_fill) (not on_pump)) + (or man_fill on_pump))) + (assert wff :partitions '(1))) + (dolist (wff '((or (not water) (not ok_boiler) (not on_boiler) steam) + (or water (not steam)) + (or ok_boiler (not steam)) + (or on_boiler (not steam)))) + (assert wff :partitions '(2))) + (dolist (wff '((or (not steam) (not coffee) hot_drink) + (or coffee teabag) + (or (not steam) (not teabag) hot_drink))) + (assert wff :partitions '(3))) + (assume 'ok_pump :partitions '(1)) + (assume 'ok_boiler :partitions '(2)) + (assume 'on_boiler :partitions '(2)) + (closure)) + +;;; hot-drink-example.lisp EOF diff --git a/examples/latin-squares.lisp b/examples/latin-squares.lisp new file mode 100644 index 0000000..01b8452 --- /dev/null +++ b/examples/latin-squares.lisp @@ -0,0 +1,121 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: latin-squares.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2006. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +(defun latin-square-clauses (order &key clause-set (standard t) &allow-other-keys) + (let ((n-1 (- order 1))) + ;; row, column, and values are numbered in [0,...,order-1] + (unless clause-set + (setf clause-set (make-dp-clause-set))) + (dp-insert-wff `(forall ((i :in (ints 0 ,n-1)) (j :in (ints 0 ,n-1))) (exists ((k :in (ints 0 ,n-1))) (p i j k))) clause-set) + (dp-insert-wff `(forall ((i :in (ints 0 ,n-1)) (k :in (ints 0 ,n-1))) (exists ((j :in (ints 0 ,n-1))) (p i j k))) clause-set) + (dp-insert-wff `(forall ((j :in (ints 0 ,n-1)) (k :in (ints 0 ,n-1))) (exists ((i :in (ints 0 ,n-1))) (p i j k))) clause-set) + (dp-insert-wff `(forall ((i :in (ints 0 ,n-1)) + (j :in (ints 0 ,n-1)) + (k :in (ints 1 ,n-1)) + (l :in (ints 0 (- k 1)))) + (and + (or (not (p i j l)) (not (p i j k))) + (or (not (p i l j)) (not (p i k j))) + (or (not (p l i j)) (not (p k i j))))) + clause-set) + (when standard + ;; fix first row and column for standard form + (dp-insert-wff `(forall ((j :in (ints 0 ,n-1))) (p 0 j j)) clause-set) + (dp-insert-wff `(forall ((i :in (ints 0 ,n-1))) (p i 0 i)) clause-set)) + clause-set)) + +(defun model-to-latin-square (atoms &optional order) + ;; convert list of p atoms to sequence of sequences representation of latin square + (unless order + (let ((n 0)) ;find its order + (dolist (atom atoms) + (when (and (consp atom) (eq 'p (first atom))) + (dolist (k (rest atom)) + (when (> k n) + (setf n k))))) + (setf order (+ n 1)))) + (let ((ls (make-array order))) + (dotimes (i order) + (setf (aref ls i) (make-array order :initial-element nil))) + (dolist (atom atoms) + (when (and (consp atom) (eq 'p (first atom))) + (let ((i (second atom)) + (j (third atom)) + (k (fourth atom))) + (cl:assert (null (aref (aref ls i) j))) + (setf (aref (aref ls i) j) k)))) + ls)) + +(defun generate-latin-squares (order &rest options &key (apply nil) (time t) &allow-other-keys) + (let (clause-set) + (flet ((make-clause-set () + (setf clause-set (apply #'latin-square-clauses order options))) + (generate () + (dp-satisfiable-p clause-set + :find-all-models -1 + :model-test-function (and apply (lambda (model) (funcall apply (model-to-latin-square model order)) t)) + :trace-choices nil))) + (if time (time (make-clause-set)) (make-clause-set)) + (if time (time (generate)) (generate))))) + +(defun print-latin-square (ls) + (map nil (lambda (row) (format t "~%") (map nil (lambda (v) (format t "~3@A" v)) row)) ls) + ls) + +(defun latin-square-conjugate (ls conjugate) + (let* ((order (length ls)) + (ls* (make-array order))) + (dotimes (i order) + (setf (elt ls* i) (make-array order :initial-element nil))) + (dotimes (i order) + (dotimes (j order) + (let ((k (elt (elt ls i) j))) + (ecase conjugate + (132 + (setf (elt (elt ls* i) k) j)) + (213 + (setf (elt (elt ls* j) i) k)) + (231 + (setf (elt (elt ls* j) k) i)) + ((312 column) + (setf (elt (elt ls* k) i) j)) + ((321 row) + (setf (elt (elt ls* k) j) i)) + (123 ;makes copy of ls + (setf (elt (elt ls* i) j) k)))))) + ls*)) + +(defun latin-square-standard-form (ls) + (let* ((order (length ls)) + (ls* (make-array order))) + (dotimes (i order) + (setf (elt ls* i) (make-array order :initial-element nil))) + ;; renumber entries so first row is 0,...,order-1 + (let ((row0 (elt ls 0))) + (dotimes (i order) + (let ((rowi (elt ls i)) + (rowi* (elt ls* i))) + (dotimes (j order) + (setf (elt rowi* j) (position (elt rowi j) row0)))))) + ;; sort rows so that first column is 0,...,order-1 + (sort ls* #'< :key (lambda (x) (elt x 0))))) + +;;; latin-squares.lisp EOF diff --git a/examples/overbeek-test.lisp b/examples/overbeek-test.lisp new file mode 100644 index 0000000..41e1ea6 --- /dev/null +++ b/examples/overbeek-test.lisp @@ -0,0 +1,359 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: overbeek-test.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2008. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +(defun overbeek-test (&key (verbose t)) + #+Symbolics (zl:print-herald) + (let ((p1 (default-print-rows-when-given?)) + (p2 (default-print-rows-when-derived?)) + (p3 (default-print-rows-prettily?)) + (p4 (default-print-final-rows?)) + (p5 (default-print-options-when-starting?)) + (p6 (default-print-assertion-analysis-notes?)) + (p7 (default-print-term-memory-when-finished?)) + (p8 (default-print-agenda-when-finished?))) + (unwind-protect + (let ((total-seconds 0.0)) + (dolist (x '( + ;; (print-rows-when-given print-rows-when-derived print-wffs-when-done problem-name) + (t t nil overbeek1) + (t t nil overbeek1e) + (t t nil overbeek3e) + (t t nil overbeek6) + (t t nil overbeek2e) + (t :signal nil overbeek2) + (t t nil overbeek4e) + (t t nil overbeek3) + (t t nil overbeek7e) + (t :signal nil overbeek7) + (t :signal nil overbeek4) + (t :signal nil overbeek5e) + (t :signal nil overbeek6e) + (t :signal nil overbeek5) + (t :signal nil overbeek6-1) + (t :signal nil overbeek4-1) +;; (t t nil overbeek5-1) +;; (t t nil overbeek7-1) +;; (t t nil overbeek7e-1) + ;;overbeek8e + ;;overbeek9e + ;;overbeek10e + )) + (dotimes (i 3) (terpri)) + (let ((#-symbolics *break-on-signals* #+symbolics conditions::*break-on-signals* nil) + (snark::critique-options t)) + (default-print-rows-when-given (and verbose (first x))) + (default-print-rows-when-derived (and verbose (second x))) + (default-print-row-wffs-prettily nil) + (unless verbose + (default-print-final-rows nil) + (default-print-options-when-starting nil) + (default-print-assertion-analysis-notes nil) + (default-print-term-memory-when-finished nil) + (default-print-agenda-when-finished nil)) + (funcall (print (fourth x)))) + (incf total-seconds snark-lisp::*total-seconds*) + (when (third x) + (terpri) + (print-rows :ancestry t)) + (prin1 (fourth x)) + (terpri)) + (format t "~%OVERBEEK-TEST Total = ~D seconds" (round total-seconds))) + (default-print-rows-when-given p1) + (default-print-rows-when-derived p2) + (default-print-row-wffs-prettily p3) + (default-print-final-rows p4) + (default-print-options-when-starting p5) + (default-print-assertion-analysis-notes p6) + (default-print-term-memory-when-finished p7) + (default-print-agenda-when-finished p8) + nil))) + +(defun refute-snark-example-file (name options &key format) + (refute-file + (make-pathname :directory (append (pathname-directory cl-user::*snark-system-pathname*) (list "examples")) + :name name + :type (case format (:tptp "tptp") (otherwise "kif"))) + :options options + :format format + :ignore-errors nil + :verbose t + :output-file nil + :package :snark-user)) + +(defun overbeek1 () + (refute-snark-example-file + "GRP001-1+rm_eq_rstfp" + '(;;(agenda-ordering-function #'fifo) + ;;(row-weight-limit 4) ;4 is minimum value for which proof can be found + (declare-constant 'e :alias 'identity) + (declare-constant 'a) + (declare-constant 'b) + (declare-constant 'c) + (declare-function 'f 2 :alias 'multiply :ordering-status :left-to-right) + (declare-function 'g 1 :alias 'inverse :kbo-weight 0) + (declare-relation 'p 3 :alias 'product) + (ordering-functions>constants t) + (declare-ordering-greaterp 'g 'f 'c 'b 'a 'e) + (use-hyperresolution t) + (use-term-ordering :kbo)))) + +(defun overbeek2 () + (refute-snark-example-file + "GRP002-1+rm_eq_rstfp" + '(;;(ROW-WEIGHT-LIMIT 9) + (declare-constant 'e :alias 'identity) + (declare-constant 'a) + (declare-constant 'b) + (declare-constant 'c) + (declare-constant 'd) + (declare-constant 'h) + (declare-constant 'j) + (declare-constant 'k) + (declare-function 'f 2 :alias 'multiply) + (declare-function 'g 1 :alias 'inverse :kbo-weight '(1 2)) + (declare-relation 'p 3 :alias 'product) + (ordering-functions>constants t) + (declare-ordering-greaterp 'g 'f 'k 'j 'h 'd 'c 'b 'a 'e) + (use-hyperresolution t) + (use-term-ordering :kbo)))) + +(defun overbeek3 () + (refute-snark-example-file + "RNG008-6+rm_eq_rstfp" + '(;;(agenda-ordering-function #'fifo) + ;;(row-weight-limit 8) ;8 is minimum value for which proof can be found + (declare-constant 'zero :alias 'additive_identity) + (declare-constant 'a) + (declare-constant 'b) + (declare-constant 'c) + (declare-function 'j 2 :alias 'add :ordering-status :left-to-right) + (declare-function 'f 2 :alias 'multiply :ordering-status :left-to-right) + (declare-function 'g 1 :alias 'additive_inverse :kbo-weight 0) + (declare-relation 's 3 :alias 'sum) + (declare-relation 'p 3 :alias 'product) + (ordering-functions>constants t) + (declare-ordering-greaterp 'g 'f 'j 'c 'b 'a 'zero) + (use-hyperresolution t) + (use-term-ordering :kbo)))) + +(defun overbeek4 () + (refute-snark-example-file + "LCL024-1+rm_eq_rstfp" + '((declare-relation 'p 1 :alias 'is_a_theorem) + (declare-function 'e 2 :alias 'equivalent) + (use-hyperresolution t)))) + +(defun overbeek5 () + (refute-snark-example-file + "LCL038-1+rm_eq_rstfp" + '((declare-relation 'p 1 :alias 'is_a_theorem) + (declare-function 'i 2 :alias 'implies) + (use-hyperresolution t)))) + +(defun overbeek6 () + (refute-snark-example-file + "LCL111-1" + '((declare-relation 'p 1 :alias '|is_a_theorem|) + (declare-function 'i 2 :alias '|implies|) + (declare-function 'n 1 :alias '|not|) + ;;(agenda-ordering-function #'fifo) ;very fast with fifo ordering + (use-hyperresolution t) + (level-pref-for-giving 1)) + :format :tptp)) + +(defun overbeek7 () + (refute-snark-example-file + "LCL114-1+rm_eq_rstfp" + '((declare-relation 'p 1 :alias 'is_a_theorem) + (declare-function 'i 2 :alias 'implies) + (declare-function 'n 1 :alias 'not) + (use-hyperresolution t) + (level-pref-for-giving 1)))) + +(defun overbeek4-1 () + (refute-snark-example-file + "LCL024-1+rm_eq_rstfp" + '((declare-relation 'p 1 :alias 'is_a_theorem) + (declare-function 'e 2 :alias 'equivalent) + (use-resolution t) + (use-literal-ordering-with-resolution 'literal-ordering-a)))) + +(defun overbeek5-1 () + (refute-snark-example-file + "LCL038-1+rm_eq_rstfp" + '((declare-relation 'p 1 :alias 'is_a_theorem) + (declare-function 'i 2 :alias 'implies) + (use-resolution t) + (use-literal-ordering-with-resolution 'literal-ordering-a)))) + +(defun overbeek6-1 () + (refute-snark-example-file + "LCL111-1" + '((declare-relation 'p 1 :alias '|is_a_theorem|) + (declare-function 'i 2 :alias '|implies|) + (declare-function 'n 1 :alias '|not|) + (use-resolution t) + (assert-context :current) + (use-literal-ordering-with-resolution 'literal-ordering-a) + (level-pref-for-giving 1)) + :format :tptp)) + +(defun overbeek7-1 () + (refute-snark-example-file + "LCL114-1+rm_eq_rstfp" + '((declare-relation 'p 1 :alias 'is_a_theorem) + (declare-function 'i 2 :alias 'implies) + (declare-function 'n 1 :alias 'not) + (use-resolution t) + (use-literal-ordering-with-resolution 'literal-ordering-a) + (level-pref-for-giving 1)))) + +(defun overbeek1e () + (refute-snark-example-file + "GRP002-3+rm_eq_rstfp" + '((declare-constant 'e :alias 'identity) + (declare-constant 'a) + (declare-constant 'b) + (declare-function 'f 2 :alias 'multiply :ordering-status :left-to-right) + (declare-function 'g 1 :alias 'inverse :kbo-weight '(1 2)) + (declare-function 'h 2 :alias 'commutator :kbo-weight '(5 3 3) :ordering-status :left-to-right) + (ordering-functions>constants t) + (declare-ordering-greaterp 'h 'g 'f 'b 'a 'e) + (use-paramodulation t) + (use-term-ordering :kbo)))) + +(defun overbeek2e () + (refute-snark-example-file + "ROB005-1+rm_eq_rstfp" + '((declare-constant 'a) + (declare-constant 'b) + (declare-constant 'c) + (declare-function 'o 2 :alias 'add) + (declare-function 'n 1 :alias 'negate) + (ordering-functions>constants t) + (declare-ordering-greaterp 'n 'o 'a 'b 'c) + (use-paramodulation t)))) + +(defun overbeek3e () + (refute-snark-example-file + "BOO002-1+rm_eq_rstfp" + '(;;(agenda-ordering-function #'fifo) + ;;(row-weight-limit 15) ;15 is minimum value for which proof can be found + (declare-function 'f 3 :alias 'multiply :ORDERING-STATUS :RIGHT-TO-LEFT) + (declare-function 'g 1 :alias 'inverse) + (declare-constant 'a) + (declare-constant 'b) + (declare-ordering-greaterp 'b 'a 'g 'f) + (use-paramodulation t) + (use-term-ordering :kbo)))) + +(defun overbeek4e () + (refute-snark-example-file + "GRP014-1+rm_eq_rstfp" + '((declare-constant 'a) + (declare-constant 'b) + (declare-constant 'c) + (declare-function 'f 2 :alias 'multiply :ordering-status :left-to-right) + (declare-function 'i 1 :alias 'inverse :kbo-weight 0) + (ordering-functions>constants t) + (declare-ordering-greaterp 'i 'f 'c 'b 'a) + (use-paramodulation t) + (use-term-ordering :kbo) ;KBO better than RPO 4/20/92 + ;;(use-function-creation t) ;constant-creation only, insert new symbols into KB ordering + ))) + +(defun overbeek5e () + (refute-snark-example-file + "LCL109-2+rm_eq_rstfp" + '(;;(ROW-WEIGHT-LIMIT 21) ;21 works, think 19 will too + (declare-function 'i 2 :alias 'implies #| :ordering-status :left-to-right |#) + (declare-function 'n 1 :alias 'not) + (declare-constant 'a) + (declare-constant 'b) + (declare-constant 't :alias 'true0) + (ordering-functions>constants t) + (declare-ordering-greaterp 'i 'n 'a 'b 't) + (use-paramodulation t)))) + +(defun overbeek6e () + (refute-snark-example-file + "COL049-1+rm_eq_rstfp" + '(;;(row-weight-limit 21) ;don't know what value works (19 doesn't) + (declare-function 'a 2 :alias 'apply :ordering-status :left-to-right) + (declare-function 'f 1 :weight-code (list (constantly 1))) + (declare-constant 'b) + (declare-constant 'm) + (declare-constant 'w) + (ordering-functions>constants t) + (declare-ordering-greaterp 'a 'f 'b 'w 'm) + (use-paramodulation t)))) + +(defun overbeek7e () + (refute-snark-example-file + "RNG009-5+rm_eq_rstfp" + '((row-weight-before-simplification-limit 100) + (row-weight-limit 50) + (declare-constant 'zero :alias 'additive_identity) + (declare-function '* 2 :alias 'multiply :ordering-status :left-to-right) + (declare-function '- 1 :alias 'additive_inverse) + (declare-function '+ 2 :alias 'add) + (ordering-functions>constants t) + (declare-ordering-greaterp '* '- '+ 'zero) + (DECLARE-CANCELLATION-LAW '= '+ 'zero) + (use-paramodulation t)))) + +(defun overbeek7e-1 () + (refute-snark-example-file + "RNG009-5+rm_eq_rstfp" + '((row-weight-before-simplification-limit 100) + (row-weight-limit 50) + (declare-constant 'zero :alias 'additive_identity) + (declare-function '* 2 :alias 'multiply :ordering-status :left-to-right) + (declare-function '- 1 :alias 'additive_inverse) + (declare-function '+ 2 :alias 'add) + (ordering-functions>constants t) + (declare-ordering-greaterp '* '- '+ 'zero) + (DECLARE-CANCELLATION-LAW '= '+ 'zero) + (use-paramodulation t) + (use-associative-unification t)))) + +(defun overbeek8e () + (refute-snark-example-file + "COL003-1+rm_eq_rstfp" + '((declare-function 'a 2 :alias 'apply :ordering-status :left-to-right) + (declare-function 'f 1 :weight-code (list (constantly 1))) + (declare-constant 'b) + (declare-constant 'w) + (ordering-functions>constants t) + (declare-ordering-greaterp 'a 'f 'b 'w) + (use-paramodulation t)))) + +(defun overbeek9e () + (refute-snark-example-file + "RNG010-5+rm_eq_rstfp" + '((use-paramodulation t)))) + +(defun overbeek10e () + (refute-snark-example-file + "RNG011-5+rm_eq_rstfp" + '((use-paramodulation t)))) + +;;; overbeek-test.lisp EOF diff --git a/examples/ramsey-examples.lisp b/examples/ramsey-examples.lisp new file mode 100644 index 0000000..ffd551c --- /dev/null +++ b/examples/ramsey-examples.lisp @@ -0,0 +1,191 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: ramsey-examples.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2006. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +;;; see http://mathworld.wolfram.com/RamseyNumber.html +;;; for Ramsey Number definition and results +;;; +;;; r( 3, 3) = 6 done +;;; r( 3, 4) = 9 done +;;; r( 3, 5) = 14 done +;;; r( 3, 6) = 18 +;;; r( 3, 7) = 23 +;;; r( 3, 8) = 28 +;;; r( 3, 9) = 36 +;;; r( 3,10) in [40,43] +;;; r( 4, 4) = 18 +;;; r( 4, 5) = 25 +;;; r( 4, 6) in [35,41] +;;; r( 5, 5) in [43,49] +;;; r( 6, 6) in [102,165] + +(defun ramsey-3-3 (n) + ;; results: found to be satisfiable for n=5, unsatisfiable for n=6 (should be unsatisfiable iff n>=6) + (let ((clause-set (make-dp-clause-set))) + (no-clique-of-order-3 n clause-set) + (no-independent-set-of-order-3 n clause-set) + (dp-satisfiable-p clause-set :atom-choice-function #'choose-an-atom-of-a-shortest-clause))) + +(defun ramsey-3-4 (n) + ;; results: found to be satisfiable for n=8, unsatisfiable for n=9 (should be unsatisfiable iff n>=9) + (let ((clause-set (make-dp-clause-set))) + (no-clique-of-order-3 n clause-set) + (no-independent-set-of-order-4 n clause-set) + (dp-satisfiable-p clause-set :atom-choice-function #'choose-an-atom-of-a-shortest-clause))) + +(defun ramsey-3-5 (n) + ;; results: found to be satisfiable for n=13, unsatisfiable for n=14 (should be unsatisfiable iff n>=14) + (let ((clause-set (make-dp-clause-set))) + (no-clique-of-order-3 n clause-set) + (no-independent-set-of-order-5 n clause-set) + (dp-satisfiable-p clause-set :atom-choice-function #'choose-an-atom-of-a-shortest-clause))) + +(defun ramsey-3-6 (n) + ;; results: found to be satisfiable for n=17, unsatisfiable for n=?? (should be unsatisfiable iff n>=18) + (let ((clause-set (make-dp-clause-set))) + (no-clique-of-order-3 n clause-set) + (no-independent-set-of-order-6 n clause-set) + (dp-satisfiable-p clause-set :atom-choice-function #'choose-an-atom-of-a-shortest-clause))) + +(defun ramsey-4-4 (n) + ;; results: found to be satisfiable for n=17, unsatisfiable for n=?? (should be unsatisfiable iff n>=18) + (let ((clause-set (make-dp-clause-set))) + (no-clique-of-order-4 n clause-set) + (no-independent-set-of-order-4 n clause-set) + (dp-satisfiable-p clause-set :atom-choice-function #'choose-an-atom-of-a-shortest-clause))) + +(defun ramsey-4-5 (n) + ;; results: found to be satisfiable for n=23, unsatisfiable for n=?? (should be unsatisfiable iff n>=25) + (let ((clause-set (make-dp-clause-set))) + (no-clique-of-order-4 n clause-set) + (no-independent-set-of-order-5 n clause-set) + (dp-satisfiable-p clause-set :atom-choice-function #'choose-an-atom-of-a-shortest-clause-WITH-MOST-OCCURRENCES-RANDOMLY))) + +(defun ramsey-4-6 (n) + ;; results: found to be satisfiable for n=29, unsatisfiable for n=?? + (let ((clause-set (make-dp-clause-set))) + (no-clique-of-order-4 n clause-set) + (no-independent-set-of-order-6 n clause-set) + (dp-satisfiable-p clause-set :atom-choice-function #'choose-an-atom-of-a-shortest-clause-WITH-MOST-OCCURRENCES-RANDOMLY))) + +(defun no-clique-of-order-3 (nnodes clause-set) + ;; in every 3 node subset, at least one pair is not connected + (dp-insert-wff `(forall ((i :in (ints 1 ,nnodes)) + (j :in (ints i ,nnodes) :except i) + (k :in (ints j ,nnodes) :except j)) + (or (not (c i j)) (not (c i k)) (not (c j k)))) + clause-set)) + +(defun no-clique-of-order-4 (nnodes clause-set) + ;; in every 4 node subset, at least one pair is not connected + (dp-insert-wff `(forall ((i :in (ints 1 ,nnodes)) + (j :in (ints i ,nnodes) :except i) + (k :in (ints j ,nnodes) :except j) + (l :in (ints k ,nnodes) :except k)) + (or (not (c i j)) (not (c i k)) (not (c i l)) (not (c j k)) (not (c j l)) (not (c k l)))) + clause-set)) + +(defun no-clique-of-order-5 (nnodes clause-set) + ;; in every 5 node subset, at least one pair is not connected + (dp-insert-wff `(forall ((i :in (ints 1 ,nnodes)) + (j :in (ints i ,nnodes) :except i) + (k :in (ints j ,nnodes) :except j) + (l :in (ints k ,nnodes) :except k) + (m :in (ints l ,nnodes) :except l)) + (or (not (c i j)) (not (c i k)) (not (c i l)) (not (c i m)) + (not (c j k)) (not (c j l)) (not (c j m)) + (not (c k l)) (not (c k m)) + (not (c l m)))) + clause-set)) + +(defun no-clique-of-order-6 (nnodes clause-set) + ;; in every 6 node subset, at least one pair is not connected + (dp-insert-wff `(forall ((i :in (ints 1 ,nnodes)) + (j :in (ints i ,nnodes) :except i) + (k :in (ints j ,nnodes) :except j) + (l :in (ints k ,nnodes) :except k) + (m :in (ints l ,nnodes) :except l) + (n :in (ints m ,nnodes) :except m)) + (or (not (c i j)) (not (c i k)) (not (c i l)) (not (c i m)) (not (c i n)) + (not (c j k)) (not (c j l)) (not (c j m)) (not (c j n)) + (not (c k l)) (not (c k m)) (not (c k n)) + (not (c l m)) (not (c l n)) + (not (c m n)))) + clause-set)) + +(defun no-independent-set-of-order-3 (nnodes clause-set) + ;; in every 3 node subset, at least one pair is connected + (dp-insert-wff `(forall ((i :in (ints 1 ,nnodes)) + (j :in (ints i ,nnodes) :except i) + (k :in (ints j ,nnodes) :except j)) + (or (c i j) (c i k) (c j k))) + clause-set)) + +(defun no-independent-set-of-order-4 (nnodes clause-set) + ;; in every 4 node subset, at least one pair is connected + (dp-insert-wff `(forall ((i :in (ints 1 ,nnodes)) + (j :in (ints i ,nnodes) :except i) + (k :in (ints j ,nnodes) :except j) + (l :in (ints k ,nnodes) :except k)) + (or (c i j) (c i k) (c i l) (c j k) (c j l) (c k l))) + clause-set)) + +(defun no-independent-set-of-order-5 (nnodes clause-set) + ;; in every 5 node-subset, at least one pair is connected + (dp-insert-wff `(forall ((i :in (ints 1 ,nnodes)) + (j :in (ints i ,nnodes) :except i) + (k :in (ints j ,nnodes) :except j) + (l :in (ints k ,nnodes) :except k) + (m :in (ints l ,nnodes) :except l)) + (or (c i j) (c i k) (c i l) (c i m) + (c j k) (c j l) (c j m) + (c k l) (c k m) + (c l m))) + clause-set)) + +(defun no-independent-set-of-order-6 (nnodes clause-set) + ;; in every 6 node-subset, at least one pair is connected + (dp-insert-wff `(forall ((i :in (ints 1 ,nnodes)) + (j :in (ints i ,nnodes) :except i) + (k :in (ints j ,nnodes) :except j) + (l :in (ints k ,nnodes) :except k) + (m :in (ints l ,nnodes) :except l) + (n :in (ints m ,nnodes) :except m)) + (or (c i j) (c i k) (c i l) (c i m) (c i n) + (c j k) (c j l) (c j m) (c j n) + (c k l) (c k m) (c k n) + (c l m) (c l n) + (c m n))) + clause-set)) + +(defun ramsey-test () + ;; there doesn't seem to be any difference in search space size between choose-an-atom-of-a-shortest-clause and choose-an-atom-of-a-shortest-clause-randomly + ;; choose-an-atom-of-a-shortest-clause-with-most-occurrences-randomly seems to work much better for satisfiable instances + (cl:assert (eval (print '(ramsey-3-3 5)))) ;2 branches + (cl:assert (not (eval (print '(ramsey-3-3 6))))) ;22 branches + (cl:assert (eval (print '(ramsey-3-4 8)))) ;4 branches + (cl:assert (not (eval (print '(ramsey-3-4 9))))) ;10,251 branches + (cl:assert (eval (print '(ramsey-3-5 13)))) ;93,125 branches +;;(cl:assert (not (eval (print '(ramsey-3-5 14))))) ;1,078,238,816 branches +;;(cl:assert (eval (print '(ramsey-4-4 17)))) ;56,181,666 branches +;;(cl:assert (not (eval (print '(ramsey-4-4 18))))) + ) + +;;; ramsey-examples.lisp EOF diff --git a/examples/reverse-example.lisp b/examples/reverse-example.lisp new file mode 100644 index 0000000..cd1dc74 --- /dev/null +++ b/examples/reverse-example.lisp @@ -0,0 +1,51 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: reverse-example.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2006. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +(defun reverse-example (&key (length 3) magic) + (let ((l nil)) + (dotimes (i length) + (push i l)) + (initialize) + (declare-function '$$cons 2 :new-name 'cons) + (declare-function '$$list :any :new-name 'list) + (declare-function '$$list* :any :new-name 'list*) + (cond + (magic + (use-hyperresolution t) + (use-magic-transformation t)) + (t + (use-resolution t) + (assert-supported nil) + (assert-sequential t) + (print-rows-shortened t))) + (assert '(reverse nil nil)) + (assert '(implied-by + (reverse (cons ?x ?l) ?l1) + (and + (reverse ?l ?l2) + (append ?l2 (cons ?x nil) ?l1)))) + (assert '(append nil ?l ?l)) + (assert '(implied-by + (append (cons ?x ?l1) ?l2 (cons ?x ?l3)) + (append ?l1 ?l2 ?l3))) + (prove `(reverse (list ,@l) ?l) :answer '(values ?l)))) + +;;; reverse-example.lisp EOF diff --git a/examples/snark-test b/examples/snark-test new file mode 100644 index 0000000..ba39d59 --- /dev/null +++ b/examples/snark-test @@ -0,0 +1,19 @@ +;;; a script to run some SNARK examples +;;; usage: +;;; cd snark +;;; lisp < examples/snark-test >& examples/snark-test.out & + +#-snark (load "snark-system.lisp") +#-snark (make-snark-system) +(in-package :snark-user) +(default-print-row-wffs-prettily nil) +(overbeek-test) +(time (steamroller-example)) +(time (front-last-example)) +(time (reverse-example)) +(time (reverse-example :magic t)) +(time (hot-drink-example)) +(coder-test) +(time (snark-dpll::queens-problem 8 :find-all-models -1)) +(generate-latin-squares 7) +(quit) diff --git a/examples/steamroller-example.lisp b/examples/steamroller-example.lisp new file mode 100644 index 0000000..bb866cc --- /dev/null +++ b/examples/steamroller-example.lisp @@ -0,0 +1,82 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: steamroller-example.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +(defun steamroller-example0 () + (refute-snark-example-file + "PUZ031+1" + '((use-hyperresolution)))) + +(defun steamroller-example () + (initialize) + (use-hyperresolution) + + (declare-sort 'animal :subsorts-incompatible t) + (declare-sort 'plant :subsorts-incompatible t) + (declare-subsort 'bird 'animal) + (declare-subsort 'caterpillar 'animal) + (declare-subsort 'fox 'animal) + (declare-subsort 'snail 'animal) + (declare-subsort 'wolf 'animal) + (declare-subsort 'grain 'plant) + + (declare-relation 'e 2 :sort '((1 animal))) ;animal*true + (declare-relation 'm 2 :sort '((t animal))) ;animal*animal + + (declare-variable '?a1 :sort 'animal) + (declare-variable '?a2 :sort 'animal) + + (assertion (forall ((?s1 snail) (?b1 bird)) ;KIF-style sort specification + (m ?s1 ?b1)) ;all KIF variables begin with ? + :name snails-are-smaller-than-birds) + (assertion (forall ((b1 :sort bird) (f1 :sort fox)) ;SNARK-preferred sort specification + (m b1 f1)) + :name birds-are-smaller-than-foxes) + (assertion (forall ((f1 true :sort fox) + (w1 wolf :sort wolf)) ;this works too + (m f1 w1)) + :name foxes-are-smaller-than-wolves) + (assertion (forall ((w1 wolf) (f1 fox)) + (not (e w1 f1))) + :name wolves-dont-eat-foxes) + (assertion (forall ((w1 :sort wolf) (g1 :sort grain)) + (not (e w1 g1))) + :name wolves-dont-eat-grain) + (assertion (forall ((b1 :sort bird) (c1 :sort caterpillar)) + (e b1 c1)) + :name birds-eat-caterpillars) + (assertion (forall ((b1 :sort bird) (s1 :sort snail)) + (not (e b1 s1))) + :name birds-dont-eat-snails) + (assertion (forall ((c1 :sort caterpillar)) + (exists ((p1 :sort plant)) + (e c1 p1))) + :name caterpillars-eat-some-plants) + (assertion (forall ((s1 :sort snail)) + (exists ((p1 :sort plant)) + (e s1 p1))) + :name snails-eat-some-plants) + (assertion (forall ((p1 :sort plant) (p2 :sort plant)) + (implied-by (or (e ?a1 ?a2) (e ?a1 p1)) (and (m ?a2 ?a1) (e ?a2 p2))))) + + (prove '(and (e ?x.animal ?y.animal) (e ?y.animal ?z.grain)) + :answer '(values ?x.animal ?y.animal ?z.grain))) + +;;; steamroller-example.lisp EOF diff --git a/make-snark-ccl b/make-snark-ccl new file mode 100755 index 0000000..dec5068 --- /dev/null +++ b/make-snark-ccl @@ -0,0 +1,6 @@ +ccl < compile >& compile.out +ccl << ENDOFSTDIN +(load "snark-system.lisp") +(make-snark-system) +(save-snark-system) +ENDOFSTDIN diff --git a/make-snark-ccl64 b/make-snark-ccl64 new file mode 100755 index 0000000..12f6bca --- /dev/null +++ b/make-snark-ccl64 @@ -0,0 +1,6 @@ +ccl64 < compile >& compile.out +ccl64 << ENDOFSTDIN +(load "snark-system.lisp") +(make-snark-system) +(save-snark-system) +ENDOFSTDIN diff --git a/make-snark-sbcl b/make-snark-sbcl new file mode 100755 index 0000000..9e8f4f0 --- /dev/null +++ b/make-snark-sbcl @@ -0,0 +1,6 @@ +sbcl < compile >& compile.out +sbcl << ENDOFSTDIN +(load "snark-system.lisp") +(make-snark-system) +(save-snark-system :name "snark" :executable t) +ENDOFSTDIN diff --git a/make-snark-sbcl64 b/make-snark-sbcl64 new file mode 100755 index 0000000..7a2bbf8 --- /dev/null +++ b/make-snark-sbcl64 @@ -0,0 +1,6 @@ +~/sbcl-1.0.29-x86_64-darwin/run-sbcl.sh < compile >& compile.out +~/sbcl-1.0.29-x86_64-darwin/run-sbcl.sh << ENDOFSTDIN +(load "snark-system.lisp") +(make-snark-system) +(save-snark-system :name "snark64" :executable t) +ENDOFSTDIN diff --git a/run-snark b/run-snark new file mode 100755 index 0000000..a5a274a --- /dev/null +++ b/run-snark @@ -0,0 +1,55 @@ +#! /bin/tcsh + +# this is Geoff's run-snark script for SystemOnTPTP as of 2012-08-21 + +if (! -f $1) then + echo "Missing filename" + exit +endif +echo $1 +if ($2 == "") then + set runtimelimit = nil +else + set runtimelimit = $2 +endif + +set this_directory=`dirname $0` +$this_directory/snark << ENDOFSTDIN +#+sbcl (sb-ext:disable-debugger) +(in-package :snark-user) + +(defvar snark-tptp-options) +(setf snark-tptp-options + '( + (agenda-length-limit nil) + (agenda-length-before-simplification-limit nil) + (use-hyperresolution t) + (use-ur-resolution t) + (use-paramodulation t) + (use-factoring :pos) + (use-literal-ordering-with-hyperresolution 'literal-ordering-p) + (use-literal-ordering-with-paramodulation 'literal-ordering-p) + (ordering-functions>constants t) + (assert-context :current) + (run-time-limit $runtimelimit) + (listen-for-commands nil) + (use-closure-when-satisfiable t) + (print-rows-when-given nil) + (print-rows-when-derived nil) + (print-unorientable-rows nil) + (print-row-wffs-prettily nil) + (print-final-rows :tptp) ;System on TPTP uses value :tptp + (print-options-when-starting nil) ;System on TPTP uses this + (use-variable-name-sorts nil) + (use-purity-test t) + (use-relevance-test t) + (declare-tptp-symbols1) + (declare-tptp-symbols2) + )) + +(setf *tptp-environment-variable* "$TPTP") +(refute-file "$1" :options snark-tptp-options :format :tptp) + +(quit) +ENDOFSTDIN + diff --git a/snark-agenda.asd b/snark-agenda.asd new file mode 100644 index 0000000..c0d1fe1 --- /dev/null +++ b/snark-agenda.asd @@ -0,0 +1,14 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-agenda + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-auxiliary-packages + #:snark-lisp #:snark-deque #:snark-sparse-array) + :pathname "src/" + :components ((:file "agenda"))) + + diff --git a/snark-auxiliary-packages.asd b/snark-auxiliary-packages.asd new file mode 100644 index 0000000..a80ba28 --- /dev/null +++ b/snark-auxiliary-packages.asd @@ -0,0 +1,12 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-auxiliary-packages + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on () + :pathname "src/" + :components ((:file "auxiliary-packages"))) + diff --git a/snark-deque.asd b/snark-deque.asd new file mode 100644 index 0000000..4e233b8 --- /dev/null +++ b/snark-deque.asd @@ -0,0 +1,12 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-deque + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-auxiliary-packages #:snark-lisp) + :pathname "src/" + :components ((:file "deque2"))) + diff --git a/snark-dpll.asd b/snark-dpll.asd new file mode 100644 index 0000000..83e4cb9 --- /dev/null +++ b/snark-dpll.asd @@ -0,0 +1,11 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-dpll + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-auxiliary-packages #:snark-lisp) + :pathname "src/" + :components ((:file "davis-putnam3"))) diff --git a/snark-examples.asd b/snark-examples.asd new file mode 100644 index 0000000..3901e20 --- /dev/null +++ b/snark-examples.asd @@ -0,0 +1,18 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-examples + :serial t + :description "Examples for Snark" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :author "Matthias Hölzl, LMU" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark) + :pathname "examples/" + :components ((:file "overbeek-test") + (:file "front-last-example") + (:file "steamroller-example") + (:file "reverse-example") + (:file "hot-drink-example") + (:file "coder-examples") + (:file "latin-squares"))) diff --git a/snark-feature.asd b/snark-feature.asd new file mode 100644 index 0000000..dc35ca7 --- /dev/null +++ b/snark-feature.asd @@ -0,0 +1,12 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-feature + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-auxiliary-packages #:snark-lisp) + :pathname "src/" + :components ((:file "feature"))) + diff --git a/snark-implementation.asd b/snark-implementation.asd new file mode 100644 index 0000000..2abdcaf --- /dev/null +++ b/snark-implementation.asd @@ -0,0 +1,92 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-implementation + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-auxiliary-packages + #:snark-lisp + #:snark-sparse-array + #:snark-numbering + #:snark-deque + #:snark-agenda + #:snark-dpll + #:snark-feature + #:snark-infix-reader + #:snark-pkg) + :pathname "src/" + :components ((:file "useful") + (:file "posets") + (:file "solve-sum") + (:file "globals") + (:file "options") + (:file "terms2") + (:file "rows") + (:file "row-contexts") + (:file "constants") + (:file "functions") + (:file "variables") + (:file "subst") + (:file "substitute") + (:file "symbol-table2") + (:file "symbol-definitions") + (:file "assertion-analysis") + (:file "jepd-relations-tables") + (:file "jepd-relations") + (:file "date-reasoning2") + (:file "constraints") + (:file "constraint-purify") + (:file "connectives") + (:file "wffs") + ;; (:file "equality-elimination2") + (:file "nonhorn-magic-set") + (:file "dp-refute") + (:file "sorts-functions") + (:file "sorts-interface") + (:file "sorts") + (:file "argument-bag-ac") + (:file "argument-list-a1") + (:file "unify") + (:file "unify-bag") + (:file "subsume-bag") + (:file "unify-vector") + (:file "equal") + (:file "variant") + (:file "alists") + (:file "term-hash") + (:file "trie-index") + (:file "path-index") + (:file "trie") + (:file "feature-vector") + (:file "feature-vector-trie") + (:file "feature-vector-index") + (:file "term-memory") + ;; (:file "instance-graph" "instance-graph2") + (:file "weight") + (:file "eval") + (:file "input") + (:file "output") + (:file "simplification-ordering") + (:file "symbol-ordering") + (:file "multiset-ordering") + (:file "recursive-path-ordering") + (:file "ac-rpo") + (:file "knuth-bendix-ordering2") + (:file "rewrite") + (:file "rewrite-code") + (:file "code-for-strings2") + (:file "code-for-numbers3") + (:file "code-for-lists2") + (:file "code-for-bags4") + (:file "resolve-code") + (:file "resolve-code-tables") + (:file "main") + (:file "subsume") + (:file "subsume-clause") + (:file "interactive") + (:file "assertion-file") + (:file "tptp") + (:file "tptp-symbols") + (:file "coder"))) diff --git a/snark-infix-reader.asd b/snark-infix-reader.asd new file mode 100644 index 0000000..b2fb0c3 --- /dev/null +++ b/snark-infix-reader.asd @@ -0,0 +1,13 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-infix-reader + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-auxiliary-packages #:snark-lisp) + :pathname "src/" + :components ((:file "infix-operators") + (:file "infix-reader"))) + diff --git a/snark-lisp.asd b/snark-lisp.asd new file mode 100644 index 0000000..c01bd81 --- /dev/null +++ b/snark-lisp.asd @@ -0,0 +1,18 @@ +(asdf:defsystem #:snark-lisp + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-auxiliary-packages) + :pathname "src/" + :components ((:file "mvlet") + (:file "progc") + (:file "lisp") + (:file "collectors") + (:file "map-file") + (:file "clocks") + (:file "counters") + (:file "pattern-match") + (:file "topological-sort"))) + diff --git a/snark-loads.asd b/snark-loads.asd new file mode 100644 index 0000000..fb0c7c2 --- /dev/null +++ b/snark-loads.asd @@ -0,0 +1,11 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-loads + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on () + :pathname "src/" + :components ((:file "loads"))) diff --git a/snark-numbering.asd b/snark-numbering.asd new file mode 100644 index 0000000..a87e02f --- /dev/null +++ b/snark-numbering.asd @@ -0,0 +1,11 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-numbering + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-auxiliary-packages #:snark-lisp #:snark-sparse-array) + :pathname "src/" + :components ((:file "numbering"))) diff --git a/snark-pkg.asd b/snark-pkg.asd new file mode 100644 index 0000000..67529c7 --- /dev/null +++ b/snark-pkg.asd @@ -0,0 +1,12 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-pkg + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-dpll) + :pathname "src/" + :components ((:file "snark-pkg"))) + diff --git a/snark-sparse-array.asd b/snark-sparse-array.asd new file mode 100644 index 0000000..04927a9 --- /dev/null +++ b/snark-sparse-array.asd @@ -0,0 +1,14 @@ +(in-package :common-lisp-user) + +(asdf:defsystem #:snark-sparse-array + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-auxiliary-packages #:snark-lisp) + :pathname "src/" + :components ((:file "sparse-vector5") + (:file "sparse-array") + (:file "sparse-vector-expression"))) + diff --git a/snark-system.lisp b/snark-system.lisp new file mode 100644 index 0000000..ca6b09b --- /dev/null +++ b/snark-system.lisp @@ -0,0 +1,160 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: snark-system.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +;;; load files from the same directory that this file was loaded from + +(defparameter *snark-system-pathname* *load-truename*) + +(defparameter *snark-files2* + '("loads" + "lisp-system" + "deque-system" + "sparse-array-system" + "numbering-system" + "agenda-system" + "infix-reader-system" + "feature-system" + "dpll-system" + "snark-pkg")) + +(defparameter *snark-files* + '("useful" + "posets" + "solve-sum" + "globals" + "options" + "terms2" + "rows" + "row-contexts" + "constants" + "functions" + "variables" + "subst" + "substitute" + "symbol-table2" + "symbol-definitions" + "assertion-analysis" + "jepd-relations-tables" "jepd-relations" "date-reasoning2" + "constraints" +;; "constraint-purify" + "connectives" + "wffs" +;; "equality-elimination2" + "nonhorn-magic-set" + "dp-refute" + "sorts-functions" + "sorts-interface" + "sorts" + "argument-bag-ac" + "argument-list-a1" + "unify" + "unify-bag" "subsume-bag" + "unify-vector" + "equal" + "variant" + "alists" + "term-hash" + "trie-index" + "path-index" + "trie" "feature-vector" "feature-vector-trie" "feature-vector-index" + "term-memory" +;; "instance-graph" "instance-graph2" + "weight" + "eval" + "input" + "output" + "simplification-ordering" + "symbol-ordering" + "multiset-ordering" + "recursive-path-ordering" "ac-rpo" + "knuth-bendix-ordering2" + "rewrite" + "rewrite-code" + "code-for-strings2" + "code-for-numbers3" + "code-for-lists2" + "code-for-bags4" + "resolve-code" + "resolve-code-tables" + "main" + "subsume" "subsume-clause" + "assertion-file" + "tptp" + "tptp-symbols" + "coder" + ("examples" "overbeek-test") + ("examples" "front-last-example") + ("examples" "steamroller-example") + ("examples" "reverse-example") + ("examples" "hot-drink-example") + ("examples" "coder-examples") + ("examples" "latin-squares") + "patches" + )) + +(defvar *compile-me* nil) + +(defun make-snark-system (&optional (*compile-me* *compile-me*)) + (pushnew :snark *features*) + #+cmu (setf extensions::*gc-verbose* nil) + (when (eq *compile-me* :optimize) + (proclaim (print '(optimize (safety 1) (space 1) (speed 3) (debug 1))))) + (with-compilation-unit () + (dolist (name *snark-files2*) + (let* ((dir (if (consp name) + (append (pathname-directory *snark-system-pathname*) (butlast name)) + (append (pathname-directory *snark-system-pathname*) (list "src")))) + (name (if (consp name) (first (last name)) name)) + (file (make-pathname :directory dir :name name :defaults *snark-system-pathname*))) + (load file))) + (setf *package* (find-package :snark)) + #+gcl (shadow '(#:assert #:substitute #:variable)) + (dolist (name *snark-files*) + (let* ((dir (if (consp name) + (append (pathname-directory *snark-system-pathname*) (butlast name)) + (append (pathname-directory *snark-system-pathname*) (list "src")))) + (name (if (consp name) (first (last name)) name)) + (file (make-pathname :directory dir :name name :defaults *snark-system-pathname*))) + (load (if *compile-me* + (compile-file file) + (or (probe-file (compile-file-pathname file)) file)))))) +;;#-(or symbolics mcl) (load "/home/pacific1/stickel/spice/build.lisp") + (setf *package* (find-package :snark-user)) + (setf *print-pretty* nil) + #+openmcl (egc nil) + (funcall (intern (symbol-name :initialize) :snark))) + +#+ignore +(defun fix-snark-files () + (let ((dir (pathname-directory cl-user::*snark-system-pathname*))) + (dolist (x (append + (directory + (make-pathname :directory (append dir (list "src")) :name :wild :type "lisp")) + (directory + (make-pathname :directory (append dir (list "Private")) :name :wild :type "lisp")) + (directory + (make-pathname :directory (append dir (list "examples")) :name :wild :type "lisp")) + (directory + (make-pathname :directory (append dir (list "examples")) :name :wild :type "kif")))) + (ccl:set-mac-file-type x :text) + (ccl:set-mac-file-creator x :ccl2)))) + +;;; snark-system.lisp EOF diff --git a/snark.asd b/snark.asd new file mode 100644 index 0000000..cbc42f1 --- /dev/null +++ b/snark.asd @@ -0,0 +1,13 @@ +(in-package #:common-lisp-user) + +(asdf:defsystem #:snark + :serial t + :description "The Snark Theorem Prover" + :version "20120808r022" + :author "Mark E. Stickel, SRI International" + :license "MPL 1.1, see file LICENSE" + :depends-on (#:snark-implementation) + :components ()) + + + diff --git a/src/ac-rpo.lisp b/src/ac-rpo.lisp new file mode 100644 index 0000000..75c6231 --- /dev/null +++ b/src/ac-rpo.lisp @@ -0,0 +1,304 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: ac-rpo.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; recursive-path-ordering extensions for Rubio's "A fully syntactic AC-RPO" + +(defun ac-rpo-compare-compounds (fn xargs yargs subst) + (or (ac-rpo-cache-lookup fn xargs yargs) + (ac-rpo-cache-store fn xargs yargs (ac-rpo-compare-compounds* fn xargs yargs subst)))) + +(defun ac-rpo-compare-compounds* (fn xargs yargs subst) + (let ((com1 nil) (com2 nil) (com3 nil) (com4 nil) + (always-> t) (always-< t) + big-head-of-x no-small-head-of-x + big-head-of-y no-small-head-of-y) + (when (and (eq '= (setf com1 (compare-argument-counts xargs yargs subst))) + (eq '= (compare-term-multisets #'rpo-compare-terms xargs yargs subst '=))) + (return-from ac-rpo-compare-compounds* '=)) + (dolist (yargs1 (emb-no-big fn yargs subst)) + (case (ac-rpo-compare-compounds fn xargs yargs1 subst) + (? + (setf always-> nil)) + ((< =) + (return-from ac-rpo-compare-compounds* '<)))) + (when always-> + (setf (values big-head-of-x no-small-head-of-x) + (big-head-and-no-small-head fn xargs subst)) + (setf (values big-head-of-y no-small-head-of-y) + (big-head-and-no-small-head fn yargs subst)) + (when (and (case (setf com4 (compare-no-small-heads fn no-small-head-of-x no-small-head-of-y subst nil)) + ((> =) + t)) + (or (eq '> com1) + (eq '> (setf com2 (compare-term-multisets #'rpo-compare-terms big-head-of-x big-head-of-y subst nil))) + (case com1 + ((>= =) + (cond + ((and (eq big-head-of-y yargs) (eq '> com2)) + t) + ((and (eq big-head-of-x xargs) (neq '> com2)) + nil) + ((and (eq big-head-of-x xargs) (eq big-head-of-y yargs)) + (eq '> com2)) + (t + (eq '> (setf com3 (compare-term-multisets #'rpo-compare-terms xargs yargs subst nil))))))))) + (return-from ac-rpo-compare-compounds* '>))) + (dolist (xargs1 (emb-no-big fn xargs subst)) + (case (ac-rpo-compare-compounds fn xargs1 yargs subst) + (? + (setf always-< nil)) + ((> =) + (return-from ac-rpo-compare-compounds* '>)))) + (when always-< + (unless always-> + (setf (values big-head-of-x no-small-head-of-x) + (big-head-and-no-small-head fn xargs subst)) + (setf (values big-head-of-y no-small-head-of-y) + (big-head-and-no-small-head fn yargs subst))) + (when (and (case (or com4 (compare-no-small-heads fn no-small-head-of-x no-small-head-of-y subst nil)) + ((< =) + t)) + (or (eq '< com1) + (eq '< (or com2 (setf com2 (compare-term-multisets #'rpo-compare-terms big-head-of-x big-head-of-y subst nil)))) + (case com1 + ((<= =) + (cond + ((and (eq big-head-of-x xargs) (eq '< com2)) + t) + ((and (eq big-head-of-y yargs) (neq '< com2)) + nil) + ((and (eq big-head-of-x xargs) (eq big-head-of-y yargs)) + (eq '< com2)) + (t + (eq '< (or com3 (compare-term-multisets #'rpo-compare-terms xargs yargs subst '<))))))))) + (return-from ac-rpo-compare-compounds* '<))) + '?)) + +(defun emb-no-big (fn args subst) + ;; defn 12 + (let ((revargs nil) (result nil) result-last) + (dotails (args args) + (let ((argi (first args))) + (when (dereference argi subst :if-compound (neq '> (symbol-ordering-compare (head argi) fn))) + (dolist (argij (args argi)) + (collect (revappend + revargs + (dereference + argij subst + :if-variable (cons argij (rest args)) + :if-constant (cons argij (rest args)) + :if-compound (if (eq fn (head argij)) + (append (flatargs argij subst) (rest args)) + (cons argij (rest args))))) + result))) + (push argi revargs))) + result)) + +(defun big-head-and-no-small-head (fn args subst) + ;; defn 2: big-head is multiset of arguments for which (> (top arg) fn) + ;; defn 7: no-small-head is multiset of arguments for which (not (< (top arg) fn)) + (labels + ((big-head-and-no-small-head* (args) + (if (null args) + (values nil nil) + (let* ((l (rest args)) + (arg (first args)) + (com (dereference + arg subst + :if-variable '? + :if-constant (symbol-ordering-compare arg fn) + :if-compound (symbol-ordering-compare (head arg) fn)))) + (mvlet (((values big-head no-small-head) (big-head-and-no-small-head* l))) + (values (if (eq '> com) + (if (eq big-head l) args (cons arg big-head)) + big-head) + (if (neq '< com) + (if (eq no-small-head l) args (cons arg no-small-head)) + no-small-head))))))) + (big-head-and-no-small-head* args))) + +(defun compare-no-small-heads (fn no-small-head-of-x no-small-head-of-y subst testval) + ;; defn 11 comparison function adds the following + ;; conditions to the usual comparison + ;; (> compound compound') : (or (> (head compound) fn) (>= (head compound) (head compound')) + ;; (> constant compound) : (or (> constant fn) (> constant (head compound))) + ;; (> compound constant) : (or (> (head compound) fn) (> (head compound) constant)) + ;; (> compound variable) : (> (head compound) fn) + (labels + ((compare (x y subst testval) + (dereference2 + x y subst + :if-variable*variable (if (eq x y) '= '?) + :if-variable*constant '? + :if-constant*variable '? + :if-constant*constant (symbol-ordering-compare x y) + :if-compound*variable (if (eq '> (symbol-ordering-compare (head x) fn)) (rpo-compare-compound*variable x y subst testval) '?) + :if-variable*compound (if (eq '> (symbol-ordering-compare (head y) fn)) (rpo-compare-variable*compound x y subst testval) '?) + :if-compound*constant (ecase testval + (> + (and (or (eq '> (symbol-ordering-compare (head x) fn)) + (eq '> (symbol-ordering-compare (head x) y))) + (rpo-compare-compound*constant x y subst testval))) + (< + (and (or (eq '> (symbol-ordering-compare y fn)) + (eq '> (symbol-ordering-compare y (head x)))) + (rpo-compare-compound*constant x y subst testval))) + ((nil) + (ecase (rpo-compare-compound*constant x y subst testval) + (> + (if (or (eq '> (symbol-ordering-compare (head x) fn)) + (eq '> (symbol-ordering-compare (head x) y))) + '> + '?)) + (< + (if (or (eq '> (symbol-ordering-compare y fn)) + (eq '> (symbol-ordering-compare y (head x)))) + '< + '?)) + (? + '?)))) + :if-constant*compound (opposite-order (compare y x subst (opposite-order testval))) + :if-compound*compound (ecase testval + (= + (rpo-compare-compounds x y subst testval)) + (> + (and (or (eq '> (symbol-ordering-compare (head x) fn)) + (case (symbol-ordering-compare (head x) (head y)) + ((> =) + t))) + (rpo-compare-compounds x y subst testval))) + (< + (and (or (eq '> (symbol-ordering-compare (head y) fn)) + (case (symbol-ordering-compare (head y) (head x)) + ((> =) + t))) + (rpo-compare-compounds x y subst testval))) + ((nil) + (ecase (rpo-compare-compounds x y subst testval) + (> + (if (or (eq '> (symbol-ordering-compare (head x) fn)) + (case (symbol-ordering-compare (head x) (head y)) + ((> =) + t))) + '> + '?)) + (< + (if (or (eq '> (symbol-ordering-compare (head y) fn)) + (case (symbol-ordering-compare (head y) (head x)) + ((> =) + t))) + '< + '?)) + (= + '=) ;this added case is the only change in version 20090905r007 + (? + '?))))))) + (compare-term-multisets #'compare no-small-head-of-x no-small-head-of-y subst testval))) + +(defun compare-argument-counts (xargs yargs subst) + ;; xargs.subst and yargs.subst are already flattened argument lists + ;; of the same associative function + ;; this is the AC-RPO comparison of #(x) and #(y) that returns + ;; =, >, <, >=, =<, or ? + (let ((variable-counts nil) (variable-count 0) (nonvariable-count 0)) + (labels + ((count-arguments (args inc) + (declare (fixnum inc)) + (let (v) + (dolist (term args) + (dereference + term subst + :if-variable (cond + ((null variable-counts) + (setf variable-counts (cons (make-tc term inc) nil))) + ((setf v (assoc/eq term variable-counts)) + (incf (tc-count v) inc)) + (t + (push (make-tc term inc) variable-counts))) + :if-constant (incf nonvariable-count inc) + :if-compound (incf nonvariable-count inc)))))) + (count-arguments xargs 1) + (count-arguments yargs -1) + (dolist (v variable-counts) + (let ((c (tc-count v))) + (cond + ((plusp c) + (if (minusp variable-count) + (return-from compare-argument-counts '?) + (incf variable-count c))) + ((minusp c) + (if (plusp variable-count) + (return-from compare-argument-counts '?) + (incf variable-count c)))))) + (cond + ((plusp variable-count) + (cond + ((minusp nonvariable-count) + (let ((d (+ variable-count nonvariable-count))) + (cond + ((eql 0 d) + '>=) + ((plusp d) + '>) + (t + '?)))) + (t + '>))) + ((minusp variable-count) + (cond + ((plusp nonvariable-count) + (let ((d (+ variable-count nonvariable-count))) + (cond + ((eql 0 d) + '=<) + ((minusp d) + '<) + (t + '?)))) + (t + '<))) + ((eql 0 nonvariable-count) + '=) + (t + (if (plusp nonvariable-count) '> '<)))))) + +(defun ac-rpo-cache-lookup (fn xargs yargs) + (dolist (x *ac-rpo-cache* nil) + (when (and (eq fn (first x)) + (eql-list xargs (first (setf x (rest x)))) + (eql-list yargs (first (setf x (rest x))))) + (return (first (rest x)))))) + +(defun ac-rpo-cache-store (fn xargs yargs com) + (push (list fn xargs yargs com) *ac-rpo-cache*) + com) + +(defun eql-list (l1 l2) + (loop + (cond + ((null l1) + (return (null l2))) + ((null l2) + (return nil)) + ((neql (pop l1) (pop l2)) + (return nil))))) + +;;; ac-rpo.lisp EOF diff --git a/src/agenda-system.lisp b/src/agenda-system.lisp new file mode 100644 index 0000000..5460939 --- /dev/null +++ b/src/agenda-system.lisp @@ -0,0 +1,36 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: agenda-system.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2009. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +(defpackage :snark-agenda + (:use :common-lisp :snark-lisp :snark-deque :snark-sparse-array) + (:export + #:make-agenda + #:agenda-name #:agenda-length + #:agenda-insert #:agenda-delete + #:agenda-first #:pop-agenda #:mapnconc-agenda #:agenda-delete-if + #:limit-agenda-length + #:print-agenda + #:*agenda* + )) + +(loads "agenda") + +;;; agenda-system.lisp EOF diff --git a/src/agenda.lisp b/src/agenda.lisp new file mode 100644 index 0000000..0ee9de3 --- /dev/null +++ b/src/agenda.lisp @@ -0,0 +1,234 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-agenda -*- +;;; File: agenda.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2008. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-agenda) + +(defstruct (agenda + (:print-function print-agenda3) + (:copier nil)) + (name "" :read-only t) + (length 0) + (length-limit nil) + (length-limit-deletion-action #'identity :read-only t) + (same-item-p #'eql :read-only t) + (buckets (make-sparse-vector))) + +;;; an agenda index value (priority) is (list integer_1 ... integer_n) or (list* integer_1 ... integer_n) +;;; which are both treated as the same sequence integer_1 ... integer_n +;;; this includes (list* integer) = integer as an agenda index value +;;; agenda index values are compared lexicographically in left-to-right order +;;; if one is prefix of another, they must be equal, e.g., can't have (2 18) and (2 18 1) +;;; agenda buckets are deques stored in nested sparse-vectors indexed by agenda index values + +(defun find-agenda-bucket (buckets value &optional create) + (labels + ((find-agenda-bucket* (buckets value) + (cond + ((atom value) + (or (sparef buckets value) + (if create (setf (sparef buckets value) (make-deque)) nil))) + ((null (rest value)) + (or (sparef buckets (first value)) + (if create (setf (sparef buckets (first value)) (make-deque)) nil))) + (t + (let ((v (sparef buckets (first value)))) + (cond + (v + (find-agenda-bucket* v (rest value))) + (create + (find-agenda-bucket* (setf (sparef buckets (first value)) (make-sparse-vector)) (rest value))) + (t + nil))))))) + (find-agenda-bucket* buckets value))) + +(defun first-or-last-nonempty-agenda-bucket (buckets last) + (labels + ((first-or-last-nonempty-agenda-bucket* (buckets) + (prog-> + (map-sparse-vector-with-indexes buckets :reverse last ->* x i) + (cond + ((sparse-vector-p x) + (first-or-last-nonempty-agenda-bucket* x)) + ((deque-empty? x) + (setf (sparef buckets i) nil)) + (t + (return-from first-or-last-nonempty-agenda-bucket x)))))) + (first-or-last-nonempty-agenda-bucket* buckets) + nil)) + +(definline first-nonempty-agenda-bucket (buckets) + (first-or-last-nonempty-agenda-bucket buckets nil)) + +(definline last-nonempty-agenda-bucket (buckets) + (first-or-last-nonempty-agenda-bucket buckets t)) + +(defun collect-agenda-buckets (buckets) + (let ((result nil) result-last) + (labels + ((collect-agenda-buckets* (buckets revalue) + (prog-> + (map-sparse-vector-with-indexes buckets ->* x i) + (cond + ((sparse-vector-p x) + (collect-agenda-buckets* x (cons i revalue))) + ((deque-empty? x) + ) + (t + (collect (list x (if (null revalue) i (reverse (cons i revalue)))) result)))))) + (collect-agenda-buckets* buckets nil) + result))) + +(defun agenda-insert (item value agenda &optional at-front) + (let* ((buckets (agenda-buckets agenda)) + (q (find-agenda-bucket buckets value :create))) + (unless (and (not (deque-empty? q)) (funcall (agenda-same-item-p agenda) item (if at-front (deque-first q) (deque-last q)))) + (if at-front (deque-push-first q item) (deque-push-last q item)) + (let ((limit (agenda-length-limit agenda)) + (length (agenda-length agenda))) + (cond + ((and limit (<= limit length)) + (let ((deleted-item (deque-pop-last (last-nonempty-agenda-bucket buckets)))) + (cond + ((eql item deleted-item) + nil) + (t + (funcall (agenda-length-limit-deletion-action agenda) deleted-item) + t)))) + (t + (setf (agenda-length agenda) (+ length 1)) + t)))))) + +(defun agenda-delete (item value agenda) + (let ((length (agenda-length agenda))) + (unless (eql 0 length) + (let ((q (find-agenda-bucket (agenda-buckets agenda) value))) + (when (and q (deque-delete q item)) + (setf (agenda-length agenda) (- length 1)) + t))))) + +(defun agenda-first (agenda &optional delete) + (cond + ((listp agenda) + (dolist (agenda agenda) + (unless (eql 0 (agenda-length agenda)) + (return (agenda-first agenda delete))))) + (t + (let ((length (agenda-length agenda))) + (unless (eql 0 length) + (let ((q (first-nonempty-agenda-bucket (agenda-buckets agenda)))) + (cond + (delete + (setf (agenda-length agenda) (- length 1)) + (deque-pop-first q)) + (t + (deque-first q))))))))) + +(defun pop-agenda (agenda) + (agenda-first agenda t)) + +(defun map-agenda-buckets (function buckets) + (prog-> + (map-sparse-vector buckets ->* x) + (cond + ((sparse-vector-p x) + (map-agenda-buckets function x)) + (t + (funcall function x))))) + +(defun mapnconc-agenda (function agenda) + (let ((result nil) result-last) + (prog-> + (map-agenda-buckets (agenda-buckets agenda) ->* q) + (mapnconc-deque q ->* item) + (cond + ((or (null function) (eq 'list function) (eq #'list function)) + (collect item result)) + (t + (ncollect (funcall function item) result)))))) + +(defun agenda-delete-if (function agenda &optional apply-length-limit-deletion-action) + (prog-> + (and apply-length-limit-deletion-action (agenda-length-limit-deletion-action agenda) -> deletion-action) + (map-agenda-buckets (agenda-buckets agenda) ->* q) + (deque-delete-if q ->* v) + (when (funcall function v) + (decf (agenda-length agenda)) + (when deletion-action + (funcall deletion-action v)) + t))) + +(defun limit-agenda-length (agenda limit) + (let ((length (agenda-length agenda))) + (setf (agenda-length-limit agenda) limit) + (when (and limit (< limit length)) + (let ((i 0)) + (agenda-delete-if (lambda (item) (declare (ignore item)) (> (incf i) limit)) agenda t))))) + +(defvar *agenda*) ;default agenda(s) for print-agenda to display + +(defun print-agenda (&key (agenda *agenda*) entries) + (cond + ((listp agenda) + (let ((all-empty t)) + (dolist (agenda agenda) + (unless (eql 0 (agenda-length agenda)) + (setf all-empty nil) + (print-agenda :agenda agenda :entries entries))) + (when all-empty + (format t "~%; All agendas are empty.")))) + (t + (with-standard-io-syntax2 + (format t "~%; The agenda of ~A has ~D entr~:@P~A" + (agenda-name agenda) + (agenda-length agenda) + (if (eql 0 (agenda-length agenda)) "." ":")) + (unless (eql 0 (agenda-length agenda)) + (let ((buckets (collect-agenda-buckets (agenda-buckets agenda)))) + (do* ((k (length buckets)) + (k1 (ceiling k 3)) + (k2 (ceiling (- k k1) 2)) + (buckets3 (nthcdr (+ k1 k2) buckets)) + (buckets2 (nbutlast (nthcdr k1 buckets) (- k k1 k2))) + (buckets1 (nbutlast buckets k2)) + b) + ((null buckets1)) + (setf b (pop buckets1)) + (format t "~%; ~5D with value ~A" (deque-length (first b)) (second b)) + (unless (null buckets2) + (setf b (pop buckets2)) + (format t "~31T~5D with value ~A" (deque-length (first b)) (second b)) + (unless (null buckets3) + (setf b (pop buckets3)) + (format t "~61T~5D with value ~A" (deque-length (first b)) (second b)))))) + (when (and entries (not (eql 0 (agenda-length agenda)))) + (prog-> + (dolist (collect-agenda-buckets (agenda-buckets agenda)) ->* x) + (first x -> q) + (second x -> value) + (unless (deque-empty? q) + (format t "~%;~%; Entries with value ~A:" value) + (mapnconc-deque (lambda (x) (format t "~%; ~A" x)) q)))))) + nil))) + +(defun print-agenda3 (agenda stream depth) + (declare (ignore depth)) + (print-unreadable-object (agenda stream :type t :identity nil) + (format stream "~S" (agenda-name agenda)))) + +;;; agenda.lisp EOF diff --git a/src/alists.lisp b/src/alists.lisp new file mode 100644 index 0000000..646f96f --- /dev/null +++ b/src/alists.lisp @@ -0,0 +1,121 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: alists.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;; alists are assumed to be well formed: +;; lists of dotted pairs ending with nil +;; car of each dotted pair is a distinct constant + +(defun equal-alist-p (alist1 alist2 subst) + (and + (do ((p1 alist1 (rest p1)) + (p2 alist2 (rest p2))) + (nil) + (dereference + p1 subst + :if-variable (return (dereference p2 subst :if-variable (eq p1 p2))) ;allow variable at end + :if-constant (return (dereference p2 subst :if-constant t)) ;assume p1=p2=nil + :if-compound-cons (unless (dereference p2 subst :if-compound-cons t) + (return nil)))) + (do ((p1 alist1 (rest p1))) + (nil) + (dereference + p1 subst + :if-variable (return t) + :if-constant (return t) + :if-compound-cons (unless (do ((p2 alist2 (rest p2))) + (nil) + (dereference + p2 subst + :if-variable (return nil) + :if-constant (return nil) + :if-compound-cons (when (eql (car (first p1)) (car (first p2))) + (return (equal-p (cdr (first p1)) (cdr (first p2)) subst))))) + (return nil)))))) + +(defun conjoin-alists (alist1 alist2) + (let ((result nil) result-last) + (dolist (x alist1) + (let ((x1 (car x))) + (dolist (y alist2 (collect x result)) + (when (eql x1 (car y)) + (collect (cons x1 (conjoin (cdr x) (cdr y))) result) + (return))))) + (dolist (y alist2) + (let ((y1 (car y))) + (dolist (x alist1 (collect y result)) + (when (eql y1 (car x)) + (return))))) + result)) + +(defun conjoin-alist1 (key value alist) + (labels + ((conjoin-alist1 (alist) + (cond + ((null alist) + (values nil nil)) + (t + (let ((p (first alist))) + (cond + ((eql key (car p)) + (let ((p* (lcons (car p) (conjoin value (cdr p)) p))) + (values (if (eq p p*) alist (cons p* (rest alist))) t))) + (t + (let ((v (rest alist))) + (multiple-value-bind (v* found) (conjoin-alist1 v) + (values (if (eq v v*) alist (cons p v*)) found)))))))))) + (multiple-value-bind (alist* found) (conjoin-alist1 alist) + (if found alist* (cons (cons key value) alist*))))) + +(defun disjoin-alists (alist1 alist2) + (let ((result nil) result-last) + (dolist (x alist1) + (let ((x1 (car x))) + (dolist (y alist2 (collect x result)) + (when (eql x1 (car y)) + (collect (cons x1 (disjoin (cdr x) (cdr y))) result) + (return))))) + (dolist (y alist2) + (let ((y1 (car y))) + (dolist (x alist1 (collect y result)) + (when (eql y1 (car x)) + (return))))) + result)) + +(defun disjoin-alist1 (key value alist) + (labels + ((disjoin-alist1 (alist) + (cond + ((null alist) + (values nil nil)) + (t + (let ((p (first alist))) + (cond + ((eql key (car p)) + (let ((p* (lcons (car p) (disjoin value (cdr p)) p))) + (values (if (eq p p*) alist (cons p* (rest alist))) t))) + (t + (let ((v (rest alist))) + (multiple-value-bind (v* found) (disjoin-alist1 v) + (values (if (eq v v*) alist (cons p v*)) found)))))))))) + (multiple-value-bind (alist* found) (disjoin-alist1 alist) + (if found alist* (cons (cons key value) alist*))))) + +;;; alists.lisp EOF diff --git a/src/argument-bag-ac.lisp b/src/argument-bag-ac.lisp new file mode 100644 index 0000000..46c0574 --- /dev/null +++ b/src/argument-bag-ac.lisp @@ -0,0 +1,82 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: argument-bag-ac.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defmacro inc-argument-count (compare-fun term counts inc not-found-form &optional cancel) + (let ((count (gensym)) (v (gensym))) + `(dolist (,v ,counts ,not-found-form) + (let ((,count (tc-count ,v))) + (unless (eql 0 ,count) + (when ,(cond + ((member compare-fun '(equal-p)) + `(,compare-fun ,term (tc-term ,v) subst)) + (t + `(,compare-fun ,term (tc-term ,v)))) + (setf (tc-count ,v) (+ ,count ,inc)) + ,@(when cancel + `((unless ,cancel + (when (if (plusp ,count) (minusp ,inc) (plusp ,inc)) + (setf ,cancel t))))) + (return))))))) + +(defmacro count-argument (fn arg counts inc count-arguments-fun not-found-form &optional cancel) + `(dereference + ,arg subst + :if-variable (inc-argument-count eq ,arg ,counts ,inc ,not-found-form ,cancel) + :if-constant (inc-argument-count eql ,arg ,counts ,inc ,not-found-form ,cancel) + :if-compound (cond + ((and ,fn (eq ,fn (head ,arg))) + ,(if cancel + `(if ,cancel + (setf ,counts (,count-arguments-fun ,fn (args ,arg) subst ,counts ,inc)) + (setf (values ,counts ,cancel) (,count-arguments-fun ,fn (args ,arg) subst ,counts ,inc))) + `(setf ,counts (,count-arguments-fun ,fn (args ,arg) subst ,counts ,inc)))) + (t + (inc-argument-count equal-p ,arg ,counts ,inc ,not-found-form ,cancel))))) + +(defun count-arguments (fn args subst &optional counts (inc 1)) + ;; creates list of term and count pairs for argument list + ;; term and count pair is represented as (term . count) + ;; return 2nd value T if a cancellation occurs + (let ((cancel nil)) + (dolist (arg args) + (count-argument fn arg counts inc count-arguments (push (make-tc arg inc) counts) cancel)) + (if cancel + (values counts t) + counts))) + +(defun recount-arguments (fn terms-and-counts subst) + (let (new-terms-and-counts) + (dolist (tc terms-and-counts) + (let ((term (tc-term tc)) (count (tc-count tc))) + (count-argument fn term new-terms-and-counts count count-arguments (push (make-tc term count) new-terms-and-counts)))) + new-terms-and-counts)) + +(defun term-size-difference (terms-and-counts subst &optional var0) + (let ((n 0)) + (dolist (tc terms-and-counts) + (let ((count (tc-count tc))) + (unless (eql 0 count) + (let ((term (tc-term tc))) + (unless (and var0 (dereference term subst :if-variable (not (variable-frozen-p term)))) + (incf n (* count (size term subst)))))))) + n)) + +;;; argument-bag-ac.lisp EOF diff --git a/src/argument-list-a1.lisp b/src/argument-list-a1.lisp new file mode 100644 index 0000000..492c297 --- /dev/null +++ b/src/argument-list-a1.lisp @@ -0,0 +1,145 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: argument-list-a1.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun argument-list-a1 (fn args &optional subst (identity none)) + ;; return list of arguments of associative function fn + ;; return undereferenced args if no flattening or identity elimination + (if (null args) + nil + (labels + ((argument-list-a1* (args) + (let* ((l (rest args)) + (l* (if (null l) nil (argument-list-a1* l))) + (arg (first args)) + (arg* arg)) + (cond + ((dereference arg* subst :if-compound-appl (eq fn (heada arg*))) + (let* ((v (argsa arg*)) + (v* (if (null v) nil (argument-list-a1* v)))) + (cond + ((null l*) + v*) + ((null v*) + l*) + (t + (append v* l*))))) + ((eql identity arg*) + l*) + ((eq l l*) + args) + (t + (cons arg l*)))))) + (argument-list-a1* args)))) + +(defun argument-count-a1 (fn args &optional subst (identity none) dont-count-variables) + (let ((c 0)) + (dolist (arg args) + (dereference + arg subst + :if-compound-appl (if (eq fn (heada arg)) + (incf c (argument-count-a1 fn (argsa arg) subst identity dont-count-variables)) + (incf c)) + :if-compound-cons (incf c) + :if-constant (unless (eql identity arg) + (incf c)) + :if-variable (unless (and dont-count-variables + (neq none identity) + (not (variable-frozen-p arg))) + (incf c)))) + c)) + +(defun similar-argument-list-ac1-p (fn args1 args2 &optional subst (identity none)) + ;; same number of variable, list, constant, and application arguments + ;; also same number of first constant and first function seen + (let ((nvari 0) (nconst 0) (nappl 0) + (const1 none) (head1 none) nconst1 nhead1) + (labels + ((similar-argument-list-ac1-p1 (arg) + (dereference + arg subst + :if-variable (incf nvari) + :if-constant (unless (eql identity arg) + (cond + ((eq const1 none) + (setf const1 arg) + (setf nconst1 1)) + ((eql arg const1) + (incf nconst1)) + (t + (incf nconst)))) + :if-compound (let ((head (head arg))) + (if (eq fn head) + (dolist (x (args arg)) + (similar-argument-list-ac1-p1 x)) + (cond + ((eq head1 none) + (setf head1 head) + (setf nhead1 1)) + ((eq head head1) + (incf nhead1)) + (t + (incf nappl))))))) + (similar-argument-list-ac1-p2 (arg) + (dereference + arg subst + :if-variable (if (eql 0 nvari) + (return-from similar-argument-list-ac1-p nil) + (decf nvari)) + :if-constant (unless (eql identity arg) + (cond + ((eq none const1) + (return-from similar-argument-list-ac1-p nil)) + ((eql arg const1) + (if (eql 0 nconst1) + (return-from similar-argument-list-ac1-p nil) + (decf nconst1))) + (t + (if (eql 0 nconst) + (return-from similar-argument-list-ac1-p nil) + (decf nconst))))) + :if-compound (let ((head (head arg))) + (if (eq fn head) + (dolist (x (args arg)) + (similar-argument-list-ac1-p2 x)) + (cond + ((eq none head1) + (return-from similar-argument-list-ac1-p nil)) + ((eq head head1) + (if (eql 0 nhead1) + (return-from similar-argument-list-ac1-p nil) + (decf nhead1))) + (t + (if (eql 0 nappl) + (return-from similar-argument-list-ac1-p nil) + (decf nappl))))))))) + (dolist (x args1) + (similar-argument-list-ac1-p1 x)) + (dolist (x args2) + (similar-argument-list-ac1-p2 x)) + (and (eql 0 nvari) (eql 0 nconst) (eql 0 nappl))))) + +(defun flatargs (term &optional subst) + (let ((fn (head term))) + (if (function-associative fn) + (argument-list-a1 fn (argsa term) subst) + (args term)))) + +;;; argument-list-a1.lisp EOF diff --git a/src/assertion-analysis.lisp b/src/assertion-analysis.lisp new file mode 100644 index 0000000..4af4545 --- /dev/null +++ b/src/assertion-analysis.lisp @@ -0,0 +1,502 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: assertion-analysis.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +;;; the main purpose of this code is to recognize axioms +;;; for commutativity, associativity, etc. so that the +;;; appropriate function or relation symbol declarations can be +;;; made when running TPTP problems, where stupid and inconvenient +;;; rules do not allow any problem-specific input other than the axioms +;;; +;;; in general, using assertion-analysis to automatically declare +;;; special properties of relations and functions is NOT encouraged + +(in-package :snark) + +(defvar *wff*) + +(declaim (special *extended-variant*)) + +(defvar *assertion-analysis-patterns*) +(defvar *assertion-analysis-function-info*) +(defvar *assertion-analysis-relation-info*) + +(defstruct aa-function + function + (left-identities nil) + (right-identities nil) + (left-inverses nil) + (right-inverses nil) + (commutative nil) + (associative nil) + (closure-relations nil)) + +(defstruct aa-relation + relation + (left-identities nil) + (right-identities nil) + (left-inverses nil) + (right-inverses nil) + (commutative nil) + (assoc1-p nil) + (assoc2-p nil) + (functional-p nil) + (closure-functions nil)) + +(defun aa-function (f) + (let ((f# (funcall *standard-eql-numbering* :lookup f))) + (or (sparef *assertion-analysis-function-info* f#) + (progn + (cl:assert (function-symbol-p f)) + (setf (sparef *assertion-analysis-function-info* f#) + (make-aa-function :function f)))))) + +(defun aa-relation (p) + (let ((p# (funcall *standard-eql-numbering* :lookup p))) + (or (sparef *assertion-analysis-relation-info* p#) + (progn + (cl:assert (function-symbol-p p)) + (setf (sparef *assertion-analysis-relation-info* p#) + (make-aa-relation :relation p)))))) + +(defun print-assertion-analysis-note (name) + (with-standard-io-syntax2 + (format t "~%; Recognized ~A assertion ~S." name (renumber *wff*)))) + +(defun note-function-associative (f) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "associativity")) + (setf (aa-function-associative (aa-function f)) t)) + +(defun note-function-commutative (f) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "commutativity")) + (setf (aa-function-commutative (aa-function f)) t)) + +(defun note-function-left-identity (f e) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "left identity")) + (pushnew e (aa-function-left-identities (aa-function f)))) + +(defun note-function-right-identity (f e) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "right identity")) + (pushnew e (aa-function-right-identities (aa-function f)))) + +(defun note-function-left-inverse (f g e) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "possible left inverse")) + (pushnew (list g e) (aa-function-left-inverses (aa-function f)) :test #'equal)) + +(defun note-function-right-inverse (f g e) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "possible right inverse")) + (pushnew (list g e) (aa-function-right-inverses (aa-function f)) :test #'equal)) + +(defun note-relation-assoc1 (p) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "possible associativity")) + (setf (aa-relation-assoc1-p (aa-relation p)) t)) + +(defun note-relation-assoc2 (p) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "possible associativity")) + (setf (aa-relation-assoc2-p (aa-relation p)) t)) + +(defun note-relation-commutative (p) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "commutativity")) + (setf (aa-relation-commutative (aa-relation p)) t)) + +(defun note-relation-left-identity (p e) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "possible left identity")) + (pushnew e (aa-relation-left-identities (aa-relation p)))) + +(defun note-relation-right-identity (p e) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "possible right identity")) + (pushnew e (aa-relation-right-identities (aa-relation p)))) + +(defun note-relation-left-inverse (p g e) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "possible left inverse")) + (pushnew (list g e) (aa-relation-left-inverses (aa-relation p)) :test #'equal)) + +(defun note-relation-right-inverse (p g e) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "possible right inverse")) + (pushnew (list g e) (aa-relation-right-inverses (aa-relation p)) :test #'equal)) + +(defun note-relation-functional (p) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "relation functionality")) + (setf (aa-relation-functional-p (aa-relation p)) t)) + +(defun note-relation-closure (p f) + (when (print-assertion-analysis-notes?) + (print-assertion-analysis-note "relation function")) + (pushnew f (aa-relation-closure-functions (aa-relation p))) + (pushnew p (aa-function-closure-relations (aa-function f)))) + +(defun function-associativity-tests () + (let ((f (make-function-symbol (gensym) 2)) + (x (make-variable)) + (y (make-variable)) + (z (make-variable))) + (list + ;; (= (f (f x y) z) (f x (f y z))) + (list (make-equality0 (make-compound f (make-compound f x y) z) (make-compound f x (make-compound f y z))) + (list 'note-function-associative f))))) + +(defun function-commutativity-tests () + (let ((f (make-function-symbol (gensym) 2)) + (x (make-variable)) + (y (make-variable))) + (list + ;; (= (f x y) (f y x)) + (list (make-equality0 (make-compound f x y) (make-compound f y x)) + (list 'note-function-commutative f))))) + +(defun function-identity-tests () + (let ((f (make-function-symbol (gensym) 2)) + (e (gensym)) + (x (make-variable))) + (list + ;; (= (f e x) x) + (list (make-equality0 (make-compound f e x) x) + (list 'note-function-left-identity f e)) + ;; (= (f x e) x) + (list (make-equality0 (make-compound f x e) x) + (list 'note-function-right-identity f e))))) + +(defun function-inverse-tests () + (let ((f (make-function-symbol (gensym) 2)) + (g (make-function-symbol (gensym) 1)) + (e (gensym)) + (x (make-variable))) + (list + ;; (= (f (g x) x) e) + (list (make-equality0 (make-compound f (make-compound g x) x) e) + (list 'note-function-left-inverse f g e)) + ;; (= (f x (g x)) e) + (list (make-equality0 (make-compound f x (make-compound g x)) e) + (list 'note-function-right-inverse f g e))))) + +(defun relation-associativity-tests () + (let ((p (make-function-symbol (gensym) 3)) + (x (make-variable)) + (y (make-variable)) + (z (make-variable)) + (u (make-variable)) + (v (make-variable)) + (w (make-variable))) + (let ((a (make-compound p x y u)) + (b (make-compound p y z v)) + (c (make-compound p u z w)) + (d (make-compound p x v w))) + (list + ;; (or (not (p x y u)) (not (p y z v)) (not (p u z w)) (p x v w)) + (list (make-compound *or* + (make-compound *not* a) + (make-compound *not* b) + (make-compound *not* c) + d) + (list 'note-relation-assoc1 p)) + ;; (implies (and (p x y u) (p y z v) (p u z w)) (p x v w)) + (list (make-compound *implies* + (make-compound *and* a b c) + d) + (list 'note-relation-assoc1 p)) + ;; (or (not (p x y u)) (not (p y z v)) (not (p x v w)) (p u z w)) + (list (make-compound *or* + (make-compound *not* a) + (make-compound *not* b) + (make-compound *not* d) + c) + (list 'note-relation-assoc2 p)) + ;; (implies (and (p x y u) (p y z v) (p x v w)) (p u z w)) + (list (make-compound *implies* + (make-compound *and* a b d) + c) + (list 'note-relation-assoc2 p)))))) + +(defun relation-commutativity-tests () + (let ((p (make-function-symbol (gensym) 3)) + (x (make-variable)) + (y (make-variable)) + (z (make-variable))) + (loop for a in (list (make-compound p x y) (make-compound p x y z)) + as b in (list (make-compound p y x) (make-compound p y x z)) + nconc (list + ;; (or (not (p x y)) (p x y)) and (or (not (p x y z)) (p y x z)) + (list (make-compound *or* (make-compound *not* a) b) + (list 'note-relation-commutative p)) + ;; (implies (p x y) (p y x)) and (implies (p x y z) (p y x z)) + (list (make-compound *implies* a b) + (list 'note-relation-commutative p)))))) + +(defun relation-identity-tests () + (let ((p (make-function-symbol (gensym) 3)) + (e (gensym)) + (x (make-variable))) + (list + ;; (p e x x) + (list (make-compound p e x x) + (list 'note-relation-left-identity p e)) + ;; (p x e x) + (list (make-compound p x e x) + (list 'note-relation-right-identity p e))))) + +(defun relation-inverse-tests () + (let ((p (make-function-symbol (gensym) 3)) + (g (make-function-symbol (gensym) 1)) + (e (gensym)) + (x (make-variable))) + (list + ;; (p (g x) x e) + (list (make-compound p (make-compound g x) x e) + (list 'note-relation-left-inverse p g e)) + ;; (p x (g x) e) + (list (make-compound p x (make-compound g x) e) + (list 'note-relation-right-inverse p g e))))) + +(defun relation-functionality-tests () + (let ((p (make-function-symbol (gensym) 3)) + (x (make-variable)) + (y (make-variable)) + (z1 (make-variable)) + (z2 (make-variable))) + (let ((a (make-compound p x y z1)) + (b (make-compound p x y z2)) + (c (make-equality0 z1 z2))) + (list + ;; (or (not (p x y z1)) (not (p x y z2)) (= z1 z2)) + (list + (make-compound *or* + (make-compound *not* a) + (make-compound *not* b) + c) + (list 'note-relation-functional p)) + ;; (implies (and (p x y z1) (p x y z2)) (= z1 z2)) + (list + (make-compound *implies* + (make-compound *and* a b) + c) + (list 'note-relation-functional p)))))) + +(defun relation-closure-tests () + (let ((p (make-function-symbol (gensym) 3)) + (f (make-function-symbol (gensym) 2)) + (x (make-variable)) + (y (make-variable))) + (list + (list + (make-compound p x y (make-compound f x y)) + (list 'note-relation-closure p f))))) + +(defun initialize-assertion-analysis () + (setf *assertion-analysis-function-info* (make-sparse-vector)) + (setf *assertion-analysis-relation-info* (make-sparse-vector)) + (setf *assertion-analysis-patterns* + (nconc (function-associativity-tests) + (function-commutativity-tests) + (function-identity-tests) + (function-inverse-tests) + (relation-associativity-tests) + (relation-commutativity-tests) + (relation-identity-tests) + (relation-inverse-tests) + (relation-functionality-tests) + (relation-closure-tests) + )) + nil) + +(defun assertion-analysis (row) + (prog-> + (when (row-bare-p row) + (row-wff row -> wff) + (identity wff -> *wff*) + (quote t -> *extended-variant*) + (dolist *assertion-analysis-patterns* ->* x) + (variant (first x) wff nil nil ->* varpairs) + (sublis varpairs (second x) -> decl) + (apply (first decl) (rest decl)) + (return-from assertion-analysis)))) + +(defun maybe-declare-function-associative (f) + (unless (function-associative f) + (when (or (use-associative-unification?) (function-commutative f)) + (with-standard-io-syntax2 + (if (function-commutative f) + (format t "~%; Declaring ~A to be associative-commutative." (function-name f)) + (format t "~%; Declaring ~A to be associative." (function-name f)))) + (declare-function (function-name f) (function-arity f) :associative t)))) + +(defun maybe-declare-function-commutative (f) + (unless (function-commutative f) + (with-standard-io-syntax2 + (if (function-associative f) + (format t "~%; Declaring ~A to be associative-commutative." (function-name f)) + (format t "~%; Declaring ~A to be commutative." (function-name f)))) + (declare-function (function-name f) (function-arity f) :commutative t))) + +(defun maybe-declare-relation-commutative (p) + (unless (function-commutative p) + (with-standard-io-syntax2 + (format t "~%; Declaring ~A to be commutative." (function-name p))) + (declare-relation (function-name p) (function-arity p) :commutative t))) + +(defun maybe-declare-function-identity (f e) + (unless (neq none (function-identity f)) + (when (and (use-associative-identity?) (function-associative f) (or (use-associative-unification?) (function-commutative f))) + (with-standard-io-syntax2 + (format t "~%; Declaring ~A to have identity ~A." (function-name f) e)) + (declare-function (function-name f) (function-arity f) :identity e)))) + +(defun aa-relation-associative (p) + (if (or (aa-relation-commutative p) + (function-commutative (aa-relation-relation p))) + (or (aa-relation-assoc1-p p) (aa-relation-assoc2-p p)) + (and (aa-relation-assoc1-p p) (aa-relation-assoc2-p p)))) + +(defun complete-assertion-analysis () + (prog-> + (map-sparse-vector *assertion-analysis-function-info* ->* f) + (when (aa-function-commutative f) + (maybe-declare-function-commutative (aa-function-function f))) + (when (aa-function-associative f) + (maybe-declare-function-associative (aa-function-function f)))) + (prog-> + (map-sparse-vector *assertion-analysis-relation-info* ->* p) + (when (aa-relation-commutative p) + (maybe-declare-relation-commutative (aa-relation-relation p)) + (when (aa-relation-functional-p p) + (dolist (f (aa-relation-closure-functions p)) + (maybe-declare-function-commutative f)))) + (when (aa-relation-associative p) + (when (aa-relation-functional-p p) + (dolist (f (aa-relation-closure-functions p)) + (maybe-declare-function-associative f))))) + (prog-> + (map-sparse-vector *assertion-analysis-function-info* ->* f) + (aa-function-left-identities f -> left-identities) + (aa-function-right-identities f -> right-identities) + (aa-function-function f -> f) + (if (function-commutative f) (union left-identities right-identities) (intersection left-identities right-identities) -> identities) + (when (and identities (null (rest identities))) + (maybe-declare-function-identity f (first identities)))) + (prog-> + (map-sparse-vector *assertion-analysis-relation-info* ->* p) + (aa-relation-left-identities p -> left-identities) + (aa-relation-right-identities p -> right-identities) + (when (and (or left-identities right-identities) (aa-relation-functional-p p)) + (dolist (aa-relation-closure-functions p) ->* f) + (if (function-commutative f) (union left-identities right-identities) (intersection left-identities right-identities) -> identities) + (when (and identities (null (rest identities))) + (maybe-declare-function-identity f (first identities)))))) + +(define-plist-slot-accessor row :pure) + +(defun atom-rel# (atom) + (dereference + atom nil + :if-constant (constant-number atom) + :if-compound (function-number (head atom)))) + +(defun purity-test (row-mapper) + (let ((relation-reference-counts (make-sparse-vector :default-value 0))) + (flet ((adjust-reference-counts (row n) + (prog-> + (map-atoms-in-wff (row-wff row) ->* atom polarity) + (atom-rel# atom -> rel#) + (ecase polarity + (:pos + (incf (sparef relation-reference-counts rel#) n)) + (:neg + (incf (sparef relation-reference-counts (- rel#)) n)) + (:both + (incf (sparef relation-reference-counts rel#) n) + (incf (sparef relation-reference-counts (- rel#)) n)))))) + ;; count occurrences of signed relations + (prog-> + (funcall row-mapper ->* row) + (unless (or (row-hint-p row) (eq :checking (row-pure row))) + ;; row might be mapped more than once, put :checking in pure slot and count once + (setf (row-pure row) :checking) + (adjust-reference-counts row 1))) + (loop + (when (print-pure-rows?) + (with-clock-on printing + (format t "~2&; Purity test finds") + (prog-> + (map-sparse-vector-with-indexes relation-reference-counts ->* count signedrel#) + (abs signedrel# -> rel#) + (if (= signedrel# rel#) (- rel#) rel# -> oppsignedrel#) + (sparef relation-reference-counts oppsignedrel# -> oppcount) + (unless (and (< 0 signedrel#) (< 0 oppcount)) + (format t "~%; ~5D positive and ~5D negative occurrences of ~S." + (if (< 0 signedrel#) count oppcount) + (if (> 0 signedrel#) count oppcount) + (symbol-numbered rel#)))))) + (let ((purerels nil)) + ;; list in purerels relations that occur only positively or only negatively + (prog-> + (map-sparse-vector-indexes-only relation-reference-counts ->* signedrel#) + (abs signedrel# -> rel#) + (if (= signedrel# rel#) (- rel#) rel# -> oppsignedrel#) + (when (= 0 (sparef relation-reference-counts oppsignedrel#)) + (symbol-numbered rel# -> symbol) + (if (< 0 signedrel#) "positively" "negatively" -> sign) + (cond + ((not (function-symbol-p symbol)) + (push rel# purerels) + (warn "~S is a proposition that occurs only ~A; disabling rows that contain it." symbol sign)) + ((or (eq *=* symbol) + (function-rewrite-code symbol) + (if (< 0 signedrel#) (function-falsify-code symbol) (function-satisfy-code symbol))) + ) + ((integerp (function-arity symbol)) + (push rel# purerels) + (warn "~S is a ~D-ary relation that occurs only ~A; disabling rows that contain it." symbol (function-arity symbol) sign)) + (t + (push rel# purerels) + (warn "~S is a relation that occurs only ~A; disabling rows that contain it." symbol sign))))) + ;; if purerels is empty, no (more) pure rows, remove :checking and return + (when (null purerels) + (prog-> + (funcall row-mapper ->* row) + (when (eq :checking (row-pure row)) + (setf (row-pure row) nil))) + (return)) + ;; if row contains a relation in purerels, mark it as pure and decrement reference counts + ;; maybe some relations will be newly pure, so loop + (prog-> + (funcall row-mapper ->* row) + (when (eq :checking (row-pure row)) + (when (prog-> + (map-atoms-in-wff (row-wff row) ->* atom polarity) + (declare (ignore polarity)) + (when (member (atom-rel# atom) purerels) + (return-from prog-> t))) + (setf (row-pure row) t) + (adjust-reference-counts row -1) + (print-pure-row row)))))) + nil))) + +;;; assertion-analysis.lisp EOF diff --git a/src/assertion-file.lisp b/src/assertion-file.lisp new file mode 100644 index 0000000..6c00203 --- /dev/null +++ b/src/assertion-file.lisp @@ -0,0 +1,262 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: assertion-file.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defmacro in-language (language) + (declare (ignore language)) + `(warn "Ignoring IN-LANGUAGE form.")) + +(defmacro in-kb (kb) + ;; use suspend/resume for this? okbc calls? + (declare (ignore kb)) + `(warn "Ignoring IN-KB form.")) + +(defmacro has-author (author) + `(setf *form-author* ',author)) + +(defmacro has-documentation (documentation) + `(setf *form-documentation* ',documentation)) + +(defmacro has-name (name) + `(setf *form-name* ',name)) + +(defmacro has-source (source) + `(setf *form-source* ',source)) + +(declare-snark-option assertion-file-commands + '(assertion + has-author ;has-xxx specifies xxx for later assertions + has-documentation + has-name + has-source + in-package + in-language + in-kb + declare-constant + declare-function + declare-relation + declare-sort + declare-subsort + declare-sorts-incompatible + declare-tptp-sort + ) ;every other form is an assertion + :never-print) + +(declare-snark-option assertion-file-keywords + '((:author *form-author*) + (:documentation *form-documentation*) + (:name *form-name*) + (:source *form-source*)) + :never-print) + +(declare-snark-option assertion-file-format nil :never-print) +(declare-snark-option assertion-file-if-does-not-exist :error :never-print) +(declare-snark-option assertion-file-verbose nil :never-print) +(declare-snark-option assertion-file-package :snark-user :never-print) +(declare-snark-option assertion-file-readtable nil :never-print) +(declare-snark-option assertion-file-negate-conjectures nil :never-print) + +(defun read-assertion-file (filespec + &key + (format (assertion-file-format?)) + (if-does-not-exist (assertion-file-if-does-not-exist?)) + (verbose (assertion-file-verbose?)) + (package (or (assertion-file-package?) *package*)) + (readtable (or (assertion-file-readtable?) *readtable*)) + (negate-conjectures (assertion-file-negate-conjectures?)) + hash-dollar + (clock t)) + ;; read-asssertion-file executes commands and return a list of calls on 'assertion' + ;; every form that is not a command (commands are named in (assertion-file-commands?)) + ;; is treated as a formula to be asserted + (declare (ignorable verbose hash-dollar)) + (let ((sort-declarations nil) + (subsort-declarations nil)) + (labels + ((raf0 () + (prog-> + (identity readtable -> *readtable*) + (identity (assertion-file-commands?) -> commands) + (identity (assertion-file-keywords?) -> keywords) + (progv (mapcar #'second keywords) + (consn nil nil (length keywords)) + (funcall (let ((type (pathname-type filespec))) + (cond + ((or (string-equal "tptp" type) (string-equal "p" type) (string-equal "ax" type)) + 'mapnconc-tptp-file-forms) + ((or (string-equal "lisp" type) (string-equal "kif" type)) + 'mapnconc-file-forms) + ((eq :tptp format) + 'mapnconc-tptp-file-forms) + (t + 'mapnconc-file-forms))) + filespec + :if-does-not-exist if-does-not-exist + :package package + ->* form) + (when form ;ignore nils + (and (consp form) + (symbolp (first form)) + (first (member (first form) commands + :test #'string-equal ;command matching ignores package and case + :key #'symbol-name)) + -> command) + (case command + ((nil) + (setf form (list 'assertion form))) + (assertion + (setf form (cons command (append (rest form) nil))) + (setf command nil)) + ((declare-sort declare-tptp-sort) + (setf form (cons command (rest form))) + (push form sort-declarations)) + (declare-subsort + (setf form (cons command (rest form))) + (push form subsort-declarations)) + ((declare-sorts-incompatible declare-constant declare-function declare-relation) + (setf form (cons command (rest form))) + (setf command nil)) + (otherwise + (eval (cons command (rest form))))) + (unless command + (case (and (consp form) (first form)) + (assertion + (cond + ((getf (cddr form) :ignore) + nil) + (t + (when (and negate-conjectures (eq 'conjecture (getf (cddr form) :reason))) + (setf (second form) (list 'not (second form))) + (setf (getf (cddr form) :reason) 'negated_conjecture)) + (dolist (x keywords) + (let ((v (symbol-value (second x)))) + (when (and v (eq none (getf (cddr form) (first x) none))) + (nconc form (list (first x) v))))) + (list form)))) + (otherwise + (list form)))))))) + (raf () + (let ((l (raf0))) + (cond + (subsort-declarations + (setf subsort-declarations (topological-sort (nreverse subsort-declarations) 'must-precede-in-assertion-file)) + (setf l (append subsort-declarations l)) + (dolist (x sort-declarations) + (unless (member (unquote (second x)) subsort-declarations :key #'(lambda (x) (unquote (second x)))) + (push x l)))) + (t + (dolist (x sort-declarations) + (push x l)))) + l))) + (if clock + (with-clock-on read-assertion-file (raf)) + (raf))))) + +(defun must-precede-in-assertion-file (x y) + (ecase (first x) + ((declare-sort declare-subsort) + (ecase (first y) + ((declare-sort declare-subsort) + (leafp (unquote (second x)) y)) + ((declare-sorts-incompatible declare-constant declare-function declare-relation declare-proposition assertion) + t))) + (declare-sorts-incompatible + (ecase (first y) + ((declare-sort declare-subsort declare-sorts-incompatible) + nil) + ((declare-constant declare-function declare-relation declare-proposition assertion) + t))) + ((declare-constant declare-function declare-relation declare-proposition) + (eq 'assertion (first y))) + (assertion + nil))) + +(declare-snark-option refute-file-initialize t :never-print) +(declare-snark-option refute-file-closure t :never-print) +(declare-snark-option refute-file-options nil :never-print) +(declare-snark-option refute-file-actions nil :never-print) +(declare-snark-option refute-file-ignore-errors nil :never-print) +(declare-snark-option refute-file-verbose t :never-print) +(declare-snark-option refute-file-output-file nil :never-print) +(declare-snark-option refute-file-if-exists nil :never-print) + +(defun refute-file (filespec + &key + (initialize (refute-file-initialize?)) + (closure (refute-file-closure?)) + (format (assertion-file-format?)) + (options (refute-file-options?)) + (actions (refute-file-actions?)) + (ignore-errors (refute-file-ignore-errors?)) + (verbose (refute-file-verbose?)) + (output-file (refute-file-output-file?)) + (if-exists (refute-file-if-exists?)) + (package (or (assertion-file-package?) *package*)) + (readtable (or (assertion-file-readtable?) *readtable*)) + (use-coder nil)) + (labels + ((refute-file0 () + (cond + (use-coder + (multiple-value-bind (axioms target op pred) (snark-user::condensed-detachment-problem-p (read-assertion-file filespec)) + (declare (ignorable pred)) + (if op + (snark-user::coder axioms target :op op :run-time-limit (if (numberp use-coder) use-coder nil)) + (format t "~%Not recognized as a condensed-detachment problem.")))) + (t + (when initialize + (initialize)) + (mapc #'eval options) + (mapc #'eval (funcall 'read-assertion-file filespec + :format format + :package package + :readtable readtable)) + (mapc #'eval actions) + (when closure + (or (let ((*szs-filespec* filespec)) (closure)) :done))))) + (refute-file1 () + (if verbose + (let ((result (time (refute-file0)))) + (case result + (:proof-found + (unless (member (print-final-rows?) '(:tptp :tptp-too)) + (print-szs-status result nil filespec))) + ((:run-time-limit :agenda-empty) + (print-szs-status result nil filespec))) + (prin1 result)) + (refute-file0))) + (refute-file2 () + (prog2 + (when verbose + (format t "~&; Begin refute-file ~A " filespec) (print-current-time) (terpri)) + (if ignore-errors + (mvlet (((values value condition) (ignore-errors (refute-file1)))) + (or value (princ condition))) + (refute-file1)) + (when verbose + (format t "~&; End refute-file ~A " filespec) (print-current-time) (terpri))))) + (if output-file + (with-open-file (stream output-file :direction :output :if-exists if-exists) + (when stream + (let ((*standard-output* stream) (*error-output* stream) (*trace-output* stream)) + (refute-file2)))) + (refute-file2)))) + +;;; assertion-file.lisp EOF diff --git a/src/auxiliary-packages.lisp b/src/auxiliary-packages.lisp new file mode 100644 index 0000000..3a4e947 --- /dev/null +++ b/src/auxiliary-packages.lisp @@ -0,0 +1,199 @@ +(in-package :common-lisp-user) + +#+asdf +(defparameter *snark-system-pathname* + (let ((system (asdf:find-system :snark))) + (asdf:system-source-directory system))) + +#+asdf +(defvar *compile-me* nil) + +#+asdf +(defun make-snark-system (&optional (*compile-me* *compile-me*)) + (when (eql *compile-me* :optimize) + (proclaim (print '(optimize (safety 1) (space 1) (speed 3) (debug 1))))) + (with-compilation-unit () + (if *compile-me* + (progn + (asdf:compile-system :snark :force t) + (asdf:load-system :snark)) + (asdf:load-system :snark)))) + +(defpackage :snark-lisp + (:use :common-lisp) + (:export + + ;; defined in mvlet.lisp + #:mvlet #:mvlet* + + ;; defined in progc.lisp + #:prog-> + #:*prog->-function-second-forms* + #:*prog->-special-forms* + + ;; defined in lisp.lisp + #:none + #:true #:false + #:definline + #:neq #:neql #:nequal #:nequalp + #:if-let #:when-let + #:iff #:implies + #:kwote #:unquote + #:rrest #:rrrest #:rrrrest + #:mklist #:firstn #:consn #:leafp + #:naturalp #:ratiop + #:carc #:cdrc #:caarcc #:cadrcc #:cdarcc #:cddrcc + #:lcons + #:cons-unless-nil #:push-unless-nil #:pushnew-unless-nil + #:dotails #:dopairs + #:choose + #:integers-between #:ints + #:length= #:length< #:length<= #:length> #:length>= + #:acons+ #:alist-notany-plusp #:alist-notany-minusp + #:cons-count + #:char-invert-case + #:to-string + #:find-or-make-package + #:percentage + #:print-current-time + #:leap-year-p #:days-per-month #:month-number + #:print-args + #:define-plist-slot-accessor + #:*print-pretty2* + #:with-standard-io-syntax2 + #:quit + + ;; defined in collectors.lisp + #:make-collector #:collector-value #:collect-item #:collect-list + #:make-queue #:queue-empty-p #:enqueue #:dequeue + #:collect #:ncollect + + ;; defined in map-file.lisp + #:mapnconc-stream-forms #:mapnconc-stream-lines + #:mapnconc-file-forms #:mapnconc-file-lines + #:read-file #:read-file-lines #:read-file-to-string + + ;; defined in clocks.lisp + #:initialize-clocks #:print-clocks + #:with-clock-on #:with-clock-off + #:total-run-time + #:print-incremental-time-used + + ;; defined in counters.lisp + #:make-counter + #:increment-counter #:decrement-counter + #:counter-value #:counter-values + #:princf + + ;; defined in pattern-match.lisp + #:pattern-match + + ;; defined in topological-sort.lisp + #:topological-sort* #:topological-sort + + ;; undefined symbols used by snark + #:implied-by #:xor #:nand #:nor + #:forall #:exists + #:$$cons #:$$list #:$$list* + )) + +(defpackage :snark-deque + (:use :common-lisp :snark-lisp) + (:export + #:make-deque + #:deque? + #:deque-empty? + #:deque-first #:deque-rest #:deque-pop-first #:deque-add-first #:deque-push-first + #:deque-last #:deque-butlast #:deque-pop-last #:deque-add-last #:deque-push-last + #:deque-length + #:deque-delete + #:deque-delete-if + #:mapnconc-deque + )) + +(defpackage :snark-sparse-array + (:use :common-lisp :snark-lisp) + (:export + #:sparef + #:sparse-vector #:make-sparse-vector #:sparse-vector-p + #:sparse-vector-boolean #:sparse-vector-default-value + #:sparse-vector-count + #:map-sparse-vector #:map-sparse-vector-with-indexes #:map-sparse-vector-indexes-only + #:with-sparse-vector-iterator + #:first-sparef #:last-sparef #:pop-first-sparef #:pop-last-sparef + #:copy-sparse-vector #:spacons + #:sparse-matrix #:make-sparse-matrix #:sparse-matrix-p + #:sparse-matrix-boolean #:sparse-matrix-default-value + #:sparse-matrix-count + #:sparse-matrix-row #:sparse-matrix-column #:sparse-matrix-rows #:sparse-matrix-columns + #:map-sparse-matrix #:map-sparse-matrix-with-indexes #:map-sparse-matrix-indexes-only + + #:sparse-vector-expression-p + #:map-sparse-vector-expression + #:map-sparse-vector-expression-with-indexes + #:map-sparse-vector-expression-indexes-only + #:optimize-sparse-vector-expression + #:uniond + )) + +(defpackage :snark-numbering + (:use :common-lisp :snark-lisp :snark-sparse-array) + (:export + #:nonce + #:initialize-numberings #:make-numbering + #:*standard-eql-numbering* #:*standard-equal-numbering* + )) + +(defpackage :snark-agenda + (:use :common-lisp :snark-lisp :snark-deque :snark-sparse-array) + (:export + #:make-agenda + #:agenda-name #:agenda-length + #:agenda-insert #:agenda-delete + #:agenda-first #:pop-agenda #:mapnconc-agenda #:agenda-delete-if + #:limit-agenda-length + #:print-agenda + #:*agenda* + )) + +(defpackage :snark-infix-reader + (:use :common-lisp :snark-lisp) + (:export + #:initialize-operator-syntax #:declare-operator-syntax + #:tokenize #:read-infix-term + #:--)) + +(defpackage :snark-feature + (:use :common-lisp :snark-lisp) + (:export + #:initialize-features + #:make-feature #:declare-feature + #:declare-features-incompatible + #:feature? #:feature-parent + #:the-feature + #:delete-feature #:feature-live? + #:feature-union #:feature-subsumes? + #:print-feature-tree + )) + +(defpackage :snark-dpll + (:use :common-lisp :snark-lisp) + (:export + #:dp-prover #:dp-version + #:dp-tracing #:dp-tracing-state #:dp-tracing-models #:dp-tracing-choices + #:dp-satisfiable-p #:dp-satisfiable-file-p #:make-dp-clause-set + #:dp-insert #:dp-insert-sorted #:dp-insert-wff #:dp-insert-file + #:dp-count #:dp-clauses #:dp-output-clauses-to-file #:wff-clauses + #:dp-horn-clause-set-p + #:checkpoint-dp-clause-set #:restore-dp-clause-set #:uncheckpoint-dp-clause-set + #:choose-an-atom-of-a-shortest-clause + #:choose-an-atom-of-a-shortest-clause-randomly + #:choose-an-atom-of-a-shortest-clause-with-most-occurrences + #:choose-an-atom-of-a-shortest-clause-with-most-occurrences-randomly + #:choose-an-atom-of-a-shortest-positive-clause + #:choose-an-atom-of-a-shortest-positive-clause-randomly + #:choose-an-atom-of-a-shortest-positive-clause-with-most-occurrences + #:choose-an-atom-of-a-shortest-positive-clause-with-most-occurrences-randomly + #:lookahead-true #:lookahead-false + #:lookahead-true-false #:lookahead-false-true + )) diff --git a/src/clocks.lisp b/src/clocks.lisp new file mode 100644 index 0000000..467d85b --- /dev/null +++ b/src/clocks.lisp @@ -0,0 +1,169 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*- +;;; File: clocks.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-lisp) + +(defvar *clocks* nil) + +(defun make-clock-variable (name) + (cl:assert (symbolp name)) + (let* ((s (symbol-name name)) + (v (intern (to-string "*%" s :-time%*) :snark-lisp)) + (w (intern (to-string "*%" s :-count%*) :snark-lisp))) + (unless (assoc v *clocks*) + (setf *clocks* (nconc *clocks* (list (list v w)))) + (proclaim `(special ,v ,w))) + (values v w))) + +(mapc #'make-clock-variable + '( + read-assertion-file + assert + process-new-row + resolution + paramodulation + factoring + equality-factoring + embedding + condensing + forward-subsumption + backward-subsumption + clause-clause-subsumption + forward-simplification + backward-simplification + ordering + ordering-ac + sortal-reasoning + temporal-reasoning + constraint-simplification + term-hashing + path-indexing + instance-graph-insertion + purity-testing + relevance-testing + satisfiability-testing + printing + halted + test1 + test2 + test3 + )) + +(defvar *excluded-clocks* '(*%printing-time%* *%halted-time%*)) + +(defvar *running-clocks* nil) +(defvar *first-real-time-value* 0) +(defvar *first-run-time-value* 0) +(defvar *last-run-time-value* 0) +(defvar *run-time-mark* 0) +(declaim (type integer *first-real-time-value* *first-run-time-value* *last-run-time-value* *run-time-mark*)) +(defvar *total-seconds* 0.0) + +(defun initialize-clocks (&optional (excluded-clocks *excluded-clocks*)) + (cl:assert (null *running-clocks*)) + (setf *first-real-time-value* (get-internal-real-time)) + (setf *run-time-mark* (setf *first-run-time-value* (get-internal-run-time))) + (setf *excluded-clocks* excluded-clocks) + (dolist (l *clocks*) + (dolist (v l) + (setf (symbol-value v) 0)))) + +(defmacro with-clock-on (clock &body body) + (let (count) + (setf (values clock count) (make-clock-variable clock)) + (let ((previously-running-clocks (make-symbol (symbol-name 'previously-running-clocks))) + (first-previously-running-clock (make-symbol (symbol-name 'first-previously-running-clock)))) + `(let* ((,previously-running-clocks *running-clocks*) + (,first-previously-running-clock (first ,previously-running-clocks))) + (unless (eq ',clock ,first-previously-running-clock) + (if ,previously-running-clocks + (decf (symbol-value ,first-previously-running-clock) (- *last-run-time-value* (setf *last-run-time-value* (get-internal-run-time)))) + (setf *last-run-time-value* (get-internal-run-time))) + (incf (symbol-value ',count)) + (setf *running-clocks* (cons ',clock ,previously-running-clocks))) + (unwind-protect + (progn ,@body) + (unless (eq ',clock ,first-previously-running-clock) + (setf *running-clocks* ,previously-running-clocks) + (decf (symbol-value ',clock) (- *last-run-time-value* (setf *last-run-time-value* (get-internal-run-time)))))))))) + +(defmacro with-clock-off (clock &body body) + ;; dummy with-clock-on + (make-clock-variable clock) + `(progn ,@body)) + +(defun clock-name (clock) + (let ((name (symbol-name clock))) + (nsubstitute #\ #\- (subseq name 2 (- (length name) 7))))) + +(defun print-clocks (&optional (excluded-clocks *excluded-clocks*)) + (let ((total-ticks (- (get-internal-run-time) *first-run-time-value*)) + (time-included 0) + (time-excluded 0)) + (format t "~%; Run time in seconds") + (dolist (l *clocks*) + (let* ((clk (first l)) + (run-time (symbol-value clk))) + (cond + ((eql 0 run-time) + ) + ((member clk excluded-clocks) + (format t (if (eql 0 time-excluded) " excluding ~(~A~)" ", ~(~A~)") (clock-name clk)) + (incf time-excluded run-time)) + (t + (incf time-included run-time))))) + (unless (eql 0 time-excluded) + (decf total-ticks time-excluded) + (format t " time")) + (princ ":") + (dolist (l *clocks*) + (let ((clk (first l)) + (cnt (second l))) + (unless (member clk excluded-clocks) + (let ((run-time (symbol-value clk)) + (count (symbol-value cnt))) + (unless (eql 0 count) + (format t "~%;~10,3F ~3D% ~@(~A~)~48T(~:D call~:P)" + (/ run-time (float internal-time-units-per-second)) + (if (eql 0 total-ticks) 0 (percentage run-time total-ticks)) + (clock-name clk) + count)))))) + (let ((other-time (- total-ticks time-included))) + (format t "~%;~10,3F ~3D% Other" + (/ other-time (float internal-time-units-per-second)) + (if (eql 0 total-ticks) 0 (percentage other-time total-ticks)))) + (setf *total-seconds* (/ total-ticks (float internal-time-units-per-second))) + (format t "~%;~10,3F Total" *total-seconds*) + (format t "~%;~10,3F Real time" (/ (- (get-internal-real-time) *first-real-time-value*) (float internal-time-units-per-second))) + *total-seconds*)) + +(defun total-run-time (&optional (excluded-clocks *excluded-clocks*)) + (let ((total-ticks (- (get-internal-run-time) *first-run-time-value*))) + (dolist (l *clocks*) + (let ((clk (first l))) + (when (member clk excluded-clocks) + (decf total-ticks (symbol-value clk))))) + (/ total-ticks (float internal-time-units-per-second)))) + +(defun print-incremental-time-used () + (let ((time (get-internal-run-time))) + (format t " ;~,3Fsec" (/ (- time *run-time-mark*) (float internal-time-units-per-second))) + (setf *run-time-mark* time))) + +;;; clocks.lisp EOF diff --git a/src/closure1.lisp b/src/closure1.lisp new file mode 100644 index 0000000..0ec98c0 --- /dev/null +++ b/src/closure1.lisp @@ -0,0 +1,66 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: closure1.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; simple closure algorithm for small deduction tasks +;;; that do not require features like indexing for performance + +(defun closure1 (items &key done unary-rules binary-rules ternary-rules (subsumption-test #'equal)) + ;; compute closure of the union of items and done using rules and subsumption-test + ;; if done is given as an argument, it is assumed to be closed already + (flet ((unsubsumed (l1 l2 subsumption-test) + ;; return items in l2 that are not subsumed by any item in l1 + (delete-if #'(lambda (item2) + (some #'(lambda (item1) + (funcall subsumption-test item1 item2)) + l1)) + l2))) + (let ((todo (make-deque))) + (dolist (item items) + (deque-push-last todo item)) + (loop + (when (deque-empty? todo) + (return done)) + (let ((item1 (deque-pop-first todo))) + (when (unsubsumed done (list item1) subsumption-test) + (setf done (cons item1 (unsubsumed (list item1) done subsumption-test))) + (prog-> + (dolist unary-rules ->* rule) + (funcall rule item1 ->* new-item) + (when (eq :inconsistent new-item) + (return-from closure1 new-item)) + (deque-push-last todo new-item)) + (prog-> + (dolist binary-rules ->* rule) + (dolist done ->* item2) + (funcall rule item1 item2 ->* new-item) + (when (eq :inconsistent new-item) + (return-from closure1 new-item)) + (deque-push-last todo new-item)) + (prog-> + (dolist ternary-rules ->* rule) + (dolist done ->* item2) + (dolist done ->* item3) + (funcall rule item1 item2 item3 ->* new-item) + (when (eq :inconsistent new-item) + (return-from closure1 new-item)) + (deque-push-last todo new-item)))))))) + +;;; closure1.lisp EOF diff --git a/src/code-for-bags4.lisp b/src/code-for-bags4.lisp new file mode 100644 index 0000000..b27e2c2 --- /dev/null +++ b/src/code-for-bags4.lisp @@ -0,0 +1,116 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: code-for-bags4.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *singleton-bag*) +(defvar *bag-union*) + +;;; $$bag and $$bag* terms are translated into a standardized internal representation for bags +;;; that has $$$bag-union as the top function symbol +;;; ($$bag) -> ($$bag-union) +;;; ($$bag a) -> ($$bag-union ($$singleton-bag a)) +;;; ($$bag a b) -> ($$bag-union ($$singleton-bag a) ($$singleton-bag b)) +;;; ($$bag a b c) -> ($$bag-union ($$singleton-bag a) ($$singleton-bag b) ($$singleton-bag c)) +;;; ($$bag* a) -> ($$bag-union a) +;;; ($$bag* a b) -> ($$bag-union ($$singleton-bag a) b) +;;; ($$bag* a b c) -> ($$bag-union ($$singleton-bag a) ($$singleton-bag b) c) + +;;; variables and terms that represent bags should always be enclosed in bag-union, bag, or bag* symbols +;;; (bag-union a ?x) and a are not recognized as unifiable because they have different head symbols +;;; (bag-union a ?x) and (bag-union a) can be unified + +(defun declare-code-for-bags () + (declare-subsort 'bag :top-sort-a) + (declare-characteristic-relation '$$bagp #'bagp 'bag) + (declare-function1 '$$bag :any :macro t :input-code 'input-bag-term) + (declare-function1 '$$bag* :any :macro t :input-code 'input-bag*-term) + (setf *singleton-bag* ;should only be used as argument of bag-union + (declare-function1 '$$singleton-bag 1 ;unexported symbol that shouldn't be visible to user + :sort 'bag + :constructor t)) + (setf *bag-union* + (declare-function1 '$$bag-union 2 + :sort '(bag (t bag)) + :associative t + :commutative t + :identity '(function) ;use (bag-union) as identity + :keep-head t + :to-lisp-code 'bag-union-term-to-lisp)) + (declare-ordering-greaterp '$$bag-union '$$singleton-bag) + (declare-function1 '$$bag-to-list 1 :sort 'list :rewrite-code #'(lambda (x s) (bag-to-list (arg1 x) s))) + (declare-function1 '$$list-to-bag 1 :sort 'bag :rewrite-code #'(lambda (x s) (list-to-bag (arg1 x) s))) + nil) + +(defun bagp (x &optional subst) + (dereference x subst :if-compound-appl (eq *bag-union* (heada x)))) + +(defun input-bag-term (head args polarity) + (declare (ignore head)) + (input-term1 `($$bag-union ,@(mapcar #'(lambda (arg) `($$singleton-bag ,arg)) args)) polarity)) + +(defun input-bag*-term (head args polarity) + (require-n-or-more-arguments head args polarity 1) + (input-term1 `($$bag-union ,@(mapcar #'(lambda (arg) `($$singleton-bag ,arg)) (butlast args)) ,(first (last args))) polarity)) + +(defun bag-union-term-to-lisp (head args subst) + (mvlet* (((:values u v) (split-if #'(lambda (x) (dereference x subst :if-compound-appl (eq *singleton-bag* (heada x)))) + (argument-list-a1 head args subst))) + (u (mapcar #'(lambda (x) (dereference x subst) (term-to-lisp (arg1a x) subst)) u)) + (v (mapcar #'(lambda (x) (term-to-lisp x subst)) v))) + (cond + ((null v) + `(,(current-function-name '$$bag :any) ,@u)) + ((null u) + `(,(function-name *bag-union*) ,@v)) + (t + `(,(function-name *bag-union*) (,(current-function-name '$$bag :any) ,@u) ,@v))))) + +(defun bag-to-list (bag &optional subst) + (dereference + bag subst + :if-variable none + :if-constant none + :if-compound-cons none + :if-compound-appl (cond + ((eq *bag-union* (heada bag)) + (mapcar #'(lambda (x) + (if (dereference x subst :if-compound-appl (eq *singleton-bag* (heada x))) + (first (argsa x)) + (return-from bag-to-list none))) + (argument-list-a1 *bag-union* (argsa bag) subst))) + (t + none)))) + +(defun list-to-bag (list &optional subst) + (dereference + list subst + :if-variable none + :if-compound-appl none + :if-constant (if (null list) (make-compound *bag-union*) none) + :if-compound-cons (let ((sbags nil)) + (loop + (push (make-compound *singleton-bag* (pop list)) sbags) + (dereference + list subst + :if-variable (return none) + :if-compound-appl (return none) + :if-constant (return (if (null list) (make-compound* *bag-union* (reverse sbags)) none))))))) + +;;; code-for-bags4.lisp EOF diff --git a/src/code-for-lists2.lisp b/src/code-for-lists2.lisp new file mode 100644 index 0000000..92a0af7 --- /dev/null +++ b/src/code-for-lists2.lisp @@ -0,0 +1,34 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: code-for-lists2.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun declare-code-for-lists () + (declare-constant nil :locked t :constructor t :sort 'list) + (setf *cons* (declare-function1 '$$cons 2 :constructor t :to-lisp-code 'cons-term-to-lisp :sort 'list :ordering-status :left-to-right)) + + (declare-ordering-greaterp '$$cons nil) + + (declare-function1 '$$list :any :macro t :input-code 'input-lisp-list) + (declare-function1 '$$list* :any :macro t :input-code 'input-lisp-list*) + + (declare-characteristic-relation '$$listp #'listp 'list) + nil) + +;;; code-for-lists2.lisp EOF diff --git a/src/code-for-numbers3.lisp b/src/code-for-numbers3.lisp new file mode 100644 index 0000000..c24a1ef --- /dev/null +++ b/src/code-for-numbers3.lisp @@ -0,0 +1,505 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: code-for-numbers3.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; SNARK can evaluate arithmetic expressions as if by table lookup +;;; for procedurally attached relations and functions +;;; +;;; most of what SNARK "knows" about numbers is limited by this notion of table lookup; +;;; few if any more general properties are known +;;; like (= (+ x 0) x), (= (* x 0) 0), (exists (x) (< x 0)), +;;; associativity and commutativity of + and *, etc. +;;; +;;; this is intended to provide simple arithmetic calculation and not much if any symbolic algebra +;;; +;;; SNARK numbers are represented by Lisp rational numbers (integers or ratios) +;;; and complex numbers with rational real and imaginary parts +;;; +;;; floating-point numbers are replaced by rationals when input +;;; +;;; SNARK number type hierarchy: number = complex > real > rational > integer +;;; +;;; arithmetic relations are encoded in terms of $less +;;; using lexicographic ordering of complex numbers +;;; that also enables additive cancellation law +;;; and multiplicative cancellation law for multiplication by nonzero reals + +(defvar *sum*) +(defvar *product*) +(defvar *less*) +(defvar *reciprocal*) + +(defun rnumberp (x) + ;; test for SNARK number, no floats + (or (rationalp x) (and (complexp x) (rationalp (realpart x)) (rationalp (imagpart x))))) + +(defun nonzero-rnumberp (x) + (and (rnumberp x) (neql 0 x))) + +(defun nonzero-rationalp (x) + (and (rationalp x) (neql 0 x))) + +(defun less? (x y) + ;; extend < to total lexicographic ordering of complex numbers so that + ;; a < b or a = b or a > b + ;; a < b iff a+c < b+c + ;; a < b iff a*c < b*c (real c>0) + ;; a < b iff a*c > b*c (real c<0) + (or (< (realpart x) (realpart y)) + (and (= (realpart x) (realpart y)) + (< (imagpart x) (imagpart y))))) + +(defun lesseq? (x y) + (or (= x y) (less? x y))) + +(defun greater? (x y) + (less? y x)) + +(defun greatereq? (x y) + (lesseq? y x)) + +(defun euclidean-quotient (number &optional (divisor 1)) + (mvlet (((values quotient remainder) (truncate number divisor))) + (if (minusp remainder) + (if (plusp divisor) + (values (- quotient 1) (+ remainder divisor)) + (values (+ quotient 1) (- remainder divisor))) + (values quotient remainder)))) + +(defun euclidean-remainder (number &optional (divisor 1)) + ;; 0 <= remainder < abs(divisor) + (nth-value 1 (euclidean-quotient number divisor))) + +(defun ceiling-remainder (number &optional (divisor 1)) + (nth-value 1 (ceiling number divisor))) + +(defun round-remainder (number &optional (divisor 1)) + (nth-value 1 (round number divisor))) + +(defun declare-arithmetic-characteristic-relation (name pred sort &rest options) + (apply 'declare-characteristic-relation name pred sort :constraint-theory 'arithmetic options)) + +(defun declare-arithmetic-relation (name arity &rest options) + (apply 'declare-relation2 name arity + :constraint-theory 'arithmetic + `(,@options :sort ((t number))))) + +(defun declare-arithmetic-function (name arity &rest options &key (sort 'number) &allow-other-keys) + (apply 'declare-function2 name arity + :constraint-theory 'arithmetic + (if (consp sort) options `(:sort (,sort (t number)) ,@options)))) + +(defun declare-code-for-numbers () + (declare-constant 0) + (declare-constant 1) + (declare-constant -1) + + (declare-arithmetic-characteristic-relation '$$numberp #'rnumberp 'number) + (declare-arithmetic-characteristic-relation '$$complexp #'rnumberp 'complex) ;all Lisp numbers are SNARK complex numbers + (declare-arithmetic-characteristic-relation '$$realp #'rationalp 'real) ;no floats though + (declare-arithmetic-characteristic-relation '$$rationalp #'rationalp 'rational) + (declare-arithmetic-characteristic-relation '$$integerp #'integerp 'integer) + (declare-arithmetic-characteristic-relation '$$naturalp #'naturalp 'natural) + + (declare-arithmetic-inequality-relations) + + (setf *sum* (declare-arithmetic-function '$$sum 2 + :associative t + :commutative t + :sort 'number :sort-code 'arithmetic-term-sort-computer1 + :rewrite-code (list #'(lambda (x s) (arithmetic-term-rewriter3 x s #'+ 0 none)) + 'sum-term-rewriter1) + :arithmetic-relation-rewrite-code 'sum-rel-number-atom-rewriter)) + + (setf *product* (declare-arithmetic-function '$$product 2 + :associative t + :commutative t + :sort 'number :sort-code 'arithmetic-term-sort-computer1 + :rewrite-code (list #'(lambda (x s) (arithmetic-term-rewriter3 x s #'* 1 0)) + #'(lambda (x s) (distributivity-rewriter x s *sum*))) + :arithmetic-relation-rewrite-code 'product-rel-number-atom-rewriter)) + + (declare-arithmetic-function '$$uminus 1 :sort 'number :sort-code 'arithmetic-term-sort-computer1 :rewrite-code 'uminus-term-rewriter) + (declare-arithmetic-function '$$difference 2 :sort 'number :sort-code 'arithmetic-term-sort-computer1 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter5 x s *sum* '$$uminus))) + + (declare-arithmetic-function '$$floor 1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'floor))) + (declare-arithmetic-function '$$ceiling 1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'ceiling))) + (declare-arithmetic-function '$$truncate 1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'truncate))) + (declare-arithmetic-function '$$round 1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'round))) + + ;; partial, guard against division by zero + (declare-arithmetic-function '$$quotient_f 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'floor))) + (declare-arithmetic-function '$$quotient_c 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'ceiling))) + (declare-arithmetic-function '$$quotient_t 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'truncate))) + (declare-arithmetic-function '$$quotient_r 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'round))) + (declare-arithmetic-function '$$quotient_e 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'euclidean-quotient))) + (declare-arithmetic-function '$$remainder_f 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'mod))) + (declare-arithmetic-function '$$remainder_c 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'ceiling-remainder))) + (declare-arithmetic-function '$$remainder_t 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'rem))) + (declare-arithmetic-function '$$remainder_r 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'round-remainder))) + (declare-arithmetic-function '$$remainder_e 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'euclidean-remainder))) + + ;; partial, guard against division by zero + (setf *reciprocal* (declare-arithmetic-function '$$reciprocal 1 + :sort 'number :sort-code 'arithmetic-term-sort-computer2 + :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rnumberp #'/)) + :arithmetic-relation-rewrite-code 'reciprocal-rel-number-atom-rewriter)) + (declare-arithmetic-function '$$quotient 2 :sort 'number :sort-code 'arithmetic-term-sort-computer2 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter5 x s *product* '$$reciprocal))) + + ;; abs of complex numbers might be irrational + (declare-arithmetic-function '$$abs 1 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter1 x s #'rationalp #'abs))) + + (declare-arithmetic-function '$$realpart 1 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter1 x s #'rnumberp #'realpart))) + (declare-arithmetic-function '$$imagpart 1 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter1 x s #'rnumberp #'imagpart))) + nil) + +(defun declare-arithmetic-inequality-relations () + (setf *less* (declare-arithmetic-relation '$$$less 2 + :rewrite-code (list 'irreflexivity-rewriter + #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'less?)) + 'arithmetic-relation-rewriter + 'term-rel-term-to-0-rel-difference-atom-rewriter) + :falsify-code 'irreflexivity-falsifier)) + (declare-arithmetic-relation '$$$greater 2 :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter4 x s '$$$less t nil))) + (declare-arithmetic-relation '$$$lesseq 2 :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter4 x s '$$$less t t))) + (declare-arithmetic-relation '$$$greatereq 2 :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter4 x s '$$$less nil t))) + (let ((inputter + (let ((done nil)) + (function + (lambda (head args polarity) + (declare (ignorable head args polarity)) + (unless done + (setf done t) + (assert '(forall (x) (not ($$less x x))) :name :$$less-is-irreflexive) + (assert '(forall (x) (not ($$greater x x))) :name :$$greater-is-irreflexive) + (assert '(forall (x) ($$lesseq x x)) :name :$$lesseq-is-reflexive) + (assert '(forall (x) ($$greatereq x x)) :name :$$greatereq-is-reflexive) + (assert '(forall ((x number) (y number)) (implied-by ($$less x y) ($$$less x y))) :name :solve-$$less-by-$$$less) + (assert '(forall ((x number) (y number)) (implied-by ($$greater x y) ($$$less y x))) :name :solve-$$greater-by-$$$less) + (assert '(forall ((x number) (y number)) (implied-by ($$lesseq x y) (not ($$$less y x)))) :name :solve-$$lesseq-by-$$$less) + (assert '(forall ((x number) (y number)) (implied-by ($$greatereq x y) (not ($$$less x y)))) :name :solve-$$greatereq-by-$$$less) + (assert '(forall ((x number) (y number)) (implied-by (not ($$less x y)) (not ($$$less x y)))) :name :solve-~$$less-by-$$$less) + (assert '(forall ((x number) (y number)) (implied-by (not ($$greater x y)) (not ($$$less y x)))) :name :solve-~$$greater-by-$$$less) + (assert '(forall ((x number) (y number)) (implied-by (not ($$lesseq x y)) ($$$less y x))) :name :solve-~$$lesseq-by-$$$less) + (assert '(forall ((x number) (y number)) (implied-by (not ($$greatereq x y)) ($$$less x y))) :name :solve-~$$greatereq-by-$$$less)) + none))))) + (declare-relation '$$less 2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'less?))) + (declare-relation '$$greater 2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'greater?))) + (declare-relation '$$lesseq 2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'lesseq?))) + (declare-relation '$$greatereq 2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'greatereq?)))) + nil) + +(defun arithmetic-term-sort-computer0 (term subst sort-names default-sort-name) + ;; when sort-names is '(integer rational real) and default-sort-name is number + ;; if all arguments are integers then integer + ;; elif all arguments are rationals then rational + ;; elif all arguments are reals then real + ;; else number + (let ((top-arg-sort (the-sort (pop sort-names)))) + (dolist (arg (args term) top-arg-sort) + (let ((arg-sort (term-sort arg subst))) + (when (or (top-sort? arg-sort) + (loop + (cond + ((subsort? arg-sort top-arg-sort) + (return nil)) + ((null sort-names) + (return t)) + (t + (setf top-arg-sort (the-sort (pop sort-names))))))) + (return (the-sort default-sort-name))))))) + +(defun arithmetic-term-sort-computer1 (term subst) + (arithmetic-term-sort-computer0 term subst '(integer rational real) 'number)) + +(defun arithmetic-term-sort-computer2 (term subst) + (arithmetic-term-sort-computer0 term subst '(rational real) 'number)) + +(defun arithmetic-term-sort-computer3 (term subst) + (arithmetic-term-sort-computer0 term subst '(integer rational) 'real)) + +(defun arithmetic-expr-args (x subst pred) + ;; return dereferenced arguments of x if all satisfy pred; otherwise, return none + (prog-> + (split-if (args x) subst ->* arg) + (or (funcall pred arg) (return-from arithmetic-expr-args none)))) + +(defun arithmetic-atom-rewriter1 (atom subst pred operator) + (let ((args (arithmetic-expr-args atom subst pred))) + (if (eq none args) none (if (apply operator args) true false)))) + +(defun arithmetic-atom-rewriter4 (atom subst newhead reverse negate) + ;; a<=b -> ~(bb -> b=b -> ~(a ($$sum a ($$uminus b)) + ;; ($$quotient a b) -> ($$product a ($$reciprocal b)) + (declare (ignorable subst)) + (mvlet (((list a b) (args term))) + (make-compound (input-function-symbol op2 2) a (make-compound (input-function-symbol op1 1) b)))) + +(defun decompose-product-term (term subst) + (if (dereference term subst :if-compound-appl t) + (let ((head (heada term))) + (if (eq *product* head) + (mvlet* ((args (args term)) + ((values nums nonnums) (split-if #'rnumberp (argument-list-a1 head args subst) subst))) + (if (and nonnums nums (null (rest nums)) (not (eql 0 (first nums)))) + (values (make-a1-compound* head 1 nonnums) (first nums)) + (values term 1))) + (values term 1))) + (values term 1))) + +(defun sum-term-rewriter1 (term subst) + ;; collect equal arguments into products + ;; ($$sum a a b a) -> ($$sum ($$product 3 a) b) + ;; ($$sum ($$product 2 a b) ($$product b 3 a)) -> ($$product 5 a b)) + (let ((rewritten nil)) + (labels + ((combine-terms (terms) + (cond + ((null (rest terms)) + terms) + (t + (mvlet (((values term1 mult1) (decompose-product-term (first terms) subst))) + ;; combine terms in (rest terms) then find a match for term1 if there is one + (mvlet* ((mult2 nil) + ((values matches nonmatches) (prog-> + (split-if (combine-terms (rest terms)) subst ->* term2) + (unless mult2 + (unless (rnumberp term2) ;don't combine numbers + (mvlet (((values term2 mult) (decompose-product-term term2 subst))) + (when (equal-p term1 term2 subst) + (setf mult2 mult)))))))) + (declare (ignorable matches)) + (cond + (mult2 + (setf rewritten t) + (let ((mult (declare-constant (+ mult1 mult2)))) + (cond + ((eql 0 mult) + nonmatches) + ((eql 1 mult) + (cons term1 nonmatches)) + ((dereference term1 subst :if-compound-appl (eq *product* (heada term1))) + (cons (make-compound* *product* mult (args term1)) nonmatches)) + (t + (cons (make-compound *product* mult term1) nonmatches))))) + ((eq (rest terms) nonmatches) + terms) + (t + (cons (first terms) nonmatches))))))))) + (let* ((head (head term)) + (args (argument-list-a1 head (args term) subst)) + (args* (combine-terms args))) + (if rewritten (make-a1-compound* head 0 args*) none))))) + +(defun uminus-term-rewriter (term subst) + ;; ($$uminus a) -> ($$product -1 a) + (declare (ignorable subst)) + (make-compound *product* -1 (first (args term)))) + +(defun arithmetic-relation-rewriter (atom subst) + (mvlet (((list a b) (args atom))) + (or (dereference2 + a b subst + :if-constant*compound (and (rnumberp a) + (let ((fn (head b))) + (dolist (fun (function-arithmetic-relation-rewrite-code fn) nil) + (let ((v (funcall fun atom subst))) + (unless (eq none v) + (pushnew (function-code-name fn) *rewrites-used*) + (return v)))))) + :if-compound*constant (and (rnumberp b) + (let ((fn (head a))) + (dolist (fun (function-arithmetic-relation-rewrite-code fn) nil) + (let ((v (funcall fun atom subst))) + (unless (eq none v) + (pushnew (function-code-name fn) *rewrites-used*) + (return v))))))) + none))) + +(defun term-rel-term-to-0-rel-difference-atom-rewriter (atom subst) + (mvlet ((rel (head atom)) + ((list a b) (args atom))) + (cl:assert (eq *less* rel)) + (cond + ((dereference2 + a b subst + :if-variable*compound (variable-occurs-p a b subst) + :if-compound*variable (variable-occurs-p b a subst) + :if-constant*compound (and (not (rnumberp a)) (constant-occurs-p a b subst)) + :if-compound*constant (and (not (rnumberp b)) (constant-occurs-p b a subst)) + :if-compound*compound t) + (pushnew (function-code-name *product*) *rewrites-used*) + (pushnew (function-code-name *sum*) *rewrites-used*) + (make-compound rel 0 (make-compound *sum* b (make-compound *product* -1 a)))) + (t + none)))) + +(defun sum-rel-number-atom-rewriter (atom subst) + ;; (eq (sum 2 c) 6) -> (eq c 4) and (less 6 (sum 2 c)) -> (less 4 c) etc. + (mvlet ((rel (head atom)) + ((list a b) (args atom))) + (cl:assert (or (eq *less* rel) (eq *=* rel))) + (or (dereference + a subst + :if-constant (and (rnumberp a) + (dereference + b subst + :if-compound (and (eq *sum* (head b)) + (let* ((args (args b)) (arg1 (first args))) + (and (rnumberp arg1) + (make-compound (head atom) (declare-constant (- a arg1)) (make-a1-compound* *sum* 0 (rest args)))))))) + :if-compound (and (eq *sum* (head a)) + (dereference + b subst + :if-constant (and (rnumberp b) + (let* ((args (args a)) (arg1 (first args))) + (and (rnumberp arg1) + (make-compound (head atom) (make-a1-compound* *sum* 0 (rest args)) (declare-constant (- b arg1))))))))) + none))) + +(defun product-rel-number-atom-rewriter (atom subst) + ;; like sum-rel-number-atom-rewriter, but don't divide by zero, and reverse arguments when dividing by negative number + (mvlet ((rel (head atom)) + ((list a b) (args atom))) + (cl:assert (or (eq *less* rel) (eq *=* rel))) + (or (dereference + a subst + :if-constant (and (rnumberp a) + (dereference + b subst + :if-compound (and (eq *product* (head b)) + (let* ((args (args b)) (arg1 (first args))) + (and (if (eq *less* rel) (nonzero-rationalp arg1) (nonzero-rnumberp arg1)) + (if (and (eq *less* rel) (minusp arg1)) + (make-compound (head atom) (make-a1-compound* *product* 0 (rest args)) (declare-constant (/ a arg1))) + (make-compound (head atom) (declare-constant (/ a arg1)) (make-a1-compound* *product* 0 (rest args))))))))) + :if-compound (and (eq *product* (head a)) + (dereference + b subst + :if-constant (and (rnumberp b) + (let* ((args (args a)) (arg1 (first args))) + (and (if (eq *less* rel) (nonzero-rationalp arg1) (nonzero-rnumberp arg1)) + (if (and (eq *less* rel) (minusp arg1)) + (make-compound (head atom) (declare-constant (/ b arg1)) (make-a1-compound* *product* 0 (rest args))) + (make-compound (head atom) (make-a1-compound* *product* 0 (rest args)) (declare-constant (/ b arg1)))))))))) + none))) + +(defun reciprocal-rel-number-atom-rewriter (atom subst) + (mvlet ((rel (head atom)) + ((list a b) (args atom))) + (cl:assert (or (eq *less* rel) (eq *=* rel))) + (cond + ((eq *less* rel) + none) + (t + (or (dereference + a subst + :if-constant (and (nonzero-rnumberp a) + (dereference + b subst + :if-compound (and (eq *reciprocal* (head b)) + (make-compound (head atom) (declare-constant (/ a)) (arg1 b))))) + :if-compound (and (eq *reciprocal* (head a)) + (dereference + b subst + :if-constant (and (nonzero-rnumberp b) + (make-compound (head atom) (arg1 a) (declare-constant (/ b))))))) + none))))) + +(defmethod checkpoint-theory ((theory (eql 'arithmetic))) + nil) + +(defmethod uncheckpoint-theory ((theory (eql 'arithmetic))) + nil) + +(defmethod restore-theory ((theory (eql 'arithmetic))) + nil) + +(defmethod theory-closure ((theory (eql 'arithmetic))) + nil) + +(defmethod theory-assert (atom (theory (eql 'arithmetic))) + (declare (ignorable atom)) + nil) + +(defmethod theory-deny (atom (theory (eql 'arithmetic))) + (declare (ignorable atom)) + nil) + +(defmethod theory-simplify (wff (theory (eql 'arithmetic))) + wff) + +;;; code-for-numbers3.lisp EOF diff --git a/src/code-for-strings2.lisp b/src/code-for-strings2.lisp new file mode 100644 index 0000000..c835382 --- /dev/null +++ b/src/code-for-strings2.lisp @@ -0,0 +1,62 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: code-for-strings2.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun declare-code-for-strings () + (declare-characteristic-relation '$$stringp #'stringp 'string) + + (declare-function1 '$$list-to-string 1 :rewrite-code 'list-to-string-term-rewriter :sort 'string) + (declare-function1 '$$string-to-list 1 :rewrite-code 'string-to-list-term-rewriter :sort 'list) ;nil and $$cons must be of sort list for this to work + nil) + +(defun string-list-p (x &optional subst) + (dereference + x subst + :if-constant (null x) + :if-compound-cons (and (let ((a (carc x))) + (dereference a subst :if-constant (and (stringp a) (= 1 (length a))))) + (string-list-p (cdrc x) subst)))) + +(defun string-to-list (string) + ;; (string-to-list "abc") -> (list "a" "b" "c") + (map 'list (lambda (char) (declare-constant (string char))) string)) + +(defun list-to-string (list &optional subst) + ;; (list-to-string (list "a" "b" "c")) -> "abc" + ;; list is already dereferenced + (cond + ((null list) + (declare-constant "")) + (t + (declare-constant (apply #'concatenate 'string (instantiate list subst)))))) + +(defun list-to-string-term-rewriter (term subst) + (let ((x (first (args term)))) + (if (dereference x subst :if-constant (null x) :if-compound-cons (string-list-p x subst)) + (list-to-string x subst) + none))) + +(defun string-to-list-term-rewriter (term subst) + (let ((x (first (args term)))) + (if (dereference x subst :if-constant (stringp x)) + (string-to-list x) + none))) + +;;; code-for-strings2.lisp EOF diff --git a/src/coder.lisp b/src/coder.lisp new file mode 100644 index 0000000..b881465 --- /dev/null +++ b/src/coder.lisp @@ -0,0 +1,714 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: coder.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +;;; coder finds shortest condensed-detachment proofs + +(defstruct (proof-line + (:constructor make-proof-line (number + just + wff + &optional + (wff-size (snark::size wff)) + (wff-vars (snark::variables wff)))) + (:copier nil)) + (number 0 :read-only t) + (just nil :read-only t) + (wff nil :read-only t) + (wff-size 0 :read-only t) + (wff-vars nil :read-only t) + (target nil) + (hint nil) + (cut nil)) + +(defvar *coder-start-time*) +(defvar *coder-run-time-limit*) +(defvar *coder-step-count*) +(defvar *coder-derivation-count*) +(defvar *coder-print-state-interval* 1000000) +(defvar *coder-maximum-term-size-found*) +(defvar *coder-maximum-target-size*) +(defvar *coder-term-size-limit*) +(defvar *coder-term-vars-limit*) +(defvar *coder-ordering* :rpo) +(defvar *coder-do-reverse-cd*) + +(defvar *test1* nil) +(defvar *test2* nil) + +(defun coder (axioms target &rest options + &key (max 100) (min 1) (max-syms nil) (max-vars nil) (op nil) (variables nil) + kill avoid all-proofs must-use resume hints reverse-cd + (steps-to-use nil) (steps-to-use-count (length steps-to-use)) + ((:run-time-limit *coder-run-time-limit*) nil) + (*test1* *test1*) (*test2* *test2*)) + (let ((*print-pretty* nil)) + (print (cons 'coder (mapcar (lambda (x) (kwote x t)) (list* axioms target options)))) + (initialize) + (cl:assert (>= (length steps-to-use) steps-to-use-count 0)) + (setf steps-to-use (if (= 0 steps-to-use-count) nil (mapcar #'coder-input-term steps-to-use))) + (setf variables (mapcar (lambda (x) (cons x (snark::make-variable))) variables)) + (setf avoid (mapcar #'(lambda (x) (coder-input-term x variables)) avoid)) + (use-term-ordering *coder-ordering*) + (use-default-ordering 'coder-default-symbol-ordering) + (ordering-functions>constants t) + (test-option19 t) + (prog-> + (identity 0 -> naxioms) + (mapcar (lambda (x) (make-proof-line (incf naxioms) naxioms (coder-input-term x variables))) axioms -> axioms) + (unless op + (dolist (x axioms) + (let ((x (proof-line-wff x))) + (when (and (compound-p x) (eql 2 (length (args x)))) + (cond + ((null op) + (setf op (snark::function-name (head x)))) + ((not (eq op (snark::function-name (head x)))) + (warn "There is more than one binary relation; using condensed detachment for ~A." op) + (return))))))) + (reverse axioms -> axioms) + (declare-function (if reverse-cd 'rcd 'cd) 2 :ordering-status :left-to-right -> cd) + (input-target target -> target target-alist) + (and (not (contains-test-target? target)) + (reduce #'max target-alist :key (lambda (x) (snark::size (cdr x)))) + -> *coder-maximum-target-size*) + (mapcar #'coder-input-term hints -> hints) + (identity max-syms -> *coder-term-size-limit*) + (identity max-vars -> *coder-term-vars-limit*) + (identity reverse-cd -> *coder-do-reverse-cd*) + (identity nil -> all-targets-found) + (setf *coder-step-count* 0) + (setf *coder-derivation-count* 0) + (setf *coder-maximum-term-size-found* 0) + (get-internal-run-time -> *coder-start-time*) + (loop for nsteps from min to max + do (let (targets-found) + (format t "~2%Search for ~D-step proof... " nsteps) + (force-output) + (setf targets-found (coder1 axioms target nsteps cd op kill avoid all-proofs must-use resume hints steps-to-use steps-to-use-count)) + (setf resume nil) + (let ((run-time (round (- (get-internal-run-time) *coder-start-time*) internal-time-units-per-second))) + (format t "~%~D steps in ~D seconds" *coder-step-count* run-time) + (when (and *coder-run-time-limit* (< *coder-run-time-limit* run-time)) + (format t "; time limit exceeded") + (return))) + (when targets-found + (setf target (remove-target target targets-found)) + (setf all-targets-found (nconc targets-found all-targets-found)) + (when (null target) + (return))))) + (format t ".") + (mapcar (lambda (x) (or (car (rassoc x target-alist)) x)) all-targets-found)))) + +(defun coder1 (axioms target nsteps cd op kill avoid all-proofs must-use resume hints steps-to-use steps-to-use-count) + (let ((together-target? (together-target? target)) + (targets-found nil)) + (labels + ((coder2 (lines nsteps unused target* ntargets steps-to-use steps-to-use-count) + ;; target* is used to record remaining targets only if target is a together-target + (cond + ((eql 0 nsteps) + (incf *coder-derivation-count*) + (cond + (together-target? + (cl:assert (null target*)) ;all targets should have been matched + (print-proof lines) + (print-proof-for-otter-verification lines op) + (force-output) + (setf targets-found (rest target)) + (unless all-proofs + (return-from coder1 targets-found))) + (t + (let ((found (target? target (proof-line-wff (first lines))))) ;is final wff a target? + (when found + (setf (proof-line-target (first lines)) found) + (print-proof lines) + (print-proof-for-otter-verification lines op) + (force-output) + (dolist (v found) + (pushnew v targets-found)) + (unless all-proofs + (when (null (setf target (remove-target target found))) + (return-from coder1 targets-found)))))))) + (t + (flet + ((coder3 (x y xunused? yunused? new-line) + (let ((found (and together-target? (target? target* (proof-line-wff new-line))))) + (cond + (found + ;;(princf *coder-step-count*) + (cl:assert (null (rest found)) () "More than one together-target simultaneously satisfied.") + (when (eql 0 (rem (incf *coder-step-count*) *coder-print-state-interval*)) + (let ((run-time (- (get-internal-run-time) *coder-start-time*))) + (print-coder-state (cons new-line lines) run-time) + (when (and *coder-run-time-limit* (< *coder-run-time-limit* (round run-time internal-time-units-per-second))) + (return-from coder1 targets-found)))) + (setf (proof-line-target new-line) found) + (coder2 + (cons new-line lines) + (- nsteps 1) + (let ((unused (if xunused? (remove x unused) unused))) + (if yunused? (remove y unused) unused)) + (remove-target target* found) + (- ntargets 1) + steps-to-use + steps-to-use-count)) + (t + (let ((new-steps-to-use steps-to-use) (new-steps-to-use-count steps-to-use-count)) + (when (< 0 steps-to-use-count) + (setf new-steps-to-use (remove-step-to-use (proof-line-wff new-line) steps-to-use)) + (unless (eq steps-to-use new-steps-to-use) + (decf new-steps-to-use-count))) + (cond + ((if together-target? + (>= (- nsteps 1) (+ ntargets new-steps-to-use-count)) + (if (= 1 nsteps) + (= 0 steps-to-use-count) + (> (- nsteps 1) new-steps-to-use-count))) + ;;(princf *coder-step-count*) + (when (eql 0 (rem (incf *coder-step-count*) *coder-print-state-interval*)) + (let ((run-time (- (get-internal-run-time) *coder-start-time*))) + (print-coder-state (cons new-line lines) run-time) + (when (and *coder-run-time-limit* (< *coder-run-time-limit* (round run-time internal-time-units-per-second))) + (return-from coder1 targets-found)))) + (coder2 + (cons new-line lines) + (- nsteps 1) + (let ((unused (if xunused? (remove x unused) unused))) + (cons new-line (if yunused? (remove y unused) unused))) + target* + ntargets + new-steps-to-use + new-steps-to-use-count))))))))) + (declare (dynamic-extent #'coder3)) + (let ((new-lines nil) + (new-line-number (+ (proof-line-number (first lines)) 1))) + (let ((nunused (length unused)) + (revlines (reverse lines))) + (dolist (x revlines) ;use reverse to reorder search 2003-04-17 + (let ((xunused? (member x unused)) + (big nil)) + (dolist (y revlines) ;use reverse to reorder search 2004-01-10 + (let ((yunused? (and (not (eq x y)) (member y unused)))) + (unless (> (if xunused? + (if yunused? (- nunused 1) nunused) + (if yunused? nunused (+ nunused 1))) + (if (eql 1 ntargets) nsteps (+ nsteps ntargets -1))) + (let ((just (make-compound cd (proof-line-just x) (proof-line-just y)))) + (when (or big + (and (eq '> (snark::simplification-ordering-compare-terms0 + just (proof-line-just (first lines)) nil '>)) + (setf big t))) + (prog-> + (do-cd (proof-line-wff x) (proof-line-wff y) op (eql ntargets nsteps) ->* new-wff new-wff-size cut) + (if new-wff-size + (make-proof-line new-line-number just new-wff new-wff-size) + (make-proof-line new-line-number just new-wff) + -> new-line) + (when cut + (setf (proof-line-cut new-line) t)) + (cond + ((and resume + (let ((l1 resume) (l2 (coder-state (cons new-line lines)))) + (loop + (cond + ((null l1) + (setf resume nil) + (setf *coder-step-count* -1) + (return nil)) + ((null l2) + (return nil)) + ((not (equal (pop l1) (pop l2))) + (return t)))))) + ) + ((or hints *test1* *test2*) + (cond + ((and kill (funcall kill new-line)) + ) + ((and *test2* (backward-subsumes? new-line lines)) + ;; reject all derivations beginning with lines + ;; when new-line is equal to an earlier line + ;; as well as when it strictly subsumes it + ;; as in the case below + (return-from coder2)) + ((forward-subsumed? new-line lines) + ) + ((and (not *test2*) (backward-subsumes? new-line lines)) + ;; don't just block adding new-line to lines but + ;; reject all derivations beginning with lines + (return-from coder2)) + (t + (push (list x y xunused? yunused? new-line) new-lines)))) + (t + (unless (or (and kill (funcall kill new-line)) + (and avoid (member (proof-line-wff new-line) avoid :test #'snark::variant-p)) + (forward-subsumed? new-line lines) + (backward-subsumes? new-line lines)) + (coder3 x y xunused? yunused? new-line)))) + (when cut + (return))))))))))) + (when new-lines + (dolist (new-line (if hints (sort-new-lines new-lines hints) (nreverse new-lines))) + (apply #'coder3 new-line))))))))) + (let ((ntargets (if together-target? (length (rest target)) 1))) + (unless (> (+ ntargets steps-to-use-count) nsteps) + (coder2 axioms nsteps (selected-lines axioms must-use) target ntargets steps-to-use steps-to-use-count))) + targets-found))) + +(defun sort-new-lines (new-lines hints) + (dolist (x new-lines) + (when (member (proof-line-wff (fifth x)) hints :test #'snark::subsumes-p) + (setf (proof-line-hint (fifth x)) t))) + (stable-sort (nreverse new-lines) + (lambda (x y) + (and (proof-line-hint (fifth x)) + (not (proof-line-hint (fifth y))))))) + +(defun selected-lines (lines nums) + (cond + ((eq t nums) + lines) + (t + (remove-if (lambda (line) (not (member (proof-line-number line) nums))) lines)))) + +(defun coder-default-symbol-ordering (x y) + (if (numberp x) + (if (and (numberp y) (> x y)) '> '<) + '>)) + +(defun forward-subsumed? (new-line lines) + ;; return true iff new-line is subsumed by an earlier line + (let ((new-wff (proof-line-wff new-line)) + (new-wff-size (proof-line-wff-size new-line)) + (new-wff-vars (proof-line-wff-vars new-line))) + (dolist (l lines nil) + (when (and (>= new-wff-size (proof-line-wff-size l)) + (snark::subsumed-p1 new-wff (proof-line-wff l) new-wff-vars)) + (return t))))) + +(defun backward-subsumes? (new-line lines) + ;; return true iff new-line subsumes an earlier line that is not used to derive new-line + (let ((new-wff (proof-line-wff new-line)) + (new-wff-size (proof-line-wff-size new-line))) + (dolist (l lines nil) + (let ((j (proof-line-just l))) + ;; don't backward subsume axioms or ancestors + (cond + ((not (compound-p j)) ;l and rest of lines are all axioms + (return nil)) + ((and (<= new-wff-size (proof-line-wff-size l)) + (snark::subsumes-p1 new-wff (proof-line-wff l) (proof-line-wff-vars l)) + (not (snark::occurs-p j (proof-line-just new-line) nil))) + (return t))))))) + +(defun do-cd (function x y op &optional last-line) + ;; perform condensed detachment operation + ;; with x as major premise and y as minor premise + ;; assume x and y are variable disjoint unless (eq x y) + ;; return result with new variables + (prog-> + (when (and (compound-p x) (eq op (function-name (head x)))) + (args x -> args) + (first args -> x1) + (second args -> x2) + (when *coder-do-reverse-cd* + (psetf x1 x2 x2 x1)) + ;; (cd (i x t) s) always yields t for any s if x does not occur in t + ;; producing alternative derivations which differ only in which minor premise is used + ;; used to be enabled by *test3*, default since 2003-08-14 + (and (snark::variable-p x1) (not (snark::occurs-p x1 x2)) -> cut) + ;; in this case, use same wff as major and minor premise, to avoid unnecessary use of y + ;; added 2003-11-30 + (when (and cut (not (eq x y))) + (return-from do-cd)) + (unify x1 (if (eq x y) (snark::renumber-new y) y) ->* subst) + (snark::size x2 subst -> n) + ;; don't create big terms that cannot subsume a target for the last line of proof + (unless (or (and last-line *coder-maximum-target-size* (< *coder-maximum-target-size* n)) + (and *coder-term-size-limit* (< *coder-term-size-limit* n)) + (and *coder-term-vars-limit* (< *coder-term-vars-limit* (length (snark::variables x2 subst))))) + (when (and (not *coder-term-size-limit*) (< *coder-maximum-term-size-found* n)) + (format t " ~D syms " n) + (force-output) + (setf *coder-maximum-term-size-found* n)) + (snark::renumber-new x2 subst -> x2*) + (unless cut + (setf cut (snark::variant-p x2 x2*))) + (funcall function x2* n cut))))) + +(defun just-line-number (j lines) + (proof-line-number (first (member j lines :key #'proof-line-just :test #'equal-p)))) + +(defun just-list (j lines) + (if (compound-p j) + (cons (function-name (head j)) + (mapcar (lambda (x) + (if (compound-p x) (just-line-number x lines) x)) + (args j))) + j)) + +(defun print-proof-line-just (line lines) + (let ((n (proof-line-number line)) + (j (just-list (proof-line-just line) lines))) + (format t "~2D ~A" n (if (eql n j) 'ax j))) + (when (proof-line-cut line) + (format t "!"))) + +(defun print-proof-line (line lines) + (let ((j (proof-line-just line))) + (format t "~%(") (print-proof-line-just line lines) (format t "~15T") + (print-term (snark::renumber (proof-line-wff line))) + (format t ")") + (cond + ((compound-p j) + (format t "~84T;~2D sym~:P, ~D var~:P" + (snark::size (proof-line-wff line)) + (length (snark::variables (proof-line-wff line)))) + (when (proof-line-target line) + (format t " target"))) + ((not (member j lines + :key #'proof-line-just + :test (lambda (x y) (and (not (snark::equal-p x y)) (snark::occurs-p x y nil))))) + (format t "~84T;unused"))))) + +(defun print-proof-lines (lines) + (mapc (lambda (line) (print-proof-line line lines)) lines)) + +(defun print-proof (lines) + (format t "~2%Proof:") + (print-proof-lines (reverse lines)) + (format t "~%End proof.") + (terpri)) + +(defun coder-state (lines) + (let ((lines (reverse lines))) + (mapcan (lambda (line) + (let ((j (just-list (proof-line-just line) lines))) + (if (consp j) (list j) nil))) + lines))) + +(defun print-coder-state (lines &optional (run-time (- (get-internal-run-time) *coder-start-time*))) + (format t "~% ~A ~5Dm " + (subseq (print-current-time nil t) 4 13) + (round run-time (* 60 internal-time-units-per-second))) + (mapc (lambda (x) (princ x) (princ " ")) (coder-state lines)) + (force-output)) + +;;; coder's target argument is either a normal-target or a together-target +;;; +;;; a single-target is one of +;;; a term - find generalization (or variant) of this term +;;; (TEST predicate) +;;; +;;; a normal-target is one of +;;; a single-target +;;; (OR normal-target1 ... normal-targetn) - search until one target is found +;;; (AND normal-target1 ... normal-targetn) - search until all targets are found +;;; +;;; a together-target is +;;; (TOGETHER single-target1 ... single-targetn) - search until all targets are found in a single derivation +;;; it is assumed that no single formula will satisfy more than one of these targets + +(defvar *input-target-alist*) + +(defun input-target (target) + (let ((*input-target-alist* nil)) + (values (cond + ((together-target? target) + (input-together-target target)) + (t + (input-normal-target target))) + *input-target-alist*))) + +(defun together-target? (target) + (and (consp target) (eq 'together (first target)))) + +(defun contains-test-target? (target) + (case (and (consp target) (first target)) + (test + t) + ((and or together) + (some #'contains-test-target? (rest target))))) + +(defun wrap2 (f l) + (cl:assert (consp l)) + (if (null (rest l)) (first l) (cons f l))) + +(defun coder-input-term (x &optional variables) + (snark::renumber-new + (snark::input-term + (if (stringp x) (read-infix-term x :case (readtable-case *readtable*)) x) + :*input-wff-substitution* variables))) + +(defun input-together-target (target) + (wrap2 (first target) (mapcar #'input-single-target (rest target)))) + +(defun input-normal-target (target) + (cond + ((and (consp target) (member (first target) '(or and))) + (wrap2 (first target) (mapcar #'input-normal-target (rest target)))) + (t + (input-single-target target)))) + +(defun input-single-target (target) + (cl:assert (not (and (consp target) (member (first target) '(or and together))))) + (cond + ((and (consp target) (eq 'test (first target))) + target) + (t + (let ((target* (coder-input-term target))) + (push (cons target target*) *input-target-alist*) + target*)))) + +(defun target? (target x &optional l) + ;; does x generalize a term in target? + (cond + ((and (consp target) (member (first target) '(or and together))) + (dolist (y (rest target) l) + (setf l (target? y x l)))) + ((and (consp target) (eq 'test (first target))) + (if (funcall (second target) x) (adjoin target l) l)) + (t + (if (snark::subsumes-p x target) (adjoin target l) l)))) + +(defun remove-target (target l) + (cond + ((and (consp target) (eq 'or (first target))) + (let ((v (mapcar (lambda (y) + (let ((y* (remove-target y l))) + (or y* (return-from remove-target nil)))) + (rest target)))) + (wrap2 'or v))) + ((and (consp target) (member (first target) '(and together))) + (let ((v (mapcan (lambda (y) + (let ((y* (remove-target y l))) + (and y* (list y*)))) + (rest target)))) + (and v (wrap2 (first target) v)))) + (t + (if (member target l) nil target)))) + +(defun remove-step-to-use (wff steps-to-use) + (cond + ((null steps-to-use) + nil) + ((snark::subsumes-p wff (first steps-to-use)) + (rest steps-to-use)) + (t + (let* ((l (rest steps-to-use)) + (l* (remove-step-to-use wff l))) + (if (eq l l*) steps-to-use (cons (first steps-to-use) l*)))))) + +(defun print-proof-for-otter-verification (lines op) + ;; Bob Veroff provided the template for this script + (let ((lines (reverse lines))) + (format t "~%% OTTER SCRIPT TO TRY TO FIND SAME PROOF") + (format t "~% set(hyper_res). clear(print_kept). clear(print_back_sub). assign(stats_level,0).") + (format t "~% assign(bsub_hint_add_wt,-1000000). set(keep_hint_subsumers). assign(max_weight,1).") + (format t "~% list(sos). % AXIOMS:") + (dolist (l lines) + (unless (compound-p (proof-line-just l)) + (format t "~% ") (print-term-for-otter2 (proof-line-wff l)) (format t "."))) + (format t "~% end_of_list.") + (cond + (*coder-do-reverse-cd* + (format t "~% list(usable). % REVERSED CONDENSED DETACHMENT RULE:") + (format t "~% -P(~A(x,y)) | -P(y) | P(x)." (string-downcase (string op)))) + (t + (format t "~% list(usable). % CONDENSED DETACHMENT RULE:") + (format t "~% -P(~A(x,y)) | -P(x) | P(y)." (string-downcase (string op))))) + (format t "~% end_of_list.") + (let ((first t)) + (dolist (l lines) + (when (proof-line-target l) + (cond + (first + (setf first nil) + (format t "~% list(usable). % TARGET:")) + (t + (format t " |"))) + (format t "~% -") (print-term-for-otter2 (proof-line-wff l) t))) + (unless first + (format t ".~% end_of_list."))) + (format t "~% list(hints). % PROOF LINES:") + (dolist (l lines) + (format t "~% ") (print-term-for-otter2 (proof-line-wff l)) (format t ".") + (format t "~72T%") (print-proof-line-just l lines) + (when (proof-line-target l) + (format t " TARGET"))) + (format t "~% end_of_list.") + (format t "~%% OTTER SCRIPT END~%") + )) + +(defun print-term-for-otter2 (term &optional ground) + (princ "P(") + (print-term-for-otter (snark::renumber term) ground) + (princ ")") + term) + +(defun print-term-for-otter (term &optional ground) + (dereference + term nil + :if-variable (cond + (ground + (princ #\c) + (princ (snark::variable-number term))) + (t + (let ((n (snark::variable-number term))) + (cond + ((> 6 n) + (princ (ecase n (0 #\x) (1 #\y) (2 #\z) (3 #\u) (4 #\v) (5 #\w)))) + (t + (princ #\v) + (princ n)))))) + :if-constant (cond + ((numberp term) + (princ term)) + (t + (princ #\c) + (princ (string-downcase (string term))))) + :if-compound (progn + (princ (string-downcase (string (function-name (head term))))) + (princ "(") + (let ((first t)) + (dolist (arg (args term)) + (if first (setf first nil) (princ ",")) + (print-term-for-otter arg ground))) + (princ ")"))) + term) + +(defun comb (n m) + (/ (let ((v 1)) + (dotimes (i m) + (setf v (* v (- n i)))) + v) + (let ((v 1)) + (dotimes (i (- m 1)) + (setf v (* v (+ i 2)))) + v))) + +(defun shorten-proof (proof &rest options + &key (drop 3) (shorten-by 1) (naxioms 1) (targets '(-1)) all-proofs skip from to min max + (variables '(x y z u v w v0 + x1 y1 z1 u1 v1 w1 v6 v7 v8 v9 v10 v11 + x2 y2 z2 u2 v2 w2 v12 v13 v14 v15 v16 v17 + x3 y3 z3 u3 v3 w3 v18 v19 v20 v21 v22 v23 + x4 y4 z4 u4 v4 w4 v24 v25 v26 v27 v28 v29 + x5 y5 z5 u5 v5 w5 v30 v31 v32 v33 v34 v35))) + ;; attempt to find a shorter proof than argument proof (a list of formulas) + ;; default is to assume there is a single axiom (first in proof) and single target (last in proof) + ;; to try to find a shorter proof, + ;; omit drop steps and search for a proof with fewer than drop steps to replace them + ;; + ;; :drop 0 :shorten-by 0 options can be used to reproduce proof + (print (cons 'shorten-proof (mapcar (lambda (x) (kwote x t)) (list* proof options)))) + (when skip + (cl:assert (null from)) + (setf from (+ skip 1))) + (let* ((l proof) + (proof-length (length proof)) + (nsteps (- proof-length naxioms)) + (target nil) + (source nil) + (found nil) + (count 0)) + (dolist (i (reverse targets)) ;collect targets into target + (push (nth (if (> 0 i) (+ proof-length i) i) proof) target)) + (dotimes (i naxioms) ;collect axioms into source + (declare (ignorable i)) + (push (pop l) source)) + (when (eql 1 naxioms) ;if there is only one axiom, first step is forced, + (unless (or (member 2 targets) (member (- 1 proof-length) targets)) + (setf l (rest l)))) ;so omit it from candidates to be replaced + (setf l (set-difference l target)) ;l is now list of potentially replaceable nontarget steps + (prog-> + (length l -> len) + (comb len drop -> ncombs) + (choose l (- len drop) ->* kept-steps) ;shorten l by drop steps in all ways + (incf count) + (when (and to (< to count)) + (return-from prog->)) + (when (implies from (<= from count)) + (format t "~2%Shorten proof attempt ~D of ~D" count ncombs) + (when (coder source + (cons 'together (append target kept-steps)) + :min (or min (- nsteps drop)) + :max (or max (- nsteps shorten-by)) + :all-proofs all-proofs + :variables variables) + (setf found t) + (unless all-proofs + (return-from prog->))))) + found)) + +(defun strip-ors (wff) + (cond + ((and (consp wff) (eq 'or (first wff))) + (reduce #'append (mapcar #'strip-ors (rest wff)))) + (t + (list wff)))) + +(defun condensed-detachment-rule-p (wff) + ;; recognizer for (or (not (p (i ?x ?y))) (or (not (p ?x)) (p ?y))) + (let ((l (strip-ors wff))) + (and (= 3 (length l)) + (let ((subst (some (lambda (x) + (let ((subst (pattern-match '(not (?pred (?fun ?var1 ?var2))) x))) + (and subst + (let ((var1 (sublis subst '?var1)) + (var2 (sublis subst '?var2))) + (and (neq var1 var2) + (can-be-free-variable-name var1) + (can-be-free-variable-name var2))) + subst))) + l))) + (and (member (sublis subst '(not (?pred ?var1))) l :test #'equal) + (member (sublis subst '(?pred ?var2)) l :test #'equal) + subst))))) + +(defun condensed-detachment-problem-p (assertions) + (and (every (lambda (x) (and (consp x) (eq 'assertion (first x)))) assertions) + (multiple-value-bind + (cd-rule subst) + (dolist (x assertions) + (let ((x (second x))) + (let ((subst (condensed-detachment-rule-p x))) + (when subst + (return (values x subst)))))) + (and cd-rule + (let ((axioms nil) + (target nil) + (axiom-pattern (sublis subst '((?pred ?x)))) + (target-pattern (sublis subst '(not (?pred ?x))))) + (dolist (x assertions (and axioms target (values (reverse axioms) target (sublis subst '?fun) (sublis subst '?pred)))) + (let ((x (second x))) + (unless (eq cd-rule x) + (let ((x (strip-ors x))) + (cond + ((pattern-match axiom-pattern x) + (push (second (first x)) axioms)) + ((and (null target) (every (lambda (x) (pattern-match target-pattern x)) x)) + (setf target (if (null (rest x)) + (second (second (first x))) + (cons 'together (mapcar (lambda (x) (second (second x))) x))))) + (t + (return nil)))))))))))) + +;;; coder.lisp EOF diff --git a/src/collectors.lisp b/src/collectors.lisp new file mode 100644 index 0000000..8617ce0 --- /dev/null +++ b/src/collectors.lisp @@ -0,0 +1,143 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*- +;;; File: collectors.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-lisp) + +(defun make-collector () + (cons nil nil)) + +(defun collector-value (collector) + (car collector)) + +(defun collect-item (x collector) + ;; as in Interlisp TCONC, + ;; add single element x to the end of the list in (car collector) + ;; and update (cdr collector) to point to the end of the list + (setf x (cons x nil)) + (cond + ((null collector) + (cons x x)) + ((null (car collector)) + (rplacd collector (setf (car collector) x))) + (t + (rplacd collector (setf (cddr collector) x))))) + +(defun collect-list (l collector) + ;; as in Interlisp LCONC, + ;; add list l to the end of the list in (car collector) + ;; and update (cdr collector) to point to the end of the list + (cond + ((null l) + collector) + ((null collector) + (cons l (last l))) + ((null (car collector)) + (rplacd collector (last (setf (car collector) l)))) + (t + (rplacd collector (last (setf (cddr collector) l)))))) + +(defstruct (queue + (:constructor make-queue ()) + (:copier nil)) + (list nil :type list) + (last nil :type list)) + +(defun queue-empty-p (queue) + (null (queue-list queue))) + +(defun enqueue (item queue) + (let ((l (cons item nil))) + (setf (queue-last queue) (if (queue-list queue) (setf (rest (queue-last queue)) l) (setf (queue-list queue) l))) + item)) + +(defun dequeue (queue) + (let ((l (queue-list queue))) + (if l + (prog1 (first l) (setf (queue-list queue) (or (rest l) (setf (queue-last queue) nil)))) + nil))) + +(defmacro collect (item place) + ;; like (setf place (nconc place (list item))) + ;; except last cell of list is remembered in place-last + ;; so that operation is O(1) + ;; it can be used instead of (push item place) + (nreverse place) loop idiom + ;; user must declare place-last variable or slot + (let* ((args (if (atom place) + nil + (mapcar (lambda (arg) (list (gensym) arg)) (rest place)))) + (place (if (atom place) + place + (cons (first place) (mapcar #'first args)))) + (place-last (if (atom place) + (intern (concatenate + 'string + (symbol-name place) + (symbol-name :-last))) + (cons (intern (concatenate + 'string + (symbol-name (first place)) + (symbol-name :-last))) + (rest place)))) + (v (gensym)) + (l (gensym))) + `(let* ((,v (cons ,item nil)) ,@args (,l ,place)) + (cond + ((null ,l) + (setf ,place (setf ,place-last ,v))) + (t + (rplacd ,place-last (setf ,place-last ,v)) + ,l))))) + +(defmacro ncollect (list place) + ;; like (setf place (nconc place list)) + ;; except last cell of list is remembered in place-last + (let* ((args (if (atom place) + nil + (mapcar (lambda (arg) (list (gensym) arg)) (rest place)))) + (place (if (atom place) + place + (cons (first place) (mapcar #'first args)))) + (place-last (if (atom place) + (intern (concatenate + 'string + (symbol-name place) + (symbol-name :-last))) + (cons (intern (concatenate + 'string + (symbol-name (first place)) + (symbol-name :-last))) + (rest place)))) + (v (gensym)) + (l (gensym)) + (e (gensym))) + `(let* ((,v ,list) ,@args (,l ,place)) + (if (null ,v) + ,l + (let ((,e (rest ,v))) + (setf ,e (if (null ,e) ,v (last ,e))) + (cond + ((null ,l) + (setf ,place-last ,e) + (setf ,place ,v)) + (t + (rplacd ,place-last ,v) + (setf ,place-last ,e) + ,l))))))) + +;;; collectors.lisp EOF diff --git a/src/connectives.lisp b/src/connectives.lisp new file mode 100644 index 0000000..1cd1554 --- /dev/null +++ b/src/connectives.lisp @@ -0,0 +1,550 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: connectives.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; wff = well-formed formula +;;; atom = atomic fomula + +(defun not-wff-error (x &optional subst) + (error "~A is not a formula." (term-to-lisp x subst))) + +(defun not-clause-error (x &optional subst) + (error "~A is not a clause." (term-to-lisp x subst))) + +(defun head-is-logical-symbol (wff) + (dereference + wff nil + :if-constant nil + :if-variable (not-wff-error wff) + :if-compound-cons (not-wff-error wff) + :if-compound-appl (function-logical-symbol-p (heada wff)))) + +(defun negation-p (wff) + (eq 'not (head-is-logical-symbol wff))) + +(defun conjunction-p (wff) + (eq 'and (head-is-logical-symbol wff))) + +(defun disjunction-p (wff) + (eq 'or (head-is-logical-symbol wff))) + +(defun implication-p (wff) + (eq 'implies (head-is-logical-symbol wff))) + +(defun reverse-implication-p (wff) + (eq 'implied-by (head-is-logical-symbol wff))) + +(defun equivalence-p (wff) + (eq 'iff (head-is-logical-symbol wff))) + +(defun exclusive-or-p (wff) + (eq 'xor (head-is-logical-symbol wff))) + +(defun conditional-p (wff) + (eq 'if (head-is-logical-symbol wff))) + +(defun universal-quantification-p (wff) + (eq 'forall (head-is-logical-symbol wff))) + +(defun existential-quantification-p (wff) + (eq 'exists (head-is-logical-symbol wff))) + +(defun atom-p (wff) + (not (head-is-logical-symbol wff))) + +(defun literal-p (wff &optional (polarity :pos) strict) + ;; returns (values atom polarity) + ;; only atomic formulas and negated atomic formulas are strict literals + ;; nonstrict literals can have nested negations + (let ((v (head-is-logical-symbol wff))) + (cond + ((null v) + (values wff polarity)) + ((eq 'not v) + (let ((wff1 (arg1a wff))) + (if strict + (and (atom-p wff1) (values wff1 (opposite-polarity polarity))) + (literal-p wff1 (opposite-polarity polarity))))) + (t + nil)))) + +(defun clause-p (wff &optional no-true-false strict neg) + ;; only atomic formulas, negated atomic formulas, their disjunctions, and (optionally) true and false are strict clauses + ;; nonstrict clauses are implications etc. interpretable as single clauses + (labels + ((clause-p (wff neg) + (case (head-is-logical-symbol wff) + ((nil) + (implies no-true-false (not (or (eq true wff) (eq false wff))))) + (not + (if strict + (atom-p (arg1a wff)) + (clause-p (arg1a wff) (not neg)))) + (and + (and (not strict) + neg + (dolist (arg (argsa wff) t) + (unless (clause-p arg t) + (return nil))))) + (or + (and (not neg) + (if strict + (dolist (arg (argsa wff) t) + (unless (literal-p arg :pos t) + (return nil))) + (dolist (arg (argsa wff) t) + (unless (clause-p arg nil) + (return nil)))))) + (implies + (and (not strict) + (not neg) + (let ((args (argsa wff))) + (and (clause-p (first args) t) + (clause-p (second args) nil))))) + (implied-by + (and (not strict) + (not neg) + (let ((args (argsa wff))) + (and (clause-p (first args) nil) + (clause-p (second args) t)))))))) + (clause-p wff neg))) + +(defun equality-relation-symbol-p (fn) + (eq '= (function-boolean-valued-p fn))) + +(defun equality-p (wff) + (dereference + wff nil + :if-constant nil + :if-variable (not-wff-error wff) + :if-compound-cons (not-wff-error wff) + :if-compound-appl (equality-relation-symbol-p (head wff)))) + +(defun positive-equality-wff-p (wff) + ;; nothing but strictly positive occurrences of equalities + (prog-> + (map-atoms-in-wff wff ->* atom polarity) + (unless (and (eq :pos polarity) (equality-p atom)) + (return-from positive-equality-wff-p nil))) + t) + +(declare-snark-option eliminate-negations nil nil) +(declare-snark-option flatten-connectives t t) ;e.g., replace (and a (and b c)) by (and a b c) +(declare-snark-option ex-join-negation t t) ;e.g., replace (equiv a false) by (not a) + +(defun conjoin* (wffs &optional subst) + (ao-join* wffs subst *and* true)) + +(defun disjoin* (wffs &optional subst) + (ao-join* wffs subst *or* false)) + +(defun conjoin (wff1 wff2 &optional subst) + (cond + ((or (eq wff1 wff2) (eq true wff1) (eq false wff2)) + wff2) + ((or (eq false wff1) (eq true wff2)) + wff1) + (t + (ao-join* (list wff1 wff2) subst *and* true)))) + +(defun disjoin (wff1 wff2 &optional subst) + (cond + ((or (eq wff1 wff2) (eq false wff1) (eq true wff2)) + wff2) + ((or (eq true wff1) (eq false wff2)) + wff1) + (t + (ao-join* (list wff1 wff2) subst *or* false)))) + +(defun ao-join* (wffs subst connective identity) + ;; create conjunction or disjunction of wffs + ;; handle true, false, equal and complementary wffs + (do ((not-identity (if (eq true identity) false true)) + (wffs* nil) wffs*-last + (poswffs* nil) + (negwffs* nil) + wff) + ((null wffs) + (cond + ((null wffs*) + identity) + ((null (rest wffs*)) + (first wffs*)) + ((flatten-connectives?) + (make-compound* connective wffs*)) + (t + (make-compound2 connective wffs*)))) + (setf wff (pop wffs)) + (when subst + (setf wff (instantiate wff subst))) + (cond + ((and (compound-p wff) (eq connective (head wff))) + (setf wffs (if wffs (append (argsa wff) wffs) (argsa wff)))) + (t + (mvlet (((values wff neg) (not-not-eliminate wff))) + (if neg + (cond + ((and poswffs* (hts-member-p neg poswffs*)) + (return not-identity)) + ((hts-adjoin-p neg (or negwffs* (setf negwffs* (make-hash-term-set)))) + (collect wff wffs*))) + (cond + ((eq identity wff) + ) + ((eq not-identity wff) + (return not-identity)) + ((and negwffs* (hts-member-p wff negwffs*)) + (return not-identity)) + ((hts-adjoin-p wff (or poswffs* (setf poswffs* (make-hash-term-set)))) + (collect wff wffs*))))))))) + +(defun not-not-eliminate (wff) + (let ((neg nil) -wff) + (loop + (dereference + wff nil + :if-variable (return-from not-not-eliminate + (if neg (values -wff wff) wff)) + :if-constant (return-from not-not-eliminate + (cond + ((eq true wff) + (if neg false true)) + ((eq false wff) + (if neg true false)) + (t + (if neg (values -wff wff) wff)))) + :if-compound (cond + ((eq *not* (head wff)) + (if neg (setf neg nil) (setf neg t -wff wff)) + (setf wff (arg1a wff))) + (t + (return-from not-not-eliminate + (if neg (values -wff wff) wff)))))))) + +(defun make-equivalence* (wffs &optional subst) + (ex-join* wffs subst *iff* true)) + +(defun make-exclusive-or* (wffs &optional subst) + (ex-join* wffs subst *xor* false)) + +(defun make-equivalence (wff1 wff2 &optional subst) + (cond + ((eq wff1 wff2) + true) + ((eq true wff1) + wff2) + ((eq true wff2) + wff1) + (t + (make-equivalence* (list wff1 wff2) subst)))) + +(defun make-exclusive-or (wff1 wff2 &optional subst) + (cond + ((eq wff1 wff2) + false) + ((eq false wff1) + wff2) + ((eq false wff2) + wff1) + (t + (make-exclusive-or* (list wff1 wff2) subst)))) + +(defun ex-join* (wffs subst connective identity) + ;; create equivalence or exclusive-or of wffs + ;; handle true, false, equal and complementary wffs + (let ((not-identity (if (eq true identity) false true)) + n n1 n2 negate) + (setf n (length (setf wffs (argument-list-a1 connective wffs subst identity)))) + (setf n1 (length (setf wffs (remove not-identity wffs)))) + (setf negate (oddp (- n n1))) + (setf n n1) + (do ((wffs* nil) wff) + ((null wffs) + (cond + ((null wffs*) + (if negate not-identity identity)) + (t + (when negate + (setf wffs* (if (ex-join-negation?) + (cons (negate (first wffs*)) (rest wffs*)) + (cons not-identity wffs*)))) + (cond + ((null (rest wffs*)) + (first wffs*)) + ((flatten-connectives?) + (make-compound* connective (nreverse wffs*))) + (t + (make-compound2 connective (nreverse wffs*))))))) + (setf wff (pop wffs)) + (setf n1 (length (setf wffs (remove wff wffs :test (lambda (x y) (equal-p x y subst)))))) + (setf n2 (length (setf wffs (remove wff wffs :test (lambda (x y) (complement-p x y subst)))))) + (psetq n1 (- n n1) ;count of wff in wffs + n2 (- n1 n2) ;count of ~wff in wffs + n n2) ;length of new value of wffs + (cond + ((evenp n1) + (when (oddp n2) + (push wff wffs*) + (setf negate (not negate)) ;was wrong (setf negate t); fixed 2011-05-13 + )) + ((evenp n2) + (push wff wffs*)) + (t + (setf negate (not negate)) ;was wrong (setf negate t); fixed 2011-05-13 + ))))) + +(defun negate0 (wffs &optional subst) + (declare (ignore subst)) + (cl:assert (eql 1 (length wffs))) + (make-compound* *not* wffs)) + +(defun negate* (wffs &optional subst) + (cl:assert (eql 1 (length wffs))) + (negate (first wffs) subst)) + +(defun make-implication* (wffs &optional subst) + (cl:assert (eql 2 (length wffs))) + (make-implication (first wffs) (second wffs) subst)) + +(defun make-reverse-implication* (wffs &optional subst) + (cl:assert (eql 2 (length wffs))) + (make-reverse-implication (first wffs) (second wffs) subst)) + +(defun make-conditional* (wffs &optional subst) + (cl:assert (eql 3 (length wffs))) + (make-conditional (first wffs) (second wffs) (third wffs) subst)) + +(defun make-conditional-answer* (wffs &optional subst) + (cl:assert (eql 3 (length wffs))) + (make-conditional-answer (first wffs) (second wffs) (third wffs) subst)) + +(defun negate (wff &optional subst) + (dereference + wff subst + :if-constant (cond + ((eq true wff) + false) + ((eq false wff) + true) + ((eliminate-negations?) + (proposition-complementer wff)) + (t + (make-compound *not* wff))) + :if-variable (not-wff-error wff) + :if-compound-cons (not-wff-error wff) + :if-compound-appl (let ((head (heada wff))) + (ecase (function-logical-symbol-p head) + ((nil) ;atomic + (cond + ((eliminate-negations?) + (make-compound* (relation-complementer head) (argsa wff))) + (t + (make-compound *not* wff)))) + (not + (arg1a wff)) + (and + (disjoin* (mapcar (lambda (arg) + (negate arg subst)) + (argsa wff)) + subst)) + (or + (conjoin* (mapcar (lambda (arg) + (negate arg subst)) + (argsa wff)) + subst)) + ((implies implied-by iff xor) + (make-compound *not* wff)) + (if + (let ((args (argsa wff))) + (make-compound head + (first args) + (negate (second args) subst) + (negate (third args) subst)))))))) + +(defun relation-complementer (fn) + ;; if complement has special properties + ;; such as associativity, rewrites, etc., + ;; these must be declared explicitly by the user + (or (function-complement fn) + (setf (function-complement fn) + (declare-relation (complement-name (function-name fn)) (function-arity fn))))) + +(defun proposition-complementer (const) + (or (constant-complement const) + (setf (constant-complement const) + (declare-proposition (complement-name (constant-name const)))))) + +(defun complement-name (nm &optional noninterned) + (let* ((s (symbol-name nm)) + (~s (if (eql #\~ (char s 0)) + (subseq s 1) + (to-string "~" s)))) + (if noninterned + (make-symbol ~s) + (intern ~s (symbol-package nm))))) + +(defun make-implication (wff1 wff2 &optional subst) + (cond + ((eq true wff1) + wff2) + ((eq true wff2) + wff2) + ((eq false wff1) + true) + ((eq false wff2) + (negate wff1 subst)) + ((equal-p wff1 wff2 subst) + true) + ((complement-p wff1 wff2 subst) + wff2) + ((and (compound-p wff2) (eq *implies* (head wff2))) + (let ((args2 (argsa wff2))) + (make-implication (conjoin wff1 (first args2) subst) (second args2) subst))) + ((eliminate-negations?) + (disjoin (negate wff1 subst) wff2 subst)) + (t + (make-compound *implies* wff1 wff2)))) + +(defun make-reverse-implication (wff2 wff1 &optional subst) + (cond + ((eq true wff1) + wff2) + ((eq true wff2) + wff2) + ((eq false wff1) + true) + ((eq false wff2) + (negate wff1 subst)) + ((equal-p wff1 wff2 subst) + true) + ((complement-p wff1 wff2 subst) + wff2) + ((and (compound-p wff2) (eq *implied-by* (head wff2))) + (let ((args2 (argsa wff2))) + (make-reverse-implication (first args2) (conjoin (second args2) wff1 subst) subst))) + ((eliminate-negations?) + (disjoin wff2 (negate wff1 subst) subst)) + (t + (make-compound *implied-by* wff2 wff1)))) + +(defun make-conditional (wff1 wff2 wff3 &optional subst) + (cond + ((eq true wff1) + wff2) + ((eq false wff1) + wff3) + ((negation-p wff1) + (make-conditional (arg1 wff1) wff3 wff2 subst)) + (t +;; (setf wff2 (substitute true wff1 wff2 subst)) +;; (setf wff3 (substitute false wff1 wff3 subst)) + (setf wff2 (prog-> + (map-atoms-in-wff-and-compose-result wff2 ->* atom polarity) + (declare (ignore polarity)) + (if (equal-p wff1 atom subst) true atom))) + (setf wff3 (prog-> + (map-atoms-in-wff-and-compose-result wff3 ->* atom polarity) + (declare (ignore polarity)) + (if (equal-p wff1 atom subst) false atom))) + (cond + ((eq true wff2) + (disjoin wff1 wff3 subst)) + ((eq false wff2) + (conjoin (negate wff1 subst) wff3 subst)) + ((eq true wff3) + (disjoin (negate wff1 subst) wff2 subst)) + ((eq false wff3) + (conjoin wff1 wff2 subst)) + ((equal-p wff2 wff3 subst) + wff2) + ((eliminate-negations?) + (disjoin + (conjoin wff1 wff2 subst) + (conjoin (negate wff1 subst) wff3 subst) + subst)) + (t + (make-compound *if* wff1 wff2 wff3)))))) + +(defun make-conditional-answer (wff1 wff2 wff3 &optional subst) + (cond + ((eq true wff1) + wff2) + ((eq false wff1) + wff3) + ((negation-p wff1) + (make-conditional-answer (arg1 wff1) wff3 wff2 subst)) + ((equal-p wff2 wff3 subst) + wff2) + (t + (make-compound *answer-if* wff1 wff2 wff3)))) + +(defun make-equality0 (term1 term2 &optional (relation *=*)) + (make-compound relation term1 term2)) + +(defun make-equality (term1 term2 &optional subst (relation *=*)) + (cond + ((equal-p term1 term2 subst) + true) + (t + (make-compound relation term1 term2)))) + +(defun complement-p (wff1 wff2 &optional subst) + (let ((appl nil) (neg nil)) + (loop + (dereference + wff1 nil + :if-constant (return) + :if-variable (not-wff-error wff1) + :if-compound-cons (not-wff-error wff1) + :if-compound-appl (if (eq *not* (heada wff1)) + (setf neg (not neg) wff1 (arg1a wff1)) + (return (setf appl t))))) + (loop + (dereference + wff2 nil + :if-constant (return (and neg (eql wff1 wff2))) + :if-variable (not-wff-error wff2) + :if-compound-cons (not-wff-error wff2) + :if-compound-appl (if (eq *not* (heada wff2)) + (setf neg (not neg) wff2 (arg1a wff2)) + (return (and appl neg (equal-p wff1 wff2 subst)))))))) + +(defun equal-or-complement-p (wff1 wff2 &optional subst) + (let ((appl nil) (neg nil)) + (loop + (dereference + wff1 nil + :if-constant (return) + :if-variable (not-wff-error wff1) + :if-compound-cons (not-wff-error wff1) + :if-compound-appl (if (eq *not* (heada wff1)) + (setf neg (not neg) wff1 (arg1a wff1)) + (return (setf appl t))))) + (loop + (dereference + wff2 nil + :if-constant (return (and (eql wff1 wff2) (if neg :complement :equal))) + :if-variable (not-wff-error wff2) + :if-compound-cons (not-wff-error wff2) + :if-compound-appl (if (eq *not* (heada wff2)) + (setf neg (not neg) wff2 (arg1a wff2)) + (return (and appl (equal-p wff1 wff2 subst) (if neg :complement :equal)))))))) + +;;; connectives.lisp EOF diff --git a/src/constants.lisp b/src/constants.lisp new file mode 100644 index 0000000..6205a91 --- /dev/null +++ b/src/constants.lisp @@ -0,0 +1,305 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: constants.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; Lisp symbols, strings, numbers, and characters are used directly as SNARK constants +;;; but SNARK needs to associate information with them +;;; it is stored in constant-info structures found in *constant-info-table* hash-array +;;; or *number-info-table* or *string-info-table* in the case of numbers and strings +;;; that only require sort information be stored + +(defstruct constant-info + (hash-code0 (make-atom-hash-code) :read-only t) + (boolean-valued-p0 nil) ;overloaded to be input name of the proposition + (constructor0 nil) + (magic t) ;nil means don't make magic-set goal for this proposition + (allowed-in-answer0 t) + (kbo-weight0 1) + (weight0 1) + (sort0 (top-sort)) + (plist nil)) ;property list for more properties + +(definline constant-number (const) + (funcall *standard-eql-numbering* :lookup const)) + +(defvar *constant-info-table*) + +(defmacro constant-info0 (const) + `(gethash ,const *constant-info-table*)) + +(definline constant-info (const &optional (action 'error)) + (or (constant-info0 const) + (init-constant-info const action))) + +(defun init-constant-info (const action) + (when action + (can-be-constant-name const action)) + (constant-number const) ;initialize it at first occurrence + (let ((info (make-constant-info))) + (setf (constant-info0 const) info))) + +(defmacro define-constant-slot-accessor (name &key read-only) + (let ((constant-slot (intern (to-string :constant- name) :snark)) + (constant-info-slot (intern (to-string :constant-info- name) :snark))) + `(progn + (#-(or allegro lispworks) definline #+(or allegro lispworks) defun ,constant-slot (const) + (,constant-info-slot (constant-info const))) + ,@(unless read-only + (list + `(defun (setf ,constant-slot) (value const) + (setf (,constant-info-slot (constant-info const)) value))))))) + +(define-constant-slot-accessor hash-code0 :read-only t) +(define-constant-slot-accessor boolean-valued-p0) +(define-constant-slot-accessor constructor0) +(define-constant-slot-accessor magic) +(define-constant-slot-accessor allowed-in-answer0) +(define-constant-slot-accessor kbo-weight0) +(define-constant-slot-accessor weight0) +(define-constant-slot-accessor sort0) +(define-constant-slot-accessor plist) + +(define-plist-slot-accessor constant :locked0) +(define-plist-slot-accessor constant :documentation) +(define-plist-slot-accessor constant :author) +(define-plist-slot-accessor constant :source) +(define-plist-slot-accessor constant :complement) ;complement of the symbol P is the symbol ~P +(define-plist-slot-accessor constant :skolem-p) +(define-plist-slot-accessor constant :created-p) +(define-plist-slot-accessor constant :do-not-resolve) + +(defvar *number-info-table*) ;number -> (sort) +(defvar *string-info-table*) ;string -> (sort canonical-string) + +(defstruct (number-info + (:type list) + (:copier nil)) + sort) + +(defstruct (string-info + (:type list) + (:copier nil)) + sort + (canonical nil :read-only t)) + +(defmacro number-info (number) + `(gethash ,number *number-info-table*)) + +(defmacro string-info (string) + `(gethash ,string *string-info-table*)) + +(defun number-canonical (x) + (cl:assert (numberp x)) + (cond + ((floatp x) + (rationalize x)) + ((and (complexp x) (float (realpart x))) + (complex (rationalize (realpart x)) (rationalize (imagpart x)))) + (t + x))) + +(defun declare-number (x) + (setf x (number-canonical x)) + (or (number-info x) + (progn + (constant-number x) ;initialize it at first occurrence + (setf (number-info x) (make-number-info :sort (the-sort (number-sort-name x)))))) + x) + +(defun declare-string (x) + (cl:assert (stringp x)) + ;; canonicalize strings so that (implies (string= str1 str2) (eq (declare-string str1) (declare-string str2))) + (string-info-canonical + (or (string-info x) + (progn + (constant-number x) ;initialize it at first occurrence + (setf (string-info x) (make-string-info :sort (the-sort (declare-string-sort?)) :canonical x)))))) + +(definline builtin-constant-p (x) + (or (numberp x) (stringp x))) + +(definline constant-builtin-p (const) + ;; equivalent to but faster than builtin-constant-p for known constants (can-be-constant-name is true) + (not (symbolp const))) + +(defun constant-hash-code (const) + (if (constant-builtin-p const) (+ 2 (mod (constant-number const) 1022)) (constant-hash-code0 const))) + +(definline constant-boolean-valued-p (const) + (if (constant-builtin-p const) nil (constant-boolean-valued-p0 const))) + +(definline constant-constructor (const) + (if (constant-builtin-p const) t (constant-constructor0 const))) + +(definline constant-allowed-in-answer (const) + (if (constant-builtin-p const) t (constant-allowed-in-answer0 const))) + +(definline constant-kbo-weight (const) + (if (constant-builtin-p const) + (let ((v (kbo-builtin-constant-weight?))) + (if (numberp v) v (funcall v const))) + (constant-kbo-weight0 const))) + +(definline constant-weight (const) + (if (constant-builtin-p const) + (let ((v (builtin-constant-weight?))) + (if (numberp v) v (funcall v const))) + (constant-weight0 const))) + +(defun constant-sort (const) + (cond + ((numberp const) + (number-info-sort (number-info const))) + ((stringp const) + (string-info-sort (string-info const))) + (t + (constant-sort0 const)))) + +(defun (setf constant-sort) (value const) + (cond + ((numberp const) + (setf (number-info-sort (number-info const)) value)) + ((stringp const) + (setf (string-info-sort (string-info const)) value)) + (t + (setf (constant-sort0 const) value)))) + +(definline constant-locked (const) + (if (constant-builtin-p const) t (constant-locked0 const))) + +(definline constant-name (const) + (or (constant-boolean-valued-p const) const)) + +(defun constant-name-lessp (x y) + (cond + ((complexp x) + (if (complexp y) (or (< (realpart x) (realpart y)) (and (= (realpart x) (realpart y)) (< (imagpart x) (imagpart y)))) t)) + ((complexp y) + nil) + ((realp x) + (if (realp y) (< x y) t)) + ((realp y) + nil) + ((stringp x) + (if (stringp y) (string< x y) t)) + ((stringp y) + nil) + (t + (string< x y)))) + +(defun initialize-constants () + (setf *constant-info-table* (make-hash-table)) + (setf *number-info-table* (make-hash-table)) + (setf *string-info-table* (make-hash-table :test #'equal)) + nil) + +(defmacro set-slot-if-supplied (type slot) + (let ((slot-supplied (intern (to-string slot :-supplied) :snark)) + (type-slot (intern (to-string type "-" slot) :snark))) + `(when ,slot-supplied + (setf (,type-slot symbol) ,slot)))) + +(defun declare-constant-symbol0 (symbol + &key + alias + ((:sort sort0) nil) + ((:locked locked0) nil) + (documentation nil documentation-supplied) + (author nil author-supplied) + (source nil source-supplied) + (complement nil complement-supplied) + (magic t magic-supplied) + (skolem-p nil skolem-p-supplied) + (created-p nil created-p-supplied) + ((:constructor constructor0) nil constructor0-supplied) + ((:allowed-in-answer allowed-in-answer0) nil allowed-in-answer0-supplied) + ((:kbo-weight kbo-weight0) nil kbo-weight0-supplied) + ((:weight weight0) nil weight0-supplied) + (do-not-resolve nil do-not-resolve-supplied) + ) + ;; doesn't do anything if no keywords are supplied + (when constructor0-supplied + (cl:assert (implies (constant-builtin-p symbol) constructor0) () "Builtin constant ~S cannot be a nonconstructor." symbol)) + (when alias + (create-aliases-for-symbol symbol alias)) + (when sort0 + (declare-constant-sort symbol sort0)) + (when locked0 + (setf (constant-locked0 symbol) locked0)) ;stays locked + (set-slot-if-supplied constant documentation) + (set-slot-if-supplied constant author) + (set-slot-if-supplied constant source) + (set-slot-if-supplied constant complement) + (set-slot-if-supplied constant magic) + (set-slot-if-supplied constant skolem-p) + (set-slot-if-supplied constant created-p) + (set-slot-if-supplied constant constructor0) + (set-slot-if-supplied constant allowed-in-answer0) + (set-slot-if-supplied constant kbo-weight0) + (set-slot-if-supplied constant weight0) + (set-slot-if-supplied constant do-not-resolve) + symbol) + +(defun changeable-keys-and-values0 (keys-and-values changeable) + (let ((keys-and-values1 nil) keys-and-values1-last + (keys-and-values2 nil) keys-and-values2-last) + (loop + (cond + ((endp keys-and-values) + (return (values keys-and-values1 keys-and-values2))) + ((member (first keys-and-values) changeable) + (collect (pop keys-and-values) keys-and-values1) + (collect (pop keys-and-values) keys-and-values1)) + (t + (collect (pop keys-and-values) keys-and-values2) + (collect (pop keys-and-values) keys-and-values2)))))) + +(defun changeable-keys-and-values (symbol keys-and-values changeable) + (let (keys-and-values2) + (setf (values keys-and-values keys-and-values2) (changeable-keys-and-values0 keys-and-values changeable)) + (when keys-and-values2 + (warn "Ignoring declaration of locked symbol ~S with arguments~{ ~S~}." symbol keys-and-values2)) + keys-and-values)) + +(defun declare-constant-symbol1 (symbol keys-and-values) + (cond + ((null keys-and-values) + symbol) + (t + (apply 'declare-constant-symbol0 + symbol + (cond + ((and (constant-locked symbol) (eq none (getf keys-and-values :locked none))) + (changeable-keys-and-values + symbol + keys-and-values + (if (constant-builtin-p symbol) '(:alias :sort) (changeable-properties-of-locked-constant?)))) + (t + keys-and-values)))))) + +(defun declare-constant (name &rest keys-and-values) + (declare (dynamic-extent keys-and-values)) + (declare-constant-symbol1 (input-constant-symbol name) keys-and-values)) + +(defun declare-proposition (name &rest keys-and-values) + (declare (dynamic-extent keys-and-values)) + (declare-constant-symbol1 (input-proposition-symbol name) keys-and-values)) + +;;; constants.lisp EOF diff --git a/src/constraint-purify.lisp b/src/constraint-purify.lisp new file mode 100644 index 0000000..18f311b --- /dev/null +++ b/src/constraint-purify.lisp @@ -0,0 +1,151 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: constraint-purify.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun constraint-purify-wff (wff) + (let ((ucp (use-constraint-purification?))) + ;; if ucp = 1, add equality constraints to wff instead of constraint-alist + ;; if ucp = 2, add all constraints to wff instead of constraint-alist + (let ((vars (nontheory-variables wff)) + (constraint-alist-additions nil) + (cache nil)) + (labels + ((constraint-purify-atom (atom polarity) + (dereference + atom nil + :if-constant atom + :if-variable (not-wff-error atom) + :if-compound-cons (not-wff-error atom) + :if-compound-appl (let* ((head (heada atom)) + (args (argsa atom)) + (theory2 (function-constraint-theory head)) + (args* (constraint-purify-terms args theory2)) + (atom* (if (eq args args*) atom (make-compound* head args*)))) + (if (null theory2) + atom* + (ecase polarity + (:pos (add-constraint atom* theory2) false) + (:neg (add-constraint (negate atom*) theory2) true)))))) + + (constraint-purify-term (term theory1) + (let ((theory2 nil) (dont-abstract nil)) + (dereference + term nil + :if-variable (setf dont-abstract (not (member term vars))) + :if-constant (setf dont-abstract (constant-constructor term)) + :if-compound (let* ((head (head term)) + (args (args term)) + (args* (constraint-purify-terms + args + (if (setf dont-abstract (function-constructor head)) + theory1 ;constructor symbols are transparent wrt theory + (setf theory2 (function-constraint-theory head)))))) + (unless (eq args args*) + (setf term (make-compound* head args*))))) + (cond + ((or dont-abstract (eq theory1 theory2)) + term) + (theory1 + (variable-for term (or theory2 'equality))) + (t + (variable-for (variable-for term (or theory2 'equality)) 'equality))))) + + (constraint-purify-terms (terms theory) + (lcons (constraint-purify-term (first terms) theory) + (constraint-purify-terms (rest terms) theory) + terms)) + + (add-constraint (lit theory) + (setf constraint-alist-additions (disjoin-alist1 theory lit constraint-alist-additions))) + + (variable-for (term theory) + ;; create a variable to use in place of term and store ($$eq var term) in theory constraint + (or (cdr (assoc term cache :test #'equal-p)) + (let ((eq (input-relation-symbol (intern (to-string :$$eq_ theory) :snark) 2)) + (var (make-variable (term-sort term)))) + (add-constraint (make-compound *not* (make-compound eq var term)) theory) + (setf cache (acons term var cache)) + var)))) + + (let ((wff* (map-atoms-in-wff-and-compose-result #'constraint-purify-atom wff))) + (if constraint-alist-additions + (values + (disjoin* (cons wff* (mapcan #'(lambda (p) (if (or (eql 2 ucp) (and (eql 1 ucp) (eq 'equality (car p)))) (list (cdr p)) nil)) constraint-alist-additions))) + (mapcan #'(lambda (p) (if (or (eql 2 ucp) (and (eql 1 ucp) (eq 'equality (car p)))) nil (list p))) constraint-alist-additions)) + wff)))))) + +(defun constraint-purified-p (x &optional subst) + (let ((variable-theory-alist nil)) + (labels + ((cpp (x theory1) + (dereference + x subst + :if-variable (let ((p (assoc x variable-theory-alist))) + (cond + ((null p) + (unless (eq none theory1) + (setf variable-theory-alist (acons x theory1 variable-theory-alist))) + t) + (t + (or (eq none theory1) (eq theory1 (cdr p)))))) + :if-constant (or (eq none theory1) (null theory1) (constant-constructor x)) + :if-compound (let* ((head (head x)) + (theory2 (cond + ((function-logical-symbol-p head) + none) + ((function-constructor head) + theory1) ;constructor symbols are transparent wrt theory + ((eq 'equality (function-constraint-theory head)) + none) + (t + (function-constraint-theory head))))) + (and (or (eq none theory1) (eq theory1 theory2)) + (dolist (arg (args x) t) + (unless (cpp arg theory2) + (return nil)))))))) + (cpp x none)))) + +(defun constraint-purified-row-p (row) + ;; ignore answer and ordering-constraint + (constraint-purified-p (cons (row-wff row) (remove-if #'(lambda (x) (eq (car x) 'ordering)) (row-constraints row))))) + +(defun variable-occurs-purely-p (var x &optional subst atom) + (let ((theory none)) + (labels + ((vop (x th) + (dereference + x subst + :if-variable (when (eq var x) + (unless (eq theory th) + (if (eq none theory) + (setf theory th) + (return-from variable-occurs-purely-p nil)))) + :if-compound-cons (progn (vop (carc x) th) (vop (cdrc x) th)) + :if-compound-appl (unless (eq atom x) ;ignore atom being resolved away + (let ((th (if (function-constructor (heada x)) th (function-constraint-theory (heada x))))) + (dolist (arg (args x)) + (vop arg th))))))) + (vop x nil)) + t)) + +(defun variable-occurs-purely-in-row-p (var row &optional atom) + (variable-occurs-purely-p var (list* (row-wff row) (row-answer row) (remove-if #'(lambda (x) (eq (car x) 'ordering)) (row-constraints row))) nil atom)) + +;;; constraint-purify.lisp EOF diff --git a/src/constraints.lisp b/src/constraints.lisp new file mode 100644 index 0000000..aaedf83 --- /dev/null +++ b/src/constraints.lisp @@ -0,0 +1,335 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: constraints.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim (special *processing-row*)) + +(defgeneric checkpoint-theory (theory) + ;; create checkpoint + (:method (theory) + (error "No checkpoint method for theory ~S." theory))) + +(defgeneric uncheckpoint-theory (theory) + ;; eliminate checkpoint, keeping changes since then + (:method (theory) + (error "No uncheckpoint method for theory ~S." theory))) + +(defgeneric restore-theory (theory) + ;; undo changes since checkpoint, keeping checkpoint + (:method (theory) + (error "No restore method for theory ~S." theory))) + +(defgeneric theory-closure (theory) + ;; returns non-NIL value if theory is inconsistent + (:method (theory) + (error "No closure method for theory ~S." theory))) + +(defgeneric theory-assert (atom theory) + (:method (atom theory) + (declare (ignorable atom)) + (error "No assert method for theory ~S." theory))) + +(defgeneric theory-deny (atom theory) + (:method (atom theory) + (declare (ignorable atom)) + (error "No deny method for theory ~S." theory))) + +(defgeneric theory-simplify (wff theory) + ;; wff is disjunction of literals + (:method (wff theory) + (let ((row *processing-row*)) + (cond + ((or (eq true wff) (eq false wff)) + wff) + ((and row + (eq false (row-wff row)) + (not (row-nonassertion-p row)) + (eq theory (row-unit-constraint row)) + (ground-p wff)) + (mvlet (((values atom polarity) (literal-p wff))) + (if (eq :pos polarity) + (theory-assert2 atom theory) + (theory-deny2 atom theory))) + false) + (t + (checkpoint-theory theory) + (let ((wff* (prog-> + (map-atoms-in-wff-and-compose-result wff ->* atom polarity) + (cond + ((if (eq :pos polarity) + (theory-falsep atom theory) + (theory-truep atom theory)) +;; (when row +;; (pushnew theory (row-rewrites-used row))) + (if (eq :pos polarity) false true)) + ((progn + (if (eq :pos polarity) + (theory-deny atom theory) + (theory-assert atom theory)) + (theory-closure theory)) + (restore-theory theory) + (uncheckpoint-theory theory) + (return-from theory-simplify false)) + (t + atom))))) + (restore-theory theory) + (uncheckpoint-theory theory) + wff*))))) + (:method (wff (theory (eql 'assumption))) + (let ((row-wff (row-wff *processing-row*))) + (cond + ((and (clause-p row-wff) (clause-p wff nil nil t)) + (prog-> + (map-atoms-in-wff-and-compose-result wff ->* atom polarity) + (or (prog-> + (map-atoms-in-wff row-wff ->* atom2 polarity2) + (when (and (eq polarity polarity2) (equal-p atom atom2)) + (return-from prog-> (if (eq :pos polarity) true false)))) + atom))) + (t + wff))))) + +(defgeneric theory-rewrite (wff theory) + (:method (wff theory) + (declare (ignorable theory)) + (rewriter wff nil)) + (:method (wff (theory (eql 'assumption))) + wff)) + +(defun theory-assert2 (atom theory) + (checkpoint-theory theory) + (theory-assert atom theory) + (when (theory-closure theory) ;inconsistent? + (cerror "Continue without asserting it." + "Asserting ~A leads to a contradiction." + atom) + (restore-theory theory)) + (uncheckpoint-theory theory)) + +(defun theory-deny2 (atom theory) + (checkpoint-theory theory) + (theory-deny atom theory) + (when (theory-closure theory) ;inconsistent? + (cerror "Continue without denying it." + "Denying ~A leads to a contradiction." + atom) + (restore-theory theory)) + (uncheckpoint-theory theory)) + +(defun theory-truep (atom theory) + (let (inconsistent) + (checkpoint-theory theory) + (theory-deny atom theory) + (setf inconsistent (theory-closure theory)) + (restore-theory theory) + (uncheckpoint-theory theory) + inconsistent)) + +(defun theory-falsep (atom theory) + (let (inconsistent) + (checkpoint-theory theory) + (theory-assert atom theory) + (setf inconsistent (theory-closure theory)) + (restore-theory theory) + (uncheckpoint-theory theory) + inconsistent)) + +(defun simplify-constraint-alist (alist) + (and alist + (let* ((x (first alist)) + (x* (lcons (car x) (theory-simplify (cdr x) (car x)) x))) + (cond + ((eq false (cdr x*)) + (simplify-constraint-alist (rest alist))) + (t + (lcons x* (simplify-constraint-alist (rest alist)) alist)))))) + +(defun rewrite-constraint-alist (alist) + (and alist + (let* ((x (first alist)) + (x* (lcons (car x) (theory-rewrite (cdr x) (car x)) x))) + (cond + ((eq false (cdr x*)) + (rewrite-constraint-alist (rest alist))) + (t + (lcons x* (rewrite-constraint-alist (rest alist)) alist)))))) + +(defun assumptive-constraint-theory-p (theory) + ;; assumptive constraint theories can simply be assumed + ;; they don't require row coverage + (eq 'assumption theory)) + +(defun row-constrained-p (row) + (dolist (x (row-constraints row) nil) + (unless (eq false (cdr x)) + (return t)))) + +(defun row-constrained-p2 (row) + (dolist (x (row-constraints row) nil) + (unless (or (eq false (cdr x)) + (assumptive-constraint-theory-p (car x))) + (return t)))) + +(defun row-unit-constraint (row) + (let ((v nil)) + (dolist (x (row-constraints row)) + (cond + ((eq false (cdr x)) + ) + (v + (setf v nil) + (return)) + ((assumptive-constraint-theory-p (car x)) + (return)) + (t + (setf v x)))) + (when v + (mvlet* (((list* theory wff) v) + ((values atom polarity) (literal-p wff))) + (when atom + (values theory atom polarity)))))) + +(defun row-constraint-coverage (rows) + ;; returns t if row-constraint coverage is complete + ;; by doing matings search over constraint wffs + ;; but with NO INSTANTIATION + ;; cf. Bjorner, Stickel, Uribe CADE-14 paper + (let ((theories nil) (new-rows nil) new-rows-last) + (dolist (row rows) + (dolist (x (row-constraints row)) + (mvlet (((list* theory wff) x)) + (cl:assert (neq false wff)) + (unless (or (eq true wff) + (member theory theories) + (assumptive-constraint-theory-p theory) + (theory-closure theory)) + (checkpoint-theory theory) + (push theory theories))))) + (dolist (row rows) + (mvlet (((values theory atom polarity) (row-unit-constraint row))) + (cond + ((and theory (member theory theories)) + (if (eq :pos polarity) + (theory-assert atom theory) + (theory-deny atom theory))) + (t + (collect row new-rows))))) + (prog1 + (dolist (theory theories t) + (unless (theory-closure theory) + (return (row-constraint-coverage* new-rows theories)))) + (dolist (theory theories) + (restore-theory theory) + (uncheckpoint-theory theory))))) + +(defun row-constraint-coverage* (rows theories) + (and rows + (dolist (x (row-constraints (first rows)) t) ;return t if all paths closed + (mvlet (((list* theory wff) x)) ;constraint wff is conjunction of literals + (unless (or (eq true wff) + (not (member theory theories)) + (theory-closure theory)) + (prog-> + (map-atoms-in-wff wff ->* atom polarity) + (cond + ((prog2 + (checkpoint-theory theory) + (progn + (if (eq :pos polarity) ;trial value + (theory-assert atom theory) + (theory-deny atom theory)) + (or (theory-closure theory) ;inconsistent now? + (row-constraint-coverage* (rest rows) theories))) ;all paths closed? + (restore-theory theory) + (uncheckpoint-theory theory)) + #+ignore + (if (eq :pos polarity) ;assert negation and continue + (theory-deny atom theory) + (theory-assert atom theory))) + (t + (return-from row-constraint-coverage* nil))))))))) ;return nil if unclosed path + +(defmethod checkpoint-theory ((theory (eql 'equality))) + nil) + +(defmethod uncheckpoint-theory ((theory (eql 'equality))) + nil) + +(defmethod restore-theory ((theory (eql 'equality))) + nil) + +(defmethod theory-closure ((theory (eql 'equality))) + nil) + +(defmethod theory-assert (atom (theory (eql 'equality))) + (declare (ignorable atom)) + nil) + +(defmethod theory-deny (atom (theory (eql 'equality))) + (declare (ignorable atom)) + nil) + +(defmethod theory-simplify (wff (theory (eql 'equality))) + wff) + +(defmethod checkpoint-theory ((theory (eql 'test))) + nil) + +(defmethod uncheckpoint-theory ((theory (eql 'test))) + nil) + +(defmethod restore-theory ((theory (eql 'test))) + nil) + +(defmethod theory-closure ((theory (eql 'test))) + nil) + +(defmethod theory-assert (atom (theory (eql 'test))) + (declare (ignorable atom)) + nil) + +(defmethod theory-deny (atom (theory (eql 'test))) + (declare (ignorable atom)) + nil) + +(defmethod theory-simplify (wff (theory (eql 'test))) + wff) + +(defun assumption-test1 () + ;; answer 1 with assumption (b 1) + ;; answer 2 with assumption (a 2) + ;; answer ?x with assumption (and (a ?x) (b ?x)) + (initialize) + (use-resolution) + (use-subsumption-by-false) + (assert '(a 1)) + (assert '(b 2)) + (assert '(a ?x) :constraints '((assumption (a ?x)))) + (assert '(b ?x) :constraints '((assumption (b ?x)))) + (prove '(and (a ?x) (b ?x)) :answer '(values ?x))) + +(defun assumption-test2 () + (initialize) + (use-resolution) + (assert '(implies (bird ?x) (flies ?x)) :constraints '((assumption (normal-wrt-flies ?x)))) + (assert '(bird tweety)) + (prove '(flies tweety))) + +;;; constraints.lisp EOF diff --git a/src/counters.lisp b/src/counters.lisp new file mode 100644 index 0000000..85dad20 --- /dev/null +++ b/src/counters.lisp @@ -0,0 +1,90 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*- +;;; File: counters.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-lisp) + +(defstruct (counter + (:constructor make-counter (&optional (increments 0))) + (:copier nil)) + (increments 0 :type integer) + (decrements 0 :type integer) + (previous-peak-value 0 :type integer)) + +(defun increment-counter (counter &optional (n 1)) + (declare (type integer n)) +;;(cl:assert (<= 0 n)) + (incf (counter-increments counter) n) + nil) + +(defun decrement-counter (counter &optional (n 1)) + (declare (type integer n)) +;;(cl:assert (<= 0 n)) + (let* ((d (counter-decrements counter)) + (v (- (counter-increments counter) d))) + (when (> v (counter-previous-peak-value counter)) + (setf (counter-previous-peak-value counter) v)) + (setf (counter-decrements counter) (+ d n)) + nil)) + +(defun counter-value (counter) + (- (counter-increments counter) (counter-decrements counter))) + +(defun counter-values (counter) + ;; returns 4 values: current value, peak value, #increments, #decrements + (let* ((i (counter-increments counter)) + (d (counter-decrements counter)) + (v (- i d))) + (values v (max v (counter-previous-peak-value counter)) i d))) + +(definline show-count-p (n) + (dolist (v '(1000000 100000 10000 1000 100 10) t) + (when (>= n v) + (return (eql 0 (rem n v)))))) + +(defun show-count (n) + (princ #\Space) + (let (q r) + (cond + ((eql 0 n) + (princ 0)) + ((progn (setf (values q r) (truncate n 1000000)) (eql 0 r)) + (princ q) (princ #\M)) + ((progn (setf (values q r) (truncate n 1000)) (eql 0 r)) + (princ q) (princ #\K)) + (t + (princ n)))) + (princ #\Space) + (force-output) + n) + +(defun show-count0 (n) + (if (and (neql 0 n) (show-count-p n)) n (show-count n))) + +(defun show-count1 (n) + (if (show-count-p n) (show-count n) n)) + +(defmacro princf (place &optional (delta 1)) + ;; increment counter and maybe print it + ;; if delta is 0, print the counter unless the previous increment did + (cl:assert (member delta '(0 1))) + (if (eql 0 delta) + `(show-count0 ,place) + `(show-count1 (incf ,place)))) + +;;; counters.lisp EOF diff --git a/src/date-reasoning2.lisp b/src/date-reasoning2.lisp new file mode 100644 index 0000000..688773e --- /dev/null +++ b/src/date-reasoning2.lisp @@ -0,0 +1,347 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: date-reasoning2.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; $$date-point and $$date-interval are external (solely for user convenience) function symbols +;;; for date points and intervals; they are replaced by $$utime-point and $$utime-interval when +;;; formulas are input +;;; +;;; $$utime-point and $$utime-interval are internal function symbols for dates +;;; they use Lisp universal time representation (which counts seconds since 1900-01-01T00:00:00) +;;; +;;; $$date-point and $$date-interval use 1 to 6 integer arguments +;;; year, month, day, hour, minute, second +;;; to specify dates +;;; +;;; examples of SNARK dates and their translations: +;;; ($$date-point 2002 4 1 16 27 20) -> ($$utime-point 3226667240) +;;; ($$date-interval 2002 4 1 16 34) -> ($$utime-interval 3226667640 3226667700) +;;; ($$date-interval 2002 4 1 16 34 :until 2002 4 1 16 35) -> ($$utime-interval 3226667640 3226667700) +;;; ($$date-interval 2002 4 1 16 34 :until 2002 4 1 17) -> ($$utime-interval 3226667640 3226669200) +;;; +;;; 20071215: avoid use of $$date-interval (and $$utime-interval) +;;; reasoning is more complete and effective if just $$date-point (and $$utime-point) are used + +(defvar *date-point*) +(defvar *utime-point*) +(defvar *date-interval*) +(defvar *utime-interval*) + +(defun declare-code-for-dates () + ;; declare symbols without some properties here + ;; defer full definition until declare-time-relations is called + (setf *date-point* (declare-function1 '$$date-point :any :macro t :input-code 'input-date-point)) + (setf *utime-point* (declare-function + '$$utime-point 1 + :constructor t +;; :index-type :hash-but-dont-index + :to-lisp-code 'utime-point-term-to-lisp)) + (setf *date-interval* (declare-function1 '$$date-interval :any :macro t :input-code 'input-date-interval)) + (setf *utime-interval* (declare-function + '$$utime-interval 2 + :constructor t +;; :index-type :hash-but-dont-index + :to-lisp-code 'utime-interval-term-to-lisp)) + nil) + +(defun can-be-date-p (list &optional action) + ;; a proper date is a list of 1 to 6 integers with appropriate values + ;; interpreted as year, month, day, hour, minute, and second + (or (let* ((list list) + (year (pop list))) + (and (integerp year) + (<= 1900 year) + (implies + list + (let ((month (pop list))) + (and (integerp month) + (<= 1 month 12) + (implies + list + (let ((day (pop list))) + (and (integerp day) + (<= 1 day (days-per-month month year)) + (implies + list + (let ((hour (pop list))) + (and (integerp hour) + (<= 0 hour 23) + (implies + list + (let ((minute (pop list))) + (and (integerp minute) + (<= 0 minute 59) + (implies + list + (let ((second (pop list))) + (and (integerp second) + (<= 0 second 59) ;no leap seconds! + (null list)))))))))))))))))) + (and action (funcall action "~A cannot be a date." list)))) + +(defun encode-universal-time-point (year &optional month day hour minute second) + (can-be-date-p (list year (or month 1) (or day 1) (or hour 0) (or minute 0) (or second 0)) 'error) + (encode-universal-time + (or second 0) + (or minute 0) + (or hour 0) + (or day 1) + (or month 1) + year + 0)) + +(defun decode-universal-time-point (universal-time-point) + (mvlet (((values second minute hour day month year) + (decode-universal-time universal-time-point 0))) + (cond + ((/= 0 second) + (list year month day hour minute second)) + ((/= 0 minute) + (list year month day hour minute)) + ((/= 0 hour) + (list year month day hour)) + ((/= 1 day) + (list year month day)) + ((/= 1 month) + (list year month)) + (t + (list year))))) + +(defun encode-universal-time-interval (year &optional month day hour minute second) + (let ((v (encode-universal-time-point year month day hour minute second))) + (list v + (+ v (or (and second 1) ;1 second long interval + (and minute 60) ;1 minute long interval + (and hour 3600) ;1 hour long interval + (and day 86400) ;1 day long interval + (and month (* (days-per-month month year) 86400)) ;1 month long interval + (* (if (leap-year-p year) 366 365) 86400)))))) ;1 year long interval + +(defun decode-universal-time-interval (universal-time-interval) + (mvlet (((list start finish) universal-time-interval)) + (values (decode-universal-time-point start) (decode-universal-time-point finish)))) + +(defun pp-compare-universal-times (point1 point2) + (cond + ((< point1 point2) + 'p point1 point2) + 'p>p) + (t + 'p=p))) + +(defun ii-compare-universal-times (interval1 interval2) + (mvlet (((list start1 finish1) interval1) + ((list start2 finish2) interval2)) + (cond + ((= start1 start2) + (if (< finish1 finish2) 's (if (> finish1 finish2) 'si '=))) + ((= finish1 finish2) + (if (> start1 start2) 'f 'fi)) + ((<= finish1 start2) + (if (= finish1 start2) 'm '<)) + ((>= start1 finish2) + (if (= start1 finish2) 'mi '>)) + ((< start1 start2) + (if (> finish1 finish2) 'di 'o)) + (t + (if (< finish1 finish2) 'd 'oi))))) + +(defun pi-compare-universal-times (point interval) + (mvlet (((list start finish) interval)) + (cond + ((<= point start) + (if (= point start) 'p_s_i 'p= point finish) + (if (= point finish) 'p_f_i 'p>i)) + (t + 'p_d_i)))) + +(defun declare-date-functions (&key intervals points) + (when points + (declare-function1 '$$utime-point 1 :sort (list (time-point-sort-name?)))) + (when intervals + (declare-function1 '$$utime-interval 2 :sort (list (time-interval-sort-name?)))) + (when points + (declare-relation1 '$$time-pp 3 :locked nil :rewrite-code 'time-pp-atom-rewriter-for-dates) + (declare-utime-pp-composition)) + (when intervals + (declare-relation1 '$$time-ii 3 :locked nil :rewrite-code 'time-ii-atom-rewriter-for-dates)) + (when (and points intervals) + (declare-relation1 '$$time-pi 3 :locked nil :rewrite-code 'time-pi-atom-rewriter-for-dates) + (declare-utime-pi-composition)) + nil) + +(defun input-date-point (head args polarity) + (declare (ignore head polarity)) + (make-compound *utime-point* (declare-constant (apply 'encode-universal-time-point args)))) + +(defun input-date-interval (head args polarity) + (declare (ignore head polarity)) + (let (v start finish) + (cond + ((setf v (member :until args)) + (setf start (apply 'encode-universal-time-point (ldiff args v))) + (setf finish (apply 'encode-universal-time-point (rest v))) + (cl:assert (< start finish))) + (t + (setf v (apply 'encode-universal-time-interval args)) + (setf start (first v)) + (setf finish (second v)))) + (declare-constant start) + (declare-constant finish) + (make-compound *utime-interval* start finish))) + +(defun utime-point-term-to-lisp (head args subst) + (declare (ignore head)) + (or (let ((arg1 (first args))) + (and (dereference arg1 subst :if-constant (integerp arg1)) + (cons (function-name *date-point*) + (decode-universal-time-point arg1)))) + none)) + +(defun utime-interval-term-to-lisp (head args subst) + (declare (ignore head)) + (or (let ((arg1 (first args)) + (arg2 (second args))) + (and (dereference arg1 subst :if-constant (integerp arg1)) + (dereference arg2 subst :if-constant (integerp arg2)) + (cons (function-name *date-interval*) + (append (decode-universal-time-point arg1) + (cons :until (decode-universal-time-point arg2)))))) + none)) + +(defun utime-point-term-p (term subst) + (dereference + term subst + :if-compound-appl (and (eq *utime-point* (heada term)) + (let* ((args (argsa term)) + (arg1 (first args))) + (and (dereference arg1 subst :if-constant (integerp arg1)) + arg1))))) + +(defun utime-interval-term-p (term subst) + (dereference + term subst + :if-compound-appl (and (eq *utime-interval* (heada term)) + (let* ((args (argsa term)) + (arg1 (first args)) + (arg2 (second args))) + (and (dereference arg1 subst :if-constant (integerp arg1)) + (dereference arg2 subst :if-constant (integerp arg2)) + (if (and (eql arg1 (first args)) + (eql arg2 (second args))) + args + (list arg1 arg2))))))) + +(defun time-ii-atom-rewriter-for-dates (term subst) + (let ((args (args term)) m n v) + (cond + ((and (setf m (utime-interval-term-p (first args) subst)) + (setf n (utime-interval-term-p (second args) subst)) + (progn (setf v (third args)) (dereference v subst :if-compound-cons t))) + (setf v (nth (jepd-relation-code (ii-compare-universal-times m n) $time-ii-relation-code) v)) + (if (dereference v subst :if-variable t) false true)) + (t + none)))) + +(defun time-pp-atom-rewriter-for-dates (term subst) + (let ((args (args term)) m n v) + (cond + ((and (setf m (utime-point-term-p (first args) subst)) + (setf n (utime-point-term-p (second args) subst)) + (progn (setf v (third args)) (dereference v subst :if-compound-cons t))) + (setf v (nth (jepd-relation-code (pp-compare-universal-times m n) $time-pp-relation-code) v)) + (if (dereference v subst :if-variable t) false true)) + (t + none)))) + +(defun time-pi-atom-rewriter-for-dates (term subst) + (let ((args (args term)) m n v) + (cond + ((and (setf m (utime-point-term-p (first args) subst)) + (setf n (utime-interval-term-p (second args) subst)) + (progn (setf v (third args)) (dereference v subst :if-compound-cons t))) + (setf v (nth (jepd-relation-code (pi-compare-universal-times m n) $time-pi-relation-code) v)) + (if (dereference v subst :if-variable t) false true)) + (t + none)))) + +(defun declare-utime-pp-composition () + ;; use relations between x&z and z&y to constrain relation between x&y where x and z are utimes and y is a point + (declare-relation1 + '$$utime-pp-composition + 5 + :rewrite-code + (list + (lambda (atom subst) + (let ((args (args atom)) m n) + (or (and (setf m (utime-point-term-p (third args) subst)) + (setf n (utime-point-term-p (fifth args) subst)) + (if (/= m n) + (make-compound + (input-relation-symbol '$$time-pp-composition 5) + (if (< m n) + (list 1 (make-and-freeze-variable) (make-and-freeze-variable)) + (list (make-and-freeze-variable) (make-and-freeze-variable) 1)) + (second (args atom)) + (third (args atom)) + (fifth (args atom)) + (fourth (args atom))) + true)) + none))))) + (assert `(forall (?x (?y :sort ,(time-point-sort-name?)) ?z ?l1 ?l2) + (implies (and ($$time-pp ($$utime-point ?x) ?y ?l1) + ($$time-pp ($$utime-point ?z) ?y ?l2)) + ($$utime-pp-composition ?l1 ?l2 ($$utime-point ?x) ?y ($$utime-point ?z)))) + :name :$$utime-pp-composition + :supported nil)) + +(defun declare-utime-pi-composition () + ;; use relations between x&z and z&y to constrain relation between x&y where x and z are utimes and y is an interval + (declare-relation1 + '$$utime-pi-composition + 5 + :rewrite-code + (list + (lambda (atom subst) + (let ((args (args atom)) m n) + (or (and (setf m (utime-point-term-p (third args) subst)) + (setf n (utime-point-term-p (fifth args) subst)) + (if (/= m n) + (make-compound + (input-relation-symbol '$$time-pi-pp-composition 5) + (if (< m n) + (list 1 (make-and-freeze-variable) (make-and-freeze-variable)) + (list (make-and-freeze-variable) (make-and-freeze-variable) 1)) + (second (args atom)) + (third (args atom)) + (fifth (args atom)) + (fourth (args atom))) + true)) + none))))) + (assert `(forall (?x (?y :sort ,(time-interval-sort-name?)) ?z ?l1 ?l2) + (implies (and ($$time-pi ($$utime-point ?x) ?y ?l1) + ($$time-pi ($$utime-point ?z) ?y ?l2)) + ($$utime-pi-composition ?l1 ?l2 ($$utime-point ?x) ?y ($$utime-point ?z)))) + :name :$$utime-pi-composition + :supported nil)) + +;;; date-reasoning2.lisp EOF diff --git a/src/davis-putnam3.lisp b/src/davis-putnam3.lisp new file mode 100644 index 0000000..87bc60b --- /dev/null +++ b/src/davis-putnam3.lisp @@ -0,0 +1,2344 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-dpll -*- +;;; File: davis-putnam3.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-dpll) +(defparameter dp-prover :|LDPP'|) ;the name of this prover +(defparameter dp-version "3.481") ;its version number + +;;; LDPP' +;;; +;;; Satisfiability Testing by the Davis-Putnam Procedure +;;; Using List Representation for a Set of Propositional Clauses +;;; by +;;; Mark E. Stickel +;;; Artificial Intelligence Center +;;; SRI International +;;; Menlo Park, California 94025 +;;; (stickel@ai.sri.com) +;;; +;;; LDPP' is a fairly fast implementation of the Davis-Putnam procedure, +;;; but still has several deficiencies. There is +;;; no checking that a negative clause exists +;;; no intelligent literal selection criteria +;;; no looking for symmetry +;;; +;;; +;;; Some information about LDPP' and related systems can be found in +;;; H. Zhang and M.E. Stickel. Implementing the Davis-Putnam algorithm by tries. +;;; Technical Report, Computer Science Department, The University of Iowa, +;;; Iowa City, Iowa, August 1994. +;;; obtainable by FTP from ftp.cs.uiowa.edu: /pub/hzhang/sato/papers/davis.dvi.Z +;;; +;;; +;;; Usage: +;;; A set of clauses can be created incrementally by +;;; (setf clause-set (make-dp-clause-set)) +;;; followed by calls +;;; (dp-insert clause clause-set) or +;;; (dp-insert-wff wff clause-set). +;;; A set of clauses can be tested for satisfiability by +;;; (dp-satisfiable-p clause-set {options}*). +;;; A set of clauses or wffs in a file can be tested by +;;; (dp-satisfiable-file-p filename {options}*). +;;; See examples at the end of this file. +;;; +;;; +;;; LDPP' is an implementation of the Davis-Putnam procedure without logical +;;; refinements. It is efficient because of the way it performs the crucial +;;; truth-value assignment operation. LDPP' uses reversible destructive list +;;; operations, similarly to Crawford and Auton's TABLEAU, Letz's SEMPROP, +;;; Zhang's SATO, and McCune's MACE theorem provers. +;;; +;;; In LDPP', a set of clauses is represented by a list of structures for +;;; clauses and a list of structures for atomic formulas. The structure for +;;; a clause contains the fields: +;;; +;;; * POSITIVE-LITERALS, NEGATIVE-LITERALS: List of pointers to structures +;;; for atomic formulas occurring positively (resp., negatively) in this +;;; clause. +;;; +;;; * NUMBER-OF-UNRESOLVED-POSITIVE-LITERALS, NUMBER-OF-UNRESOLVED-NEGATIVE-LITERALS: +;;; This is the number of atomic formulas in POSITIVE-LITERALS +;;; (resp., NEGATIVE-LITERALS) that have not been resolved away. +;;; They may have been assigned the opposite truth-value and the clause +;;; is really subsumed. +;;; +;;; The structure for an atomic formula contains the fields: +;;; +;;; * VALUE: This is TRUE if the atomic formula has been assigned the value +;;; true, FALSE if it has been assigned false, and NIL if no value has been +;;; assigned. +;;; +;;; * CONTAINED-POSITIVELY-CLAUSES, CONTAINED-NEGATIVELY-CLAUSES: List of +;;; pointers to structures for clauses that contain this atomic formula +;;; positively (resp., negatively). +;;; +;;; To assign true to an atomic formula: +;;; +;;; * Its VALUE field is set to TRUE. +;;; +;;; * Every clause in CONTAINED-NEGATIVELY-CLAUSES has its +;;; NUMBER-OF-UNRESOLVED-NEGATIVE-LITERALS field decremented by one. +;;; Note that we don't modify NEGATIVE-LITERALS itself. +;;; If the sum of NUMBER-OF-UNRESOLVED-NEGATIVE-LITERALS +;;; and NUMBER-OF-UNRESOLVED-POSITIVE-LITERALS is zero, the current truth +;;; assignment yields the unsatisfiable empty clause. If the sum is one, a +;;; new unit clause has been produced. The newly derived unit clause can be +;;; identified by finding the only atom in POSITIVE-LITERALS or +;;; NEGATIVE-LITERALS whose VALUE is NIL. These are queued and assigned +;;; values before assign exits so that all unit propagation is done inside +;;; the assign procedure. +;;; +;;; To undo an assignment of true to an atomic formula and thus restore +;;; the set of clauses to their state before the assignment so alternative +;;; assignments can be tested: +;;; +;;; * The VALUE field for the atomic formula is set to NIL. +;;; +;;; * Every clause in CONTAINED-NEGATIVELY-CLAUSES has its +;;; NUMBER-OF-UNRESOLVED-NEGATIVE-LITERALS field incremented by one. +;;; +;;; Assignment of false to an atomic formula is done analogously. + +(defvar dp-tracing 100000) ;prints trace information +(defvar dp-tracing-state 10) ;prints current choice points + ;once every 10000*10 branches +(defvar dp-tracing-models nil) ;prints models found +(defvar dp-tracing-choices 2) ;print values of split atoms + ; to this depth of splitting + ; beyond shallowest backtrack +;;; When dp-tracing is the number N, branch number is printed once for each +;;; N branches. +;;; When dp-tracing = T, dp-tracing enables the following: +;;; print number of branches each time a branch is added +;;; print Succeed(M/N) when terminating a success branch +;;; print Fail(M/N) when terminating a failure branch +;;; where M is the number of success/failure branches +;;; and N is total number of terminated branches so far. + +(defstruct (dp-clause-set + (:print-function print-dp-clause-set3) + (:copier nil)) + (atoms nil) + (number-of-atoms 0 :type integer) ;in atom-hash-table, may not all appear in clauses + (number-of-clauses 0 :type integer) + (number-of-literals 0 :type integer) + (p-clauses nil) ;clauses that initially contained only positive literals + (n-clauses nil) ;clauses that initially contained only negative literals + (m1-clauses nil) ;clauses that initially were mixed Horn clauses + (m2-clauses nil) ;clauses that initially were mixed non-Horn clauses + (atom-hash-table (make-hash-table :test #'equal)) + (atoms-last nil) + (p-clauses-last nil) + (n-clauses-last nil) + (m1-clauses-last nil) + (m2-clauses-last nil) + (number-to-atom-hash-table (make-hash-table)) + (checkpoint-level 0 :type fixnum) + (checkpoints nil)) + +(defstruct (dp-clause + (:print-function print-dp-clause) + (:copier nil)) + (number-of-unresolved-positive-literals 0 :type fixnum) + (number-of-unresolved-negative-literals 0 :type fixnum) + (positive-literals nil :type list) + (negative-literals nil :type list) + (subsumption-mark nil) + (next nil)) + +(defstruct (dp-atom + (:print-function print-dp-atom) + (:copier nil)) + name + number + (value nil) + (contained-positively-clauses nil) + (contained-negatively-clauses nil) + (derived-from-clause nil) + (used-in-refutation -1) + (next nil) + (choice-point nil) + true-triable ;used by lookahead + false-triable ;used by lookahead + (number-of-occurrences 0 :type integer) + (checkpoints nil)) + +(defvar *default-find-all-models* 1) +(defvar *default-model-test-function* nil) +(defvar *default-dependency-check* t) +(defvar *default-pure-literal-check* t) +(defvar *default-atom-choice-function* 'choose-an-atom-of-a-shortest-positive-clause) +(defvar *default-more-units-function* nil) +(defvar *default-branch-limit* nil) +(defvar *default-time-limit* nil) +(defvar *default-minimal-models-suffice* t) +(defvar *default-minimal-models-only* nil) +(defvar *default-convert-to-clauses* nil) +(defvar *default-dimacs-cnf-format* :p) +(defvar *default-subsumption* nil) +(defvar *default-print-summary* t) +(defvar *default-print-warnings* t) + +(defvar *dependency-check*) +(defvar *more-units-function*) +(defvar *minimal-models-suffice*) +(defvar *clause-set*) +(defvar *failure-branch-count* 0) +(defvar *assignment-count* 0) +(declaim (type integer *failure-branch-count* *assignment-count*)) +(defvar *dp-start-time*) + +(defun dp-satisfiable-p (clause-set + &key + (find-all-models *default-find-all-models*) + (model-test-function *default-model-test-function*) + ((:dependency-check *dependency-check*) *default-dependency-check*) + (pure-literal-check *default-pure-literal-check*) + (atom-choice-function *default-atom-choice-function*) + ((:more-units-function *more-units-function*) *default-more-units-function*) + (branch-limit *default-branch-limit*) + (time-limit *default-time-limit*) + ((:minimal-models-suffice *minimal-models-suffice*) *default-minimal-models-suffice*) + (return-propagated-clauses nil) + (minimal-models-only *default-minimal-models-only*) + (subsumption *default-subsumption*) + (print-summary *default-print-summary*) + (print-warnings *default-print-warnings*) + ((:trace dp-tracing) dp-tracing) + ((:trace-choices dp-tracing-choices) dp-tracing-choices)) + ;; Determines satisfiability of the set of clauses in clause-set. + ;; If find-all-models argument is T, dp-satisfiable-p will return + ;; a list of all models it finds in an exhaustive search; if it is NIL, T/NIL + ;; will be returned if a model is/is not found; if it is an integer N >= 1, + ;; only the first N models will be returned; if it is an integer N <= -1, + ;; models after the first -N will be searched for and counted but not + ;; returned. + ;; + ;; DP-SATISFIABLE-P ordinarily is not guaranteed to find all models but only + ;; all minimal models (and possibly some non-minimal ones). It returns + ;; only the true atoms of a model; all others are false. A model M is + ;; minimal if for no other model M' is it the case that the true atoms + ;; of M' are a proper subset of the true atoms of M. For many types of + ;; problems (e.g., quasigroup existence and N-queens problems) all models + ;; are minimal. A set of clauses with no more positive clauses is + ;; recognized to be satisfiable under the assignment of false to all + ;; unassigned atoms. + ;; + ;; If minimal-models-suffice argument is NIL, DP-SATISFIABLE-P behavior is + ;; modified to exhaustively find assignments that explicitly satisfy every + ;; clause; false assignments are represented as negative literals in + ;; the models returned. Atoms not assigned a value can be either true + ;; or false. + ;; + ;; If minimal-models-only argument is non-NIL, only minimal models + ;; will be returned. As in Bry and Yahya's MM-SATCHMO, false + ;; assignments are considered before true ones when branching + ;; and redundant models are pruned by adding negated models as + ;; clauses. Pure-literal-check will not assign true to a pure atom. + ;; + ;; If dependency-check argument is non-NIL, a form of intelligent + ;; backtracking is used. If there are only failures below the + ;; true assignment at a choice point, and the assignment was never + ;; used to generate any of the contradictions, exploration of + ;; the false assignment will be skipped, as it will fail for + ;; the same reasons. + ;; + ;; If pure-literal-check argument is non-NIL, literals that are + ;; pure in the original set of clauses will be assigned a satisfying + ;; value. There is no checking if a literal becomes pure later. + ;; + ;; If more-units-function argument is non-nil, it names a function + ;; to be executed after unit propagation. The function may + ;; detect unsatisfiability or compute more unit clauses by + ;; additional means such as 2-closure or lookahead. + (assert-unvalued-dp-clause-set-p clause-set) + (cl:assert (or (eq t find-all-models) + (eq nil find-all-models) + (and (integerp find-all-models) + (not (zerop find-all-models)))) + (find-all-models) + "find-all-models = ~A but should be t, nil, or a nonzero integer." find-all-models) +;;(cl:assert (not (and *dependency-check* *more-units-function*)) +;; (*dependency-check* *more-units-function*) +;; "Dependency-check cannot be used with more-units-function.") + (cl:assert (not (and minimal-models-only (not *minimal-models-suffice*))) + (minimal-models-only *minimal-models-suffice*) + "Minimal-models-only cannot be used without minimal-models-suffice.") + (cl:assert (not (and pure-literal-check (not *minimal-models-suffice*))) + (pure-literal-check *minimal-models-suffice*) + "Pure-literal-check cannot be used without minimal-models-suffice.") + (let* ((*print-pretty* nil) + (models nil) models-last + (branch-count 1) + (success-branch-count 0) + (*failure-branch-count* 0) + (cutoff-branch-count 0) + (report-reaching-branch-limit print-summary) + (*assignment-count* 0) + (forced-choice-count 0) + (dp-tracing-choices (if (eq t dp-tracing) t dp-tracing-choices)) + (dp-tracing-choices-depth (if (and dp-tracing-choices + (not (eq t dp-tracing-choices)) + (>= 0 dp-tracing-choices)) + 0 + 10000)) + (*clause-set* clause-set) + start-time) + (declare (type integer branch-count success-branch-count *failure-branch-count*) + (type integer cutoff-branch-count forced-choice-count)) + (macrolet + ((process-success-branch () + `(progn + (incf success-branch-count) + (when (eq t dp-tracing) + (format t "Succeed (~D/~D)~%" success-branch-count (+ success-branch-count *failure-branch-count* cutoff-branch-count))) + (when minimal-models-only + ;; add constraint to eliminate supermodel generation + (add-model-constraint clause-set)) + (cond + ((null find-all-models) + t) + ((or (eq t find-all-models) + (plusp find-all-models) + (<= success-branch-count (- find-all-models))) + (let ((model (valued-atoms clause-set *minimal-models-suffice*))) + (when dp-tracing-models + (format t "~&Model ~D = ~A " success-branch-count model)) + (cond + ((and minimal-models-only (null model)) + (cl:assert (null models)) + (list model)) + (t + (collect model models) + (if (eql find-all-models success-branch-count) + models + nil))))) + (t + nil)))) + (process-failure-branch () + `(progn + (incf *failure-branch-count*) + (when (eq t dp-tracing) + (format t "Fail (~D/~D)~%" *failure-branch-count* (+ success-branch-count *failure-branch-count* cutoff-branch-count))) + nil)) + (process-cutoff-branch () + `(progn + (incf cutoff-branch-count) + (when (eq t dp-tracing) + (format t "Cutoff (~D/~D)~%" cutoff-branch-count (+ success-branch-count *failure-branch-count* cutoff-branch-count))) + nil))) + (labels + ((dp-satisfiable-p* (depth) + (declare (fixnum depth)) + (multiple-value-bind (atom value1 value2 chosen-clause) + ;; try value1, then value2 + (funcall atom-choice-function clause-set) + (when (and minimal-models-only (eq false value2)) + ;; try false assignment first when seeking minimal-models + (setf value1 false value2 true)) + (cond + ((eq :unsatisfiable atom) + (process-failure-branch)) + ((and branch-limit + (>= branch-count branch-limit) + (or (null time-limit) + (let ((time (run-time-since start-time))) + (cond + ((>= time time-limit) + t) + (t + (setf branch-limit (max branch-limit (ceiling (* branch-count (min 100 (/ time-limit time)))))) + nil))))) + (when report-reaching-branch-limit + (format t "~&Branch limit reached.") + (print-dp-choice-points clause-set (run-time-since start-time)) + (setf dp-tracing-choices nil) + (setf report-reaching-branch-limit nil)) + (setf time-limit nil) ;done with this now + (setf *dependency-check* nil) ;treat remaining branches as failed, not cutoff + (process-failure-branch)) + ((eq :satisfiable atom) + (if (or (null model-test-function) + (progn + (when (or (eq t dp-tracing) dp-tracing-models) + (format t "Test model ")) + (funcall model-test-function (valued-atoms clause-set *minimal-models-suffice*)))) + (process-success-branch) + (process-failure-branch))) + (t + (cl:assert (null (dp-atom-value atom)) () + "Atom ~A was chosen for splitting, but it is already ~A." + atom (dp-atom-value atom)) + (let (v (cut nil)) + ;; must make a copy of chosen-clause for trace output + ;; before making truth-value assignments + (when (and dp-tracing-choices + chosen-clause + (or (eq t dp-tracing-choices) + (< depth dp-tracing-choices-depth))) + (setf chosen-clause (decode-dp-clause chosen-clause))) + (setf (dp-atom-value atom) value1) + (setf (dp-atom-next atom) nil) + (cond + ((null value2) + (incf forced-choice-count) + (when (and dp-tracing-choices + (or (eq t dp-tracing-choices) + (< depth dp-tracing-choices-depth))) + (print-dp-trace-line depth atom value1 nil t chosen-clause)) + (setf v (assign-atoms atom)) + (cond + ((eq :unsatisfiable v) + (process-failure-branch)) + (t + (prog1 (dp-satisfiable-p* depth) + (unassign-atoms v))))) + (t + (incf branch-count) + (cond + ((and dp-tracing-choices + (or (eq t dp-tracing-choices) + (< depth dp-tracing-choices-depth))) + (print-dp-trace-line depth atom value1 branch-count nil chosen-clause)) + ((and dp-tracing (eql 0 (rem branch-count dp-tracing))) + (when (and dp-tracing-state + (eql 0 (rem branch-count (* dp-tracing dp-tracing-state)))) + (princ branch-count) + (print-dp-choice-points clause-set (run-time-since start-time))) + (princ branch-count) + (princ " ") + (force-output))) + (setf v (assign-atoms atom)) + (cond + ((if (eq :unsatisfiable v) + (process-failure-branch) + (prog2 + (setf (dp-atom-choice-point atom) branch-count) + (if (not *dependency-check*) + (prog1 (dp-satisfiable-p* (+ depth 1)) + (unassign-atoms v)) + (let ((old-success-branch-count 0) + (old-failure-branch-count 0)) + (declare (type integer old-success-branch-count old-failure-branch-count)) + (setf old-success-branch-count success-branch-count) + (setf old-failure-branch-count *failure-branch-count*) + (prog1 (dp-satisfiable-p* (+ depth 1)) + (when (and *dependency-check* + (not (<= old-failure-branch-count (dp-atom-used-in-refutation atom))) + (eql old-success-branch-count success-branch-count)) + (setf cut t)) + (unassign-atoms v)))) + (setf (dp-atom-choice-point atom) nil))) + ) + (t + (cond + ((null dp-tracing-choices) + ) + ((eq t dp-tracing-choices) + (print-dp-trace-line depth atom value2 nil t nil)) + ((< depth dp-tracing-choices-depth) + (let ((n (+ depth dp-tracing-choices))) + (when (< n dp-tracing-choices-depth) + (setf dp-tracing-choices-depth n))) + (print-dp-trace-line depth atom value2 nil t nil))) + (cond + (cut + (process-cutoff-branch)) + (t + (setf (dp-atom-value atom) value2) + (setf (dp-atom-next atom) nil) + (setf v (assign-atoms atom)) + (cond + ((eq :unsatisfiable v) + (process-failure-branch)) + (t + (prog1 (dp-satisfiable-p* depth) + (unassign-atoms v)))))))))))))))) + (when print-summary + (dp-count clause-set t)) + (when subsumption + (dp-subsumption clause-set print-summary)) + (when print-summary + (format t "~%~A version ~A control settings:" dp-prover dp-version) + (format t "~% atom-choice-function = ~A" atom-choice-function) + (format t "~% more-units-function = ~A" *more-units-function*) + (format t "~% model-test-function = ~A" model-test-function) + (format t "~% dependency-check = ~A" *dependency-check*) + (format t "~% pure-literal-check = ~A" pure-literal-check) + (format t "~% find-all-models = ~A" find-all-models) + (cond + (minimal-models-only + (format t "~% minimal-models-only = ~A" minimal-models-only)) + ((not *minimal-models-suffice*) + (format t "~% minimal-models-suffice = ~A" *minimal-models-suffice*))) + (when branch-limit + (format t "~% branch-limit = ~A" branch-limit)) + (when time-limit + (format t "~% time-limit = ~A" time-limit)) + (terpri)) + (when print-warnings + (let ((neg-pure-atoms nil) neg-pure-atoms-last + (pos-pure-atoms nil) pos-pure-atoms-last) + (dolist (atom (dp-clause-set-atoms clause-set)) + (when (and (null (dp-atom-contained-positively-clauses atom)) ;atom occurs negatively only + (dp-atom-contained-negatively-clauses atom)) + (collect atom neg-pure-atoms)) + (when (and (null (dp-atom-contained-negatively-clauses atom)) ;atom occurs positively only + (dp-atom-contained-positively-clauses atom)) + (collect atom pos-pure-atoms))) + (when neg-pure-atoms + (warn "There are no positive occurrences of atom~P ~A~{, ~A~}." + (unless (rest neg-pure-atoms) 1) + (first neg-pure-atoms) + (rest neg-pure-atoms))) + (when pos-pure-atoms + (warn "There are no negative occurrences of atom~P ~A~{, ~A~}." + (unless (rest pos-pure-atoms) 1) + (first pos-pure-atoms) + (rest pos-pure-atoms))))) + (let (time initial-units (result nil) (pure-literals nil) + (positive-pure-literal-count 0) (negative-pure-literal-count 0) + (normal-exit nil)) + (declare (type integer positive-pure-literal-count negative-pure-literal-count)) + (setf (values start-time *dp-start-time*) (run-time-since 0.0)) + ;; time-limit uses branch-limit that is raised when reached + ;; until time-limit is reached + (when time-limit + (unless branch-limit + (setf branch-limit 1000))) + (when pure-literal-check + (dolist (atom (dp-clause-set-atoms clause-set)) + (unless (dp-atom-value atom) + (cond + ((and (null (dp-atom-contained-positively-clauses atom)) ;atom occurs negatively only + (dp-atom-contained-negatively-clauses atom)) + (incf negative-pure-literal-count) + (setf (dp-atom-value atom) false) + (setf (dp-atom-next atom) pure-literals) + (setf pure-literals atom)) + ((and (null (dp-atom-contained-negatively-clauses atom)) ;atom occurs positively only + (dp-atom-contained-positively-clauses atom) + (not minimal-models-only)) + (incf positive-pure-literal-count) + (setf (dp-atom-value atom) true) + (setf (dp-atom-next atom) pure-literals) + (setf pure-literals atom))))) + (when pure-literals + (setf pure-literals (assign-atoms pure-literals)))) + (unwind-protect + (progn + (cond + ((or (eq :unsatisfiable (setf initial-units (find-unit-clauses clause-set))) + (eq :unsatisfiable (setf initial-units (assign-atoms initial-units)))) + (when return-propagated-clauses + (setf return-propagated-clauses (list nil))) + (setf result (process-failure-branch))) + (t + (when return-propagated-clauses + (setf return-propagated-clauses + (nconc (mapcan (lambda (atom) (when (eq true (dp-atom-value atom)) (list (list (dp-atom-name atom))))) (dp-clause-set-atoms clause-set)) + (mapcan (lambda (atom) (when (eq false (dp-atom-value atom)) (list (list (complementary-literal (dp-atom-name atom)))))) (dp-clause-set-atoms clause-set)) + (dp-clauses nil clause-set)))) + (setf result (dp-satisfiable-p* 0)) + (unassign-atoms initial-units))) + (when pure-literals + (unassign-atoms pure-literals)) + (setf normal-exit t)) + (setf time (run-time-since start-time)) + (unless normal-exit + (when print-summary + (format t "~&Abnormal exit.") + (print-dp-choice-points clause-set time)) + (fix-dp-clause-set clause-set)) + (when print-summary + (format t "~&Found ~D success, ~D failure, ~D cutoff, ~D total branches in ~,1F seconds." + success-branch-count + *failure-branch-count* + cutoff-branch-count + (+ success-branch-count *failure-branch-count* cutoff-branch-count) + time) + #+ignore + (format t "~%~D assignment~:P." *assignment-count*) + (when (plusp positive-pure-literal-count) + (format t "~%~D atom~:P occurred purely positively in the input." positive-pure-literal-count)) + (when (plusp negative-pure-literal-count) + (format t "~%~D atom~:P occurred purely negatively in the input." negative-pure-literal-count)) + (when (plusp forced-choice-count) + (format t "~%~D choice~:P forced." forced-choice-count)))) + (values (or result models) + success-branch-count + *failure-branch-count* + cutoff-branch-count + time + *assignment-count* + positive-pure-literal-count + negative-pure-literal-count + forced-choice-count + return-propagated-clauses)))))) + +(defun dp-satisfiable-file-p (filename &rest options + &key + (convert-to-clauses *default-convert-to-clauses*) + (dimacs-cnf-format *default-dimacs-cnf-format*) + (print-summary *default-print-summary*) + (print-warnings *default-print-warnings*) + &allow-other-keys) + (apply #'dp-satisfiable-p + (dp-insert-file filename nil + :convert-to-clauses convert-to-clauses + :dimacs-cnf-format dimacs-cnf-format + :print-summary print-summary + :print-warnings print-warnings) + (do ((x options (cddr x)) + (v nil) v-last) + ((null x) + v) + (unless (member (first x) '(:convert-to-clauses :dimacs-cnf-format)) + (collect (first x) v) + (collect (second x) v))))) + +(defun dp-insert (clause clause-set &key (print-warnings *default-print-warnings*)) + (cl:assert (not (null clause)) () "Cannot insert the empty clause.") + (if clause-set + (assert-dp-clause-set-p clause-set) + (setf clause-set (make-dp-clause-set))) + (unless (eq :safe print-warnings) + (let ((v (clause-contains-repeated-atom clause))) + (cond + ((eq :tautology v) + (when print-warnings + (warn "Complementary literals in clause ~A." clause)) + (return-from dp-insert clause-set)) + (v + (when print-warnings + (warn "Duplicate literals in clause ~A." clause)) + (setf clause (delete-duplicates clause :test #'equal)))))) + (let ((cl (make-dp-clause)) + (nlits 0) + (p 0) + (n 0) + (positive-literals nil) + (negative-literals nil) + positive-literals-last + negative-literals-last) + (dolist (lit clause) + (let* ((neg (negative-literal-p lit)) + (atom0 (or neg lit)) + (atom (if (dp-atom-p atom0) atom0 (dp-atom-named atom0 clause-set :if-does-not-exist :create)))) + (checkpoint-dp-atom atom clause-set) + (incf (dp-atom-number-of-occurrences atom)) + (incf nlits) + (cond + (neg + (unless (eq true (dp-atom-value atom)) + (incf n)) + (collect atom negative-literals) + (push cl (dp-atom-contained-negatively-clauses atom))) + (t + (unless (eq false (dp-atom-value atom)) + (incf p)) + (collect atom positive-literals) + (push cl (dp-atom-contained-positively-clauses atom)))))) + (incf (dp-clause-set-number-of-clauses clause-set)) + (incf (dp-clause-set-number-of-literals clause-set) nlits) + (when positive-literals + (setf (dp-clause-number-of-unresolved-positive-literals cl) p) + (setf (dp-clause-positive-literals cl) positive-literals)) + (when negative-literals + (setf (dp-clause-number-of-unresolved-negative-literals cl) n) + (setf (dp-clause-negative-literals cl) negative-literals)) + (cond + ((null negative-literals) + (if (dp-clause-set-p-clauses clause-set) + (let ((temp (dp-clause-set-p-clauses-last clause-set))) + (setf (dp-clause-next temp) (setf (dp-clause-set-p-clauses-last clause-set) cl))) + (setf (dp-clause-set-p-clauses clause-set) (setf (dp-clause-set-p-clauses-last clause-set) cl)))) + ((null positive-literals) + (if (dp-clause-set-n-clauses clause-set) + (let ((temp (dp-clause-set-n-clauses-last clause-set))) + (setf (dp-clause-next temp) (setf (dp-clause-set-n-clauses-last clause-set) cl))) + (setf (dp-clause-set-n-clauses clause-set) (setf (dp-clause-set-n-clauses-last clause-set) cl)))) + ((null (rest positive-literals)) + (if (dp-clause-set-m1-clauses clause-set) + (let ((temp (dp-clause-set-m1-clauses-last clause-set))) + (setf (dp-clause-next temp) (setf (dp-clause-set-m1-clauses-last clause-set) cl))) + (setf (dp-clause-set-m1-clauses clause-set) (setf (dp-clause-set-m1-clauses-last clause-set) cl)))) + (t + (if (dp-clause-set-m2-clauses clause-set) + (let ((temp (dp-clause-set-m2-clauses-last clause-set))) + (setf (dp-clause-next temp) (setf (dp-clause-set-m2-clauses-last clause-set) cl))) + (setf (dp-clause-set-m2-clauses clause-set) (setf (dp-clause-set-m2-clauses-last clause-set) cl)))))) + clause-set) + +(defun dp-insert-sorted (clause clause-set &key (print-warnings *default-print-warnings*)) + ;; clauses are not required to be sorted, so unsorted clause is inserted + (dp-insert clause clause-set :print-warnings print-warnings)) + +(defun dp-insert-wff (wff clause-set &key (print-warnings *default-print-warnings*)) + ;; convert a wff to clause form and insert the clauses + (if clause-set + (assert-dp-clause-set-p clause-set) + (setf clause-set (make-dp-clause-set))) + (wff-clauses wff (lambda (clause) (dp-insert-sorted clause clause-set :print-warnings print-warnings))) + clause-set) + +(defvar *dp-read-string*) +(defvar *dp-read-index*) + +(defun dp-read (s dimacs-cnf-format print-warnings) + ;; reads a single clause if dimacs-cnf-format = nil + ;; reads a single literal if dimacs-cnf-format = t + (loop + (cond + (dimacs-cnf-format + (multiple-value-bind (x i) + (read-from-string *dp-read-string* nil :eof :start *dp-read-index*) + (cond + ((eq :eof x) + (if (eq :eof (setf *dp-read-string* (read-line s nil :eof))) + (return :eof) + (setf *dp-read-index* 0))) + ((integerp x) + (setf *dp-read-index* i) + (return x)) + ((eql 0 *dp-read-index*) ;ignore DIMACS problem/comment line + (when print-warnings + (warn "Skipping line ~A" *dp-read-string*)) + (if (eq :eof (setf *dp-read-string* (read-line s nil :eof))) + (return :eof) + (setf *dp-read-index* 0))) + (t + (when print-warnings + (warn "Skipping noninteger ~A" x)) + (setf *dp-read-index* i))))) + (t + (let ((x (read s nil :eof))) + (cond + ((or (eq :eof x) (consp x)) + (return x)) ;no syntax checking + (print-warnings + (warn "Skipping nonclause ~A" x)))))))) + +(defun dp-insert-file (filename clause-set + &key + (convert-to-clauses *default-convert-to-clauses*) + (dimacs-cnf-format *default-dimacs-cnf-format*) + (print-summary *default-print-summary*) + (print-warnings *default-print-warnings*)) + (let ((start-time (run-time-since 0.0)) (nclauses 0) (nlits 0)) + (declare (type integer nclauses nlits)) + (if clause-set + (assert-dp-clause-set-p clause-set) + (setf clause-set (make-dp-clause-set))) + (when print-summary + (format t "~2%Problem from file ~A:" filename)) + (with-open-file (s filename :direction :input) + (cond + (dimacs-cnf-format + (let ((*dp-read-string* "") (*dp-read-index* 0) (lits nil)) + (loop + (let ((x (dp-read s t print-warnings))) + (cond + ((eq :eof x) + (return)) + ((eql 0 x) + (when lits + (incf nclauses) + (incf nlits (length lits)) + (dp-insert-sorted (nreverse lits) clause-set :print-warnings print-warnings) + (setf lits nil))) + (t + (push x lits))))) + (when lits + (setf lits (nreverse lits)) + (when print-warnings + (warn "Last clause ~A in file not followed by 0." lits)) + (incf nclauses) + (incf nlits (length lits)) + (dp-insert-sorted lits clause-set :print-warnings print-warnings)))) + (t + (loop + (let ((x (dp-read s nil print-warnings))) + (cond + ((eq :eof x) + (return)) + (convert-to-clauses + (dp-insert-wff x clause-set :print-warnings print-warnings)) ;nclauses, nlits not incremented as they should be + (t + (incf nclauses) + (incf nlits (length x)) + (dp-insert-sorted x clause-set :print-warnings print-warnings)))))))) + (when print-summary + (format t "~&Input from file ~D clauses with ~D literals in ~,1F seconds." + nclauses + nlits + (run-time-since start-time))) + clause-set)) + +(defmacro clause-contains-true-positive-literal (clause) + (let ((atom (gensym))) + `(dolist (,atom (dp-clause-positive-literals ,clause) nil) + (when (eq true (dp-atom-value ,atom)) + (return t))))) + +(defmacro clause-contains-true-negative-literal (clause) + (let ((atom (gensym))) + `(dolist (,atom (dp-clause-negative-literals ,clause)) + (when (eq false (dp-atom-value ,atom)) + (return t))))) + +(defun dp-horn-clause-set-p (clause-set) + ;; never more than one positive literal in a clause + ;; (unless the clause is true in the current truth assignment) + (and (do ((clause (dp-clause-set-p-clauses clause-set) (dp-clause-next clause))) + ((null clause) + t) + (when (and (< 1 (dp-clause-number-of-unresolved-positive-literals clause)) + (not (clause-contains-true-positive-literal clause))) + (return nil))) + (do ((clause (dp-clause-set-m2-clauses clause-set) (dp-clause-next clause))) + ((null clause) + t) + (when (and (< 1 (dp-clause-number-of-unresolved-positive-literals clause)) + (not (clause-contains-true-positive-literal clause)) + (not (clause-contains-true-negative-literal clause))) + (return nil))))) + +(defun dp-count (clause-set &optional print-p) + ;; (dp-count clause-set) returns and optionally prints the + ;; clause and literal count of clauses stored in clause-set + (let ((nclauses 0) (nliterals 0) (natoms 0) (assigned nil)) + (when clause-set + (dolist (atom (dp-clause-set-atoms clause-set)) + (when (or (dp-atom-contained-positively-clauses atom) ;atom appears in clause-set + (dp-atom-contained-negatively-clauses atom)) + (if (dp-atom-value atom) + (setf assigned t) + (incf natoms)))) + (cond + ((not assigned) + (setf nclauses (dp-clause-set-number-of-clauses clause-set)) + (setf nliterals (dp-clause-set-number-of-literals clause-set))) + (t + (do ((clause (dp-clause-set-p-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (clause-contains-true-positive-literal clause) + (incf nclauses) + (incf nliterals (dp-clause-number-of-unresolved-positive-literals clause)))) + (do ((clause (dp-clause-set-n-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (clause-contains-true-negative-literal clause) + (incf nclauses) + (incf nliterals (dp-clause-number-of-unresolved-negative-literals clause)))) + (do ((clause (dp-clause-set-m1-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (or (clause-contains-true-positive-literal clause) + (clause-contains-true-negative-literal clause)) + (incf nclauses) + (incf nliterals (dp-clause-number-of-unresolved-positive-literals clause)) + (incf nliterals (dp-clause-number-of-unresolved-negative-literals clause)))) + (do ((clause (dp-clause-set-m2-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (or (clause-contains-true-positive-literal clause) + (clause-contains-true-negative-literal clause)) + (incf nclauses) + (incf nliterals (dp-clause-number-of-unresolved-positive-literals clause)) + (incf nliterals (dp-clause-number-of-unresolved-negative-literals clause))))))) + (when print-p + (format t "~&Clause set contains ~D clauses with ~D literals formed from ~D atoms~A." + nclauses nliterals natoms (if (stringp print-p) print-p ""))) + (values nclauses nliterals natoms))) + +(defun dp-clauses (map-fun clause-set &optional decode-fun) + ;; either return or apply map-fun to all clauses in clause-set + (when clause-set + (cond + (map-fun + (do ((clause (dp-clause-set-p-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (clause-contains-true-positive-literal clause) + (funcall map-fun (decode-dp-clause clause decode-fun)))) + (do ((clause (dp-clause-set-n-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (clause-contains-true-negative-literal clause) + (funcall map-fun (decode-dp-clause clause decode-fun)))) + (do ((clause (dp-clause-set-m1-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (or (clause-contains-true-positive-literal clause) + (clause-contains-true-negative-literal clause)) + (funcall map-fun (decode-dp-clause clause decode-fun)))) + (do ((clause (dp-clause-set-m2-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (or (clause-contains-true-positive-literal clause) + (clause-contains-true-negative-literal clause)) + (funcall map-fun (decode-dp-clause clause decode-fun))))) + (t + (let ((result nil) result-last) + (do ((clause (dp-clause-set-p-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (clause-contains-true-positive-literal clause) + (collect (decode-dp-clause clause decode-fun) result))) + (do ((clause (dp-clause-set-n-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (clause-contains-true-negative-literal clause) + (collect (decode-dp-clause clause decode-fun) result))) + (do ((clause (dp-clause-set-m1-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (or (clause-contains-true-positive-literal clause) + (clause-contains-true-negative-literal clause)) + (collect (decode-dp-clause clause decode-fun) result))) + (do ((clause (dp-clause-set-m2-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (unless (or (clause-contains-true-positive-literal clause) + (clause-contains-true-negative-literal clause)) + (collect (decode-dp-clause clause decode-fun) result))) + result))))) + +(defun dp-output-clauses-to-file (filename clause-set &key (dimacs-cnf-format *default-dimacs-cnf-format*)) + ;; write clauses in clause-set to a file + (with-open-file (s filename :direction :output :if-exists :new-version) + (cond + (dimacs-cnf-format + (when (eq :p dimacs-cnf-format) + (format s "p cnf ~D ~D~%" (dp-clause-set-number-of-atoms clause-set) (dp-count clause-set))) + (dp-clauses (lambda (clause) + (dolist (lit clause) + (princ lit s) + (princ " " s)) + (princ 0 s) + (terpri s)) + clause-set + (if (dolist (atom (dp-clause-set-atoms clause-set) t) + (unless (and (integerp (dp-atom-name atom)) + (plusp (dp-atom-name atom))) + (return nil))) + nil + #'dp-atom-number))) + (t + (dp-clauses (lambda (clause) (prin1 clause s) (terpri s)) clause-set)))) + nil) + +(defun assert-dp-clause-set-p (clause-set) + (cl:assert (dp-clause-set-p clause-set) () "~S is not a dp-clause-set." clause-set)) + +(defun assert-unvalued-dp-clause-set-p (clause-set) + (assert-dp-clause-set-p clause-set) + (cl:assert (dolist (atom (dp-clause-set-atoms clause-set) t) + (when (dp-atom-value atom) + (return nil))))) + +(defun add-model-constraint (clause-set) + ;; for nonredundant generation of minimal models, + ;; add clause of negations of atoms true in model + (let ((cl (make-dp-clause)) + (nlits 0) + (negative-literals nil) + negative-literals-last) + (dolist (atom (dp-clause-set-atoms clause-set)) + (when (eq true (dp-atom-value atom)) + (checkpoint-dp-atom atom clause-set) + (incf (dp-atom-number-of-occurrences atom)) + (incf nlits) + (collect atom negative-literals) + (push cl (dp-atom-contained-negatively-clauses atom)))) + (when negative-literals + (incf (dp-clause-set-number-of-clauses clause-set)) + (incf (dp-clause-set-number-of-literals clause-set) nlits) + (setf (dp-clause-negative-literals cl) negative-literals) + (if (dp-clause-set-n-clauses clause-set) + (let ((temp (dp-clause-set-n-clauses-last clause-set))) + (setf (dp-clause-next temp) + (setf (dp-clause-set-n-clauses-last clause-set) cl))) + (setf (dp-clause-set-n-clauses clause-set) + (setf (dp-clause-set-n-clauses-last clause-set) cl)))))) + +(defun valued-atoms (clause-set &optional only-true-atoms) + (let ((result nil) result-last) + (dolist (atom (dp-clause-set-atoms clause-set)) + (let ((value (dp-atom-value atom))) + (when (and (if only-true-atoms (eq true value) value) + (or (dp-atom-contained-positively-clauses atom) ;atom appears in clause-set + (dp-atom-contained-negatively-clauses atom))) + (collect (if (eq true value) + (dp-atom-name atom) + (complementary-literal (dp-atom-name atom))) + result)))) + result)) + +(defun dp-atom-named (x clause-set &key (if-does-not-exist :error)) + (cl:assert (and (not (null x)) (not (eql 0 x))) () "~A cannot be used as an atomic formula." x) + (let ((table (dp-clause-set-atom-hash-table clause-set))) + (or (gethash x table) + (ecase if-does-not-exist + (:create + (let ((atom (make-dp-atom + :name x + :number (cond + ((integerp x) + (incf (dp-clause-set-number-of-atoms clause-set)) + (cl:assert (null (gethash x (dp-clause-set-number-to-atom-hash-table clause-set))) () + "Atom named ~A cannot be atom number ~A." x x) + x) + (t + (incf (dp-clause-set-number-of-atoms clause-set))))))) + (collect atom (dp-clause-set-atoms clause-set)) + (setf (gethash (dp-atom-number atom) (dp-clause-set-number-to-atom-hash-table clause-set)) atom) + (setf (gethash x table) atom))) + (:error + (error "Unknown atom ~A." x)) + ((nil) + nil))))) + +(defun negative-literal-p (lit) + ;; if 'lit' is a negative literal, return its atom + ;; if 'lit' is a positive literal, return 'nil' + (cond + ((numberp lit) ;positive number is atomic formula + (and (minusp lit) (- lit))) ;negative number is its negation + ((consp lit) + (and (eq 'not (first lit)) (second lit))) ;(not x) is negation of atomic formula x + (t + nil))) ;everything else is an atomic formula + +(defun complementary-literal (lit) + (cond + ((numberp lit) + (- lit)) + ((and (consp lit) (eq 'not (first lit))) + (second lit)) + (t + (list 'not lit)))) + +(defun clause-contains-repeated-atom (clause) + (do* ((dup nil) + (lits clause (rest lits)) + (lit (first lits) (first lits)) + (clit (complementary-literal lit) (complementary-literal lit))) + ((null (rest lits)) + dup) + (dolist (lit2 (rest lits)) + (cond + ((equal lit lit2) + (setf dup t)) + ((equal clit lit2) + (return-from clause-contains-repeated-atom :tautology)))))) + +(defun print-dp-clause-set3 (clause-set &optional (stream *standard-output*) depth) + (declare (ignore depth)) + (print-unreadable-object (clause-set stream :type t :identity t) + (princ (dp-clause-set-number-of-atoms clause-set) stream) + (princ " atoms " stream) + (princ (dp-clause-set-number-of-clauses clause-set) stream) + (princ " clauses" stream))) + +(defun decode-dp-clause (clause &optional decode-fun) + (let ((result nil) result-last) + (dolist (atom (dp-clause-negative-literals clause)) + (unless (dp-atom-value atom) + (collect (complementary-literal + (if decode-fun + (funcall decode-fun atom) + (dp-atom-name atom))) + result))) + (dolist (atom (dp-clause-positive-literals clause)) + (unless (dp-atom-value atom) + (collect (if decode-fun + (funcall decode-fun atom) + (dp-atom-name atom)) + result))) + result)) + +(defun print-dp-clause (clause &optional stream depth) + (declare (ignore depth)) + (prin1 (decode-dp-clause clause) stream) + clause) + +(defun print-dp-atom (atom &optional stream depth) + (declare (ignore depth)) + (prin1 (dp-atom-name atom) stream) + atom) + +(defun print-dp-trace-line (depth atom value branch-count xp chosen-clause) + (format t "~&~12A" (or branch-count "")) + (dotimes (i depth) + (princ (if (eql 4 (rem i 5)) "| " ": "))) + (princ (dp-atom-name atom)) + (princ (if (eq true value) "=true" "=false")) + (princ (if xp "! " " ")) + (when chosen-clause + (princ "for clause ") + (princ chosen-clause) + (princ " "))) + +(defun print-dp-choice-points (clause-set time) + (let ((atoms nil)) + (dolist (atom (dp-clause-set-atoms clause-set)) + (when (dp-atom-choice-point atom) + (push atom atoms))) + (cond + ((null atoms) + (format t "~2&--- no current choice points ")) + (t + (format t "~2&--- ~D current choice point~:P:" (length atoms)) + (let ((depth 0)) + (dolist (atom (sort atoms #'< :key #'dp-atom-choice-point)) + (print-dp-trace-line depth atom (dp-atom-value atom) (dp-atom-choice-point atom) nil nil) + (incf depth))))) + (format t "~%--- after ~,1F seconds " time))) + +(defvar float-internal-time-units-per-second (float internal-time-units-per-second)) + +(defun run-time-since (start-time) + (let ((ticks (get-internal-run-time))) + (values (- (/ ticks float-internal-time-units-per-second) start-time) ticks))) + +(defmacro first-nontrue-atom (atoms) + `(dolist (atom ,atoms) + (unless (eq true (dp-atom-value atom)) + (return atom)))) + +(defmacro first-nonfalse-atom (atoms) + `(dolist (atom ,atoms) + (unless (eq false (dp-atom-value atom)) + (return atom)))) + +(defmacro first-unassigned-atom (atoms) + `(dolist (atom ,atoms) + (unless (dp-atom-value atom) + (return atom)))) + +(defmacro nth-unassigned-atom (n atoms) + `(let ((k ,n)) + (dolist (atom ,atoms) + (unless (dp-atom-value atom) + (if (eql 0 k) (return atom) (decf k)))))) + +(defun mark-used-atoms (clause) + (let ((mark *failure-branch-count*)) + (labels + ((mark-used-atoms (clause) + (let (c) + (dolist (atom (dp-clause-positive-literals clause)) + (unless (eql mark (dp-atom-used-in-refutation atom)) + (setf (dp-atom-used-in-refutation atom) mark) + (when (setf c (dp-atom-derived-from-clause atom)) + (mark-used-atoms c)))) + (dolist (atom (dp-clause-negative-literals clause)) + (unless (eql mark (dp-atom-used-in-refutation atom)) + (setf (dp-atom-used-in-refutation atom) mark) + (when (setf c (dp-atom-derived-from-clause atom)) + (mark-used-atoms c))))))) + (mark-used-atoms clause) + (make-lemma mark nil)))) + +(defun make-lemma (fbc exclude-atom) + ;; incomplete + (flet ((lemma-atoms () + (let ((result nil) result-last) + (dolist (atom (dp-clause-set-atoms *clause-set*)) + (let ((value (dp-atom-value atom))) + (when (and value + (or (dp-atom-contained-positively-clauses atom) ;atom appears in clause-set + (dp-atom-contained-negatively-clauses atom)) + ;;(dp-atom-choice-point atom) + (not (eq exclude-atom atom)) + (not (dp-atom-derived-from-clause atom)) + (<= fbc (dp-atom-used-in-refutation atom))) + (collect (if (eq true value) + (complementary-literal (dp-atom-name atom)) + (dp-atom-name atom)) + result)))) + result))) + (when (eq t dp-tracing) + (format t "Lemma ~A " (lemma-atoms))))) + +(defvar *last-tried-atom*) + +(defun assign-atoms (assignments) + ;; apply assigments and do all resulting unit propagation + ;; if result is unsatisfiable, undo all changes and return :unsatisfiable + ;; otherwise return list of assignments made; unassign-atoms can undo + ;; the assignments + (let ((compute-more-units *more-units-function*)) + (macrolet + ((undo-assignments-and-exit (&optional no-assignments-for-this-atom) + `(progn + ,@(unless no-assignments-for-this-atom + (list `(unassign-atom atom clause))) + (unassign-atoms assignments-done) + (if *dependency-check* + (do ((a assignments (dp-atom-next a))) + ((null a)) + (setf (dp-atom-value a) nil) + (setf (dp-atom-derived-from-clause a) nil)) + (do ((a assignments (dp-atom-next a))) + ((null a)) + (setf (dp-atom-value a) nil))) + #+ignore + (incf *assignment-count* assignment-count) + (return-from assign-atoms :unsatisfiable))) + (new-unit-clause (val) + (cl:assert (or (eq 'true val) (eq 'false val))) + `(let ((at ,(if (eq 'true val) + `(first-nonfalse-atom (dp-clause-positive-literals clause)) + `(first-nontrue-atom (dp-clause-negative-literals clause))))) + (cond + ((null at) + (when *dependency-check* + (mark-used-atoms clause)) + (undo-assignments-and-exit)) + ((null (dp-atom-value at)) + (setf compute-more-units *more-units-function*) + (setf (dp-atom-value at) ,val) + (when *dependency-check* + (setf (dp-atom-derived-from-clause at) clause)) + ,@(if (eq 'true val) ;true assignments at front, false at end + `((setf (dp-atom-next at) assignments) + (when (null assignments) + (setf last-assignment at)) + (setf assignments at)) + `((setf (dp-atom-next at) nil) + (if (null assignments) + (setf assignments at) + (setf (dp-atom-next last-assignment) at)) + (setf last-assignment at))))))) + (resolve (val) + (cl:assert (or (eq 'true val) (eq 'false val))) + `(dolist (clause ,(if (eq 'true val) + `(dp-atom-contained-negatively-clauses atom) + `(dp-atom-contained-positively-clauses atom))) + (cond + ((eql 0 + (setf k1 (decf ,(if (eq 'true val) + `(dp-clause-number-of-unresolved-negative-literals clause) + `(dp-clause-number-of-unresolved-positive-literals clause))))) + (cond + ((eql 0 + (setf k2 ,(if (eq 'true val) + `(dp-clause-number-of-unresolved-positive-literals clause) + `(dp-clause-number-of-unresolved-negative-literals clause)))) + (when *dependency-check* + (mark-used-atoms clause)) + (undo-assignments-and-exit)) + ((eql 1 k2) + (new-unit-clause ,val)))) + ((and (eql 1 k1) + (eql 0 + ,(if (eq 'true val) + `(dp-clause-number-of-unresolved-positive-literals clause) + `(dp-clause-number-of-unresolved-negative-literals clause)))) + (new-unit-clause ,(if (eq 'true val) 'false 'true))))))) + (let ((k1 0) (k2 0) #+ignore (assignment-count 0) (assignments-done nil) + (*last-tried-atom* nil) ;used by lookahead + atom value last-assignment) + (declare (fixnum k1 k2 #+ignore assignment-count)) + (loop + (when assignments ;find last assignment + (do ((a assignments next) + (next (dp-atom-next assignments) (dp-atom-next next))) + ((null next) + (setf last-assignment a)))) + (loop + (when (null assignments) + (return)) + (setf atom assignments) + (setf assignments (dp-atom-next atom)) + (setf value (dp-atom-value atom)) + #+ignore + (incf assignment-count) + (if (eq true value) (resolve true) (resolve false)) + (setf (dp-atom-next atom) assignments-done) + (setf assignments-done atom)) + (cond ;find more assignments? + ((and compute-more-units + (multiple-value-bind (result call-again) + (funcall compute-more-units *clause-set*) + (cond + ((eq :unsatisfiable result) + (undo-assignments-and-exit t)) + (t + (unless call-again + (setf compute-more-units nil)) + (setf assignments result))))) + ) ;make the new assignments + (t + (return)))) ;no more assignments + #+ignore + (incf *assignment-count* assignment-count) + assignments-done)))) + +(defun unassign-atom (atom stop-clause) + (when *dependency-check* + (setf (dp-atom-derived-from-clause atom) nil)) + (if (eq true (dp-atom-value atom)) + (dolist (clause (dp-atom-contained-negatively-clauses atom)) + (incf (dp-clause-number-of-unresolved-negative-literals clause)) + (when (eq stop-clause clause) + (return))) + (dolist (clause (dp-atom-contained-positively-clauses atom)) + (incf (dp-clause-number-of-unresolved-positive-literals clause)) + (when (eq stop-clause clause) + (return)))) + (setf (dp-atom-value atom) nil)) + +(defun unassign-atoms (assignments) + (do ((atom assignments (dp-atom-next atom))) + ((null atom)) + (when *dependency-check* + (setf (dp-atom-derived-from-clause atom) nil)) + (if (eq true (dp-atom-value atom)) + (dolist (clause (dp-atom-contained-negatively-clauses atom)) + (incf (dp-clause-number-of-unresolved-negative-literals clause))) + (dolist (clause (dp-atom-contained-positively-clauses atom)) + (incf (dp-clause-number-of-unresolved-positive-literals clause)))) + (setf (dp-atom-value atom) nil))) + +(defun find-unit-clauses (clause-set) + ;; this is only used to find unit clauses in the initial set of clauses, + ;; assign-atoms detects and simplifies by derived unit clauses + (let ((assignments nil)) + (macrolet + ((add-assignment (atom value) + (cl:assert (or (eq 'true value) (eq 'false value))) + `(let ((atom ,atom)) + (cond + ((null atom) + (do ((a assignments (dp-atom-next a))) + ((null a)) + (setf (dp-atom-value a) nil) + (setf (dp-atom-derived-from-clause a) nil)) + (return-from find-unit-clauses :unsatisfiable)) + ((null (dp-atom-value atom)) + (setf (dp-atom-value atom) ,value) + (setf (dp-atom-derived-from-clause atom) clause) + (setf (dp-atom-next atom) assignments) + (setf assignments atom)))))) + (do ((clause (dp-clause-set-p-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (when (eql 1 (dp-clause-number-of-unresolved-positive-literals clause)) + (add-assignment (first-nonfalse-atom (dp-clause-positive-literals clause)) true))) + (do ((clause (dp-clause-set-n-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (when (eql 1 (dp-clause-number-of-unresolved-negative-literals clause)) + (add-assignment (first-nontrue-atom (dp-clause-negative-literals clause)) false)))) + assignments)) + +(defun choose-an-atom-of-a-shortest-clause* (clause-set positive option randomly) + ;; assume every clause has at least two literals + ;; return :satisfiable if there are no more (positive) clauses + (let ((shortest-length 10000) (length 0) (chosen-clause nil) + (chosen-atom nil) (nfound 0) (noccurrences 0)) + (declare (fixnum shortest-length length)) + (macrolet + ((check-clause () + `(progn + (setf length (if positive + (dp-clause-number-of-unresolved-positive-literals clause) + (+ (dp-clause-number-of-unresolved-positive-literals clause) + (dp-clause-number-of-unresolved-negative-literals clause)))) + (when (and (if (and (eq :none option) (not randomly)) + (> shortest-length length 1) + (>= shortest-length length 2)) + (not (clause-contains-true-positive-literal clause)) + (or positive (not (clause-contains-true-negative-literal clause)))) + (ecase option + (:none + (if randomly + (cond + ((eql length shortest-length) + (when (eql 0 (random (incf nfound))) + (setf chosen-clause clause))) + (t + (setf chosen-clause clause) + (setf shortest-length length) + (setf nfound 1))) + (cond + ((eql 2 length) + (return-from choose-an-atom-of-a-shortest-clause* + (cond + ((setf chosen-atom (first-unassigned-atom (dp-clause-positive-literals clause))) + (values chosen-atom true false clause)) + (t + (setf chosen-atom (first-unassigned-atom (dp-clause-negative-literals clause))) + (values chosen-atom false true clause))))) + (t + (setf chosen-clause clause) + (setf shortest-length length))))) + (:with-most-occurrences + (unless (eql length shortest-length) + (setf shortest-length length) + (setf noccurrences 0)) + (dolist (atom (dp-clause-positive-literals clause)) + (when (null (dp-atom-value atom)) + (let ((c (dp-atom-number-of-occurrences atom))) + (cond + ((and randomly (eql c noccurrences)) + (when (eql 0 (random (incf nfound))) + (setf chosen-clause clause) + (setf chosen-atom atom))) + ((> c noccurrences) + (setf chosen-clause clause) + (setf chosen-atom atom) + (setf noccurrences c) + (setf nfound 1)))))) + (unless positive + (dolist (atom (dp-clause-negative-literals clause)) + (when (null (dp-atom-value atom)) + (let ((c (dp-atom-number-of-occurrences atom))) + (cond + ((and randomly (eql c noccurrences)) + (when (eql 0 (random (incf nfound))) + (setf chosen-clause clause) + (setf chosen-atom atom))) + ((> c noccurrences) + (setf chosen-clause clause) + (setf chosen-atom atom) + (setf noccurrences c) + (setf nfound 1))))))))))))) + (do ((clause (dp-clause-set-p-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (check-clause)) + (do ((clause (dp-clause-set-m2-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (when (or (not positive) (eql 0 (dp-clause-number-of-unresolved-negative-literals clause))) + (check-clause))) + (unless positive + (do ((clause (dp-clause-set-m1-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (check-clause)) + (do ((clause (dp-clause-set-n-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (check-clause))) + (cond + (chosen-clause + (case option + (:none + (if randomly + (let ((n (random shortest-length))) + (if positive + (values (nth-unassigned-atom + n (dp-clause-positive-literals chosen-clause)) + true false chosen-clause) + (let ((m (dp-clause-number-of-unresolved-positive-literals chosen-clause))) + (if (< n m) + (values (nth-unassigned-atom + n (dp-clause-positive-literals chosen-clause)) + true false chosen-clause) + (values (nth-unassigned-atom + (- n m) (dp-clause-negative-literals chosen-clause)) + false true chosen-clause))))) + (cond + ((setf chosen-atom (first-unassigned-atom + (dp-clause-positive-literals chosen-clause))) + (values chosen-atom true false chosen-clause)) + (t + (setf chosen-atom (first-unassigned-atom + (dp-clause-negative-literals chosen-clause))) + (values chosen-atom false true chosen-clause))))) + (:with-most-occurrences + (if (or positive + (member chosen-atom + (dp-clause-positive-literals chosen-clause))) + (values chosen-atom true false chosen-clause) + (values chosen-atom false true chosen-clause))))) + ((and positive (not *minimal-models-suffice*)) + (choose-an-atom-of-a-shortest-clause* clause-set nil option randomly)) + (t + :satisfiable))))) + +(defun choose-an-atom-of-a-shortest-clause (clause-set) + (choose-an-atom-of-a-shortest-clause* clause-set nil :none nil)) + +(defun choose-an-atom-of-a-shortest-clause-randomly (clause-set) + (choose-an-atom-of-a-shortest-clause* clause-set nil :none t)) + +(defun choose-an-atom-of-a-shortest-clause-with-most-occurrences (clause-set) + (choose-an-atom-of-a-shortest-clause* clause-set nil :with-most-occurrences nil)) + +(defun choose-an-atom-of-a-shortest-clause-with-most-occurrences-randomly (clause-set) + (choose-an-atom-of-a-shortest-clause* clause-set nil :with-most-occurrences t)) + +(defun choose-an-atom-of-a-shortest-positive-clause (clause-set) + (choose-an-atom-of-a-shortest-clause* clause-set t :none nil)) + +(defun choose-an-atom-of-a-shortest-positive-clause-randomly (clause-set) + (choose-an-atom-of-a-shortest-clause* clause-set t :none t)) + +(defun choose-an-atom-of-a-shortest-positive-clause-with-most-occurrences (clause-set) + (choose-an-atom-of-a-shortest-clause* clause-set t :with-most-occurrences nil)) + +(defun choose-an-atom-of-a-shortest-positive-clause-with-most-occurrences-randomly (clause-set) + (choose-an-atom-of-a-shortest-clause* clause-set t :with-most-occurrences t)) + +(defun fix-dp-clause-set (clause-set) + ;; restores a clause-set to its original state if the user aborts out of dp-satisfiable-p + (assert-dp-clause-set-p clause-set) + (dolist (atom (dp-clause-set-atoms clause-set)) + (setf (dp-atom-value atom) nil) + (setf (dp-atom-derived-from-clause atom) nil) + (setf (dp-atom-choice-point atom) nil)) + (do ((clause (dp-clause-set-p-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (setf (dp-clause-number-of-unresolved-positive-literals clause) + (length (dp-clause-positive-literals clause)))) + (do ((clause (dp-clause-set-n-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (setf (dp-clause-number-of-unresolved-negative-literals clause) + (length (dp-clause-negative-literals clause)))) + (do ((clause (dp-clause-set-m1-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (setf (dp-clause-number-of-unresolved-positive-literals clause) 1) + (setf (dp-clause-number-of-unresolved-negative-literals clause) + (length (dp-clause-negative-literals clause)))) + (do ((clause (dp-clause-set-m2-clauses clause-set) (dp-clause-next clause))) + ((null clause)) + (setf (dp-clause-number-of-unresolved-positive-literals clause) + (length (dp-clause-positive-literals clause))) + (setf (dp-clause-number-of-unresolved-negative-literals clause) + (length (dp-clause-negative-literals clause)))) + nil) + +(defun checkpoint-dp-clause-set (clause-set) + ;; creates a checkpoint record for clause-set to allow later clause insertions to be undone + ;; and returns the level of the new checkpoint + (assert-dp-clause-set-p clause-set) + (push (list nil ;checkpointed atoms + (dp-clause-set-number-of-clauses clause-set) + (dp-clause-set-number-of-literals clause-set) + (dp-clause-set-p-clauses-last clause-set) + (dp-clause-set-n-clauses-last clause-set) + (dp-clause-set-m1-clauses-last clause-set) + (dp-clause-set-m2-clauses-last clause-set)) + (dp-clause-set-checkpoints clause-set)) + (incf (dp-clause-set-checkpoint-level clause-set))) + +(defun restore-dp-clause-set (clause-set) + ;; restores a clause-set to an earlier state undoing effects of clause insertions + (assert-dp-clause-set-p clause-set) + (cl:assert (not (eql 0 (dp-clause-set-checkpoint-level clause-set))) () + "Clause set has no checkpoint.") + (let ((l (first (dp-clause-set-checkpoints clause-set)))) + (dolist (atom (prog1 (first l) (setf (first l) nil) (setf l (rest l)))) + (restore-dp-atom atom)) + (setf (dp-clause-set-number-of-clauses clause-set) (pop l)) + (setf (dp-clause-set-number-of-literals clause-set) (pop l)) + (let ((v (pop l))) + (cond + (v + (setf (dp-clause-set-p-clauses-last clause-set) v) + (setf (dp-clause-next v) nil)) + (t + (setf (dp-clause-set-p-clauses clause-set) nil) + (setf (dp-clause-set-p-clauses-last clause-set) nil)))) + (let ((v (pop l))) + (cond + (v + (setf (dp-clause-set-n-clauses-last clause-set) v) + (setf (dp-clause-next v) nil)) + (t + (setf (dp-clause-set-n-clauses clause-set) nil) + (setf (dp-clause-set-n-clauses-last clause-set) nil)))) + (let ((v (pop l))) + (cond + (v + (setf (dp-clause-set-m1-clauses-last clause-set) v) + (setf (dp-clause-next v) nil)) + (t + (setf (dp-clause-set-m1-clauses clause-set) nil) + (setf (dp-clause-set-m1-clauses-last clause-set) nil)))) + (let ((v (first l))) + (cond + (v + (setf (dp-clause-set-m2-clauses-last clause-set) v) + (setf (dp-clause-next v) nil)) + (t + (setf (dp-clause-set-m2-clauses clause-set) nil) + (setf (dp-clause-set-m2-clauses-last clause-set) nil))))) + nil) + +(defun uncheckpoint-dp-clause-set (clause-set) + ;; removes most recent checkpoint record + ;; and returns the level of the removed checkpoint + (assert-dp-clause-set-p clause-set) + (let ((level (dp-clause-set-checkpoint-level clause-set))) + (cl:assert (not (eql 0 level)) () + "Clause set has no checkpoint.") + (let* ((level2 (- level 1)) + (checkpoint2 (dp-clause-set-checkpoints clause-set)) + (checkpoint (first checkpoint2))) + (setf checkpoint2 (first (setf (dp-clause-set-checkpoints clause-set) (rest checkpoint2)))) + (dolist (atom (first checkpoint)) + (let ((acps (dp-atom-checkpoints atom))) + (cond + ((null checkpoint2) + (setf (dp-atom-checkpoints atom) nil)) + ((eql level2 (first (second acps))) + (setf (dp-atom-checkpoints atom) (rest acps))) + (t + (push atom (first checkpoint2)) + (setf (first (first acps)) level2))))) + (setf (dp-clause-set-checkpoint-level clause-set) level2)) + level)) + +(defun checkpoint-dp-atom (atom clause-set) + (let ((level (dp-clause-set-checkpoint-level clause-set))) + (unless (eql 0 level) + (let ((checkpoints (dp-atom-checkpoints atom))) + (unless (eql level (first (first checkpoints))) ;already checkpointed + (push atom (first (first (dp-clause-set-checkpoints clause-set)))) + (setf (dp-atom-checkpoints atom) + (cons (list level + (dp-atom-contained-positively-clauses atom) + (dp-atom-contained-negatively-clauses atom) + (dp-atom-number-of-occurrences atom)) + checkpoints))))))) + +(defun restore-dp-atom (atom) + (let ((l (rest (pop (dp-atom-checkpoints atom))))) + (setf (dp-atom-contained-positively-clauses atom) (pop l)) + (setf (dp-atom-contained-negatively-clauses atom) (pop l)) + (setf (dp-atom-number-of-occurrences atom) (first l)))) + +;;; lookahead-true, lookahead-false, +;;; lookahead-true-false, lookahead-false-true +;;; can be used as more-units-function argument to dp-satisfiable-p +;;; in LDPP' to constrain search by lookahead +;;; +;;; they make trial assignments of truth values to each atom; +;;; if unit propagation demonstrates that the assignment yields an +;;; unsatisfiable set of clauses, the opposite truth value is assigned + +(defvar *verbose-lookahead* nil) +(defvar *verbose-lookahead-show-count* nil) + +(defun lookahead-true (clause-set) + ;; lookahead with true trial assignments + (lookahead* clause-set true *verbose-lookahead*)) + +(defun lookahead-false (clause-set) + ;; lookahead with false trial assignments + (lookahead* clause-set false *verbose-lookahead*)) + +(defun lookahead-true-false (clause-set) + ;; lookahead with true trial assignments, + ;; then lookahead with false trial assignments + (lookahead* clause-set :true-false *verbose-lookahead*)) + +(defun lookahead-false-true (clause-set) + ;; lookahead with false trial assignments, + ;; then lookahead with true trial assignments + (lookahead* clause-set :false-true *verbose-lookahead*)) + +(defvar values-and-passes1 (list (cons true :after-last-tried-atom) + (cons true :before-last-tried-atom))) +(defvar values-and-passes2 (list (cons false :after-last-tried-atom) + (cons false :before-last-tried-atom))) +(defvar values-and-passes3 (list (cons true :after-last-tried-atom) + (cons true :before-last-tried-atom) + (cons false :atoms-in-order))) +(defvar values-and-passes4 (list (cons false :after-last-tried-atom) + (cons false :before-last-tried-atom) + (cons true :atoms-in-order))) +(defvar values-and-passes5 (list (cons true :atoms-in-order))) +(defvar values-and-passes6 (list (cons false :atoms-in-order))) +(defvar values-and-passes7 (list (cons true :atoms-in-order) + (cons false :atoms-in-order))) +(defvar values-and-passes8 (list (cons false :atoms-in-order) + (cons true :atoms-in-order))) + +(defun lookahead* (clause-set lookahead-values verbose) + (let ((*more-units-function* nil) ;don't apply lookahead recursively + (ntrials 0)) + (when verbose + (if (null *last-tried-atom*) + (format t "~%LOOKAHEAD call ") + (format t "~% call ")) + (format t "with ~D unassigned atoms " (count-if-not #'dp-atom-value (dp-clause-set-atoms clause-set)))) + ;; initialize triable-atom slots + (cond + ((eq true lookahead-values) + (dolist (atom (dp-clause-set-atoms clause-set)) + (setf (dp-atom-true-triable atom) (null (dp-atom-value atom))))) + ((eq false lookahead-values) + (dolist (atom (dp-clause-set-atoms clause-set)) + (setf (dp-atom-false-triable atom) (null (dp-atom-value atom))))) + (t + (cl:assert (member lookahead-values '(:true-false :false-true))) + (dolist (atom (dp-clause-set-atoms clause-set)) + (setf (dp-atom-true-triable atom) (setf (dp-atom-false-triable atom) (null (dp-atom-value atom))))))) + ;; continue trying assignments in order after the last successful one in *last-tried-atom* + (dolist (value-and-pass + (if *last-tried-atom* + (cond + ((eq true lookahead-values) + values-and-passes1) + ((eq false lookahead-values) + values-and-passes2) + (t + (cond + ((eq false (dp-atom-value *last-tried-atom*)) ;trying true assignments + values-and-passes3) + (t ;trying false assignments + values-and-passes4)))) + (cond + ((eq true lookahead-values) + values-and-passes5) + ((eq false lookahead-values) + values-and-passes6) + ((eq :true-false lookahead-values) + values-and-passes7) + (t + values-and-passes8)))) + (let* ((value (car value-and-pass)) + (pass (cdr value-and-pass)) + (try-it (not (eq :after-last-tried-atom pass)))) + (dolist (atom (dp-clause-set-atoms clause-set)) + (cond + ((and (not (eq :atoms-in-order pass)) + (eq atom *last-tried-atom*)) + (if try-it + (return) + (setf try-it t))) + ((and try-it + (if (eq true value) + (dp-atom-true-triable atom) + (dp-atom-false-triable atom))) + (setf (dp-atom-value atom) value) + (setf (dp-atom-next atom) nil) + (let ((v (assign-atoms atom))) + (cond + ((eq :unsatisfiable v) + (when verbose + (when *verbose-lookahead-show-count* + (show-count (incf ntrials) t)) + (format t "derived ~A." + (if (eq true value) + (complementary-literal (dp-atom-name atom)) + (dp-atom-name atom)))) + (setf (dp-atom-value atom) (if (eq true value) false true)) + (setf (dp-atom-next atom) nil) + (setf *last-tried-atom* atom) + (return-from lookahead* (values atom t))) + (t + (when (and verbose *verbose-lookahead-show-count*) + (show-count (incf ntrials))) + (cond + ((eq true lookahead-values) + (do ((atom v (dp-atom-next atom))) + ((null atom)) + (when (eq true (dp-atom-value atom)) + (setf (dp-atom-true-triable atom) nil)))) + ((eq false lookahead-values) + (do ((atom v (dp-atom-next atom))) + ((null atom)) + (when (eq false (dp-atom-value atom)) + (setf (dp-atom-false-triable atom) nil)))) + (t + (do ((atom v (dp-atom-next atom))) + ((null atom)) + (if (eq true (dp-atom-value atom)) + (setf (dp-atom-true-triable atom) nil) + (setf (dp-atom-false-triable atom) nil))))) + (unassign-atoms v))))))))) + (when verbose + (when *verbose-lookahead-show-count* + (show-count ntrials nil t)) + (format t "failed to derive a unit clause.")) + nil)) + +(defun show-count-p (n) + (dolist (v '(100000 10000 1000 100 10) t) + (when (>= n v) + (return (eql 0 (mod n v)))))) + +(defun show-count (n &optional always neg) + (when (or always (if neg (not (show-count-p n)) (show-count-p n))) + (princ n) + (princ " "))) + +;;; routines for translating well-formed formulas (wffs) to clause form + +(defun variable-and-range-p (x) + (and (consp x) + (symbolp (first x)) + (not (null (first x))) + (variable-range (rest x)))) + +(defun variables-and-ranges-p (x) + (and (consp x) + (if (consp (first x)) + (every #'variable-and-range-p x) + (variable-and-range-p x)))) + +(defun quoteval (x &optional env) + (cond + ((consp x) + (apply (first x) (mapcar (lambda (x) (quoteval x env)) (rest x)))) + (t + (let ((v (assoc x env))) + (if v (cdr v) x))))) + +(defun variable-range (x &optional (range-term-values 'syntax-check)) + (cond + ((not (consp x)) + nil) + (t + (case (first x) + (:in ;e.g., COLOR2 :IN (LIST R G B) :EXCEPT COLOR1 + (if (eq range-term-values 'syntax-check) ;or COLOR2 :IN (LIST R G B) :AFTER COLOR1 + (and (or (consp (second x)) (symbolp (second x))) + (or (do ((l (cddr x) (cddr l))) + ((null l) + t) + (unless (and (eq :except (first l)) + (rest l) + (symbolp (second l))) + (return nil))) + (and (eq :after (first (cddr x))) + (rest (cddr x)) + (symbolp (second (cddr x))) + (null (cddddr x))))) + (cond + ((null (cddr x)) + (quoteval (second x) range-term-values)) + ((eq :after (first (cddr x))) + (rest (member (range-term-value (second (cddr x)) range-term-values x) + (quoteval (second x) range-term-values) + :test #'equal))) + (t + (let ((result nil) result-last) + (dolist (i (quoteval (second x) range-term-values)) + (do ((l (cddr x) (cddr l))) + ((null l) + (collect i result)) + (when (equal (range-term-value (second l) range-term-values x) i) + (return nil)))) + result))))) + (otherwise + nil))))) + +(defun range-term-value (x range-term-values range) + (cond + ((integerp x) + x) + (t + (let ((v (assoc x range-term-values))) + (cond + (v + (cdr v)) + (t + (error "Variable ~A has no value in range ~A." x range))))))) + +(defun expand-range-form (ranges wff range-term-values) + (let ((var (first (first ranges))) + (result nil) result-last) + (if (null (rest ranges)) + (dolist (value (variable-range (rest (first ranges)) range-term-values)) + (collect (replace-variable-by-value-in-term var value wff) result)) + (dolist (value (variable-range (rest (first ranges)) range-term-values)) + (ncollect (expand-range-form + (rest ranges) + (replace-variable-by-value-in-term var value wff) + (acons var value range-term-values)) + result))) + result)) + +(defun replace-variable-by-value-in-term (var value term) + (cond + ((consp term) + (let* ((u (car term)) + (u* (replace-variable-by-value-in-term var value u)) + (v (cdr term))) + (if (null v) + (if (eq u u*) + term + (list u*)) + (let ((v* (replace-variable-by-value-in-term var value v))) + (if (and (eq v v*) (eq u u*)) + term + (cons u* v*)))))) + ((eq var term) + value) + (t + term))) + +(defun wff-clauses (wff &optional map-fun) + ;; apply map-fun to each clause in the clause form of wff + (let ((clauses nil)) + (labels + ((wff-kind (wff) + (cond + ((consp wff) + (let ((head (first wff))) + (case head + (not + (cl:assert (eql 1 (length (rest wff))) () "Wff ~A should have one argument." wff) + head) + ((and or) + (cl:assert (<= 2 (length (rest wff))) () "Wff ~A should have two or more arguments." wff) + head) + ((implies implied-by iff xor) + (cl:assert (eql 2 (length (rest wff))) () "Wff ~A should have two arguments." wff) + head) + (if + (cl:assert (eql 3 (length (rest wff))) () "Wff ~A should have three arguments." wff) + head) + ((forall exists) + (cl:assert (eql 2 (length (rest wff))) () "Wff ~A should have two arguments." wff) + (cl:assert (variables-and-ranges-p (second wff))) + head) + (otherwise + :literal)))) + (t + :literal))) + (combine-quantifiers (wff) + (let ((quantifier (first wff)) + (ranges (if (consp (first (second wff))) (second wff) (list (second wff)))) ;(forall (x ...) ...) -> (forall ((x ...)) ...) + (form (third wff))) + (cond + ((eq quantifier (wff-kind form)) ;nesting of same quantifier + (let ((form (combine-quantifiers form))) + (list quantifier (append ranges (second form)) (third form)))) + (t + (list quantifier ranges form))))) + (wff-clauses* (wff pos lits map-fun) + (case (wff-kind wff) + (:literal + (let ((-wff (complementary-literal wff))) + (unless (eq (if pos true false) wff) + (dolist (lit lits (funcall map-fun (if (eq (if pos false true) wff) lits (cons (if pos wff -wff) lits)))) + (cond + ((equal lit wff) + (when pos + (funcall map-fun lits)) + (return)) + ((equal lit -wff) + (unless pos + (funcall map-fun lits)) + (return))))))) + (not + (wff-clauses* (second wff) (not pos) lits map-fun)) + (and + (if pos + (if (and lits (some (lambda (arg) (member arg lits :test #'equal)) (rest wff))) + (funcall map-fun lits) + (dolist (arg (rest wff)) + (wff-clauses* arg t lits map-fun))) + (wff-clauses* (second wff) nil lits (lambda (l) (wff-clauses* (if (rrrest wff) `(and ,@(rrest wff)) (third wff)) nil l map-fun))))) + (or + (if pos + (wff-clauses* (second wff) t lits (lambda (l) (wff-clauses* (if (rrrest wff) `(or ,@(rrest wff)) (third wff)) t l map-fun))) + (if (and lits (some (lambda (arg) (member (complementary-literal arg) lits :test #'equal)) (rest wff))) + (funcall map-fun lits) + (dolist (arg (rest wff)) + (wff-clauses* arg nil lits map-fun))))) + (implies + (if pos + (wff-clauses* (second wff) nil lits (lambda (l) (wff-clauses* (third wff) t l map-fun))) + (progn + (wff-clauses* (second wff) t lits map-fun) + (wff-clauses* (third wff) nil lits map-fun)))) + (implied-by + (if pos + (wff-clauses* (third wff) nil lits (lambda (l) (wff-clauses* (second wff) t l map-fun))) + (progn + (wff-clauses* (third wff) t lits map-fun) + (wff-clauses* (second wff) nil lits map-fun)))) + (iff + (if pos + (progn + (wff-clauses* (second wff) nil lits (lambda (l) (wff-clauses* (third wff) t l map-fun))) + (wff-clauses* (second wff) t lits (lambda (l) (wff-clauses* (third wff) nil l map-fun)))) + (progn + (wff-clauses* (second wff) nil lits (lambda (l) (wff-clauses* (third wff) nil l map-fun))) + (wff-clauses* (second wff) t lits (lambda (l) (wff-clauses* (third wff) t l map-fun)))))) + (xor + (if pos + (progn + (wff-clauses* (second wff) nil lits (lambda (l) (wff-clauses* (third wff) nil l map-fun))) + (wff-clauses* (second wff) t lits (lambda (l) (wff-clauses* (third wff) t l map-fun)))) + (progn + (wff-clauses* (second wff) nil lits (lambda (l) (wff-clauses* (third wff) t l map-fun))) + (wff-clauses* (second wff) t lits (lambda (l) (wff-clauses* (third wff) nil l map-fun)))))) + (if + (wff-clauses* (second wff) nil lits (lambda (l) (wff-clauses* (third wff) pos l map-fun))) + (wff-clauses* (second wff) t lits (lambda (l) (wff-clauses* (fourth wff) pos l map-fun)))) + (forall ;yields conjunction over range + (let* ((wff (combine-quantifiers wff)) + (wffs (expand-range-form (second wff) (third wff) nil))) + (cl:assert (not (null wffs)) () "Wff ~S expands into empty conjunction." wff) + (wff-clauses* (if (null (rest wffs)) (first wffs) `(and ,@wffs)) pos lits map-fun))) + (exists ;yields disjunction over range + (let* ((wff (combine-quantifiers wff)) + (wffs (expand-range-form (second wff) (third wff) nil))) + (cl:assert (not (null wffs)) () "Wff ~S expands into empty disjunction." wff) + (wff-clauses* (if (null (rest wffs)) (first wffs) `(or ,@wffs)) pos lits map-fun)))))) + (wff-clauses* wff t nil + (lambda (lits) + (if map-fun + (funcall map-fun (reverse lits)) + (push (reverse lits) clauses)))) + (nreverse clauses)))) + +(defvar *verbose-subsumption* nil) +(defvar *subsumption-show-count* nil) + +(defun dp-subsumption (clause-set &optional print-summary) + ;; eliminate subsumed clauses + ;; also add resolvents when they subsume a parent + (assert-unvalued-dp-clause-set-p clause-set) + (cl:assert (eql 0 (dp-clause-set-checkpoint-level clause-set)) () + "Cannot use subsumption on clause set that has a checkpoint.") + (let ((start-time (run-time-since 0.0)) + (changed nil) + (candidates nil) + (count 0)) + (labels + ((same-literal (clauses) + (dolist (clause2 clauses) + (let ((subsumption-mark (dp-clause-subsumption-mark clause2))) + (cond + ((null subsumption-mark) + (push clause2 candidates) + (setf (dp-clause-subsumption-mark clause2) (cons 1 0))) + ((not (eq :subsumed subsumption-mark)) + (incf (car subsumption-mark))))))) + (comp-literal (clauses) + (dolist (clause2 clauses) + (let ((subsumption-mark (dp-clause-subsumption-mark clause2))) + (cond + ((null subsumption-mark) + (push clause2 candidates) + (setf (dp-clause-subsumption-mark clause2) (cons 0 1))) + ((not (eq :subsumed subsumption-mark)) + (incf (cdr subsumption-mark))))))) + (resolve (clause clause2 &optional subsume-both) + (setf changed t) + (when *verbose-subsumption* + (if subsume-both + (format t "~%Resolve ~A with ~A subsuming both" clause clause2) + (format t "~%Resolve ~A with ~A subsuming it" clause clause2))) + (setf (dp-clause-subsumption-mark clause2) :subsumed) + (when subsume-both + (setf (dp-clause-subsumption-mark clause) :subsumed)) + (let ((poslits (dp-clause-positive-literals clause)) + (neglits (dp-clause-negative-literals clause)) + (poslits2 (dp-clause-positive-literals clause2)) + (neglits2 (dp-clause-negative-literals clause2)) + (resolvent-poslits nil) + (resolvent-neglits nil)) + (when (or (null neglits2) (null (cdr poslits))) + (psetq poslits poslits2 + neglits neglits2 + poslits2 poslits + neglits2 neglits)) + (dolist (atom poslits) + (unless (member atom neglits2) + (push atom resolvent-poslits))) + (dolist (atom poslits2) + (unless (member atom neglits) + (pushnew atom resolvent-poslits))) + (dolist (atom neglits) + (unless (member atom poslits2) + (push (list 'not atom) resolvent-neglits))) + (dolist (atom neglits2) + (unless (member atom poslits) + (pushnew (list 'not atom) resolvent-neglits :key #'second))) + (dp-insert (nconc (nreverse resolvent-poslits) (nreverse resolvent-neglits)) clause-set))) + (delete-clauses (first) + (let ((nclauses 0) (nliterals 0)) + (loop + (cond + ((null first) + (decf (dp-clause-set-number-of-clauses clause-set) nclauses) + (decf (dp-clause-set-number-of-literals clause-set) nliterals) + (return-from delete-clauses (values nil nil))) + ((eq :subsumed (dp-clause-subsumption-mark first)) + (incf nclauses) + (incf nliterals (+ (length (dp-clause-positive-literals first)) + (length (dp-clause-negative-literals first)))) + (setf first (dp-clause-next first))) + (t + (return)))) + (let* ((last first) + (next (dp-clause-next last))) + (loop + (cond + ((null next) + (decf (dp-clause-set-number-of-clauses clause-set) nclauses) + (decf (dp-clause-set-number-of-literals clause-set) nliterals) + (return-from delete-clauses (values first last))) + ((eq :subsumed (dp-clause-subsumption-mark next)) + (incf nclauses) + (incf nliterals (+ (length (dp-clause-positive-literals next)) + (length (dp-clause-negative-literals next)))) + (setf next (setf (dp-clause-next last) (dp-clause-next next)))) + (t + (setf next (dp-clause-next (setf last next))))))))) + (subsumption (clause) + (when *subsumption-show-count* + (show-count (incf count))) + (unless (eq :subsumed (dp-clause-subsumption-mark clause)) + (dolist (atom (dp-clause-positive-literals clause)) + (same-literal (rest (member clause (dp-atom-contained-positively-clauses atom)))) + (comp-literal (dp-atom-contained-negatively-clauses atom))) + (dolist (atom (dp-clause-negative-literals clause)) + (same-literal (rest (member clause (dp-atom-contained-negatively-clauses atom)))) + (comp-literal (dp-atom-contained-positively-clauses atom))) + (let ((length (+ (dp-clause-number-of-unresolved-positive-literals clause) + (dp-clause-number-of-unresolved-negative-literals clause)))) + (dolist (clause2 candidates) + (let ((same-count (car (dp-clause-subsumption-mark clause2)))) + (cond + ((eql same-count length) + (setf changed t) + (when *verbose-subsumption* + (format t "~%Subsume ~A by ~A" clause2 clause)) + (setf (dp-clause-subsumption-mark clause2) :subsumed)) + ((eql same-count (+ (dp-clause-number-of-unresolved-positive-literals clause2) + (dp-clause-number-of-unresolved-negative-literals clause2))) + (setf changed t) + (when *verbose-subsumption* + (format t "~%Subsume ~A by ~A" clause clause2)) + (setf (dp-clause-subsumption-mark clause) :subsumed))))) + (decf length) + (dolist (clause2 candidates) + (let ((subsumption-mark (dp-clause-subsumption-mark clause2))) + (unless (eq :subsumed subsumption-mark) + (setf (dp-clause-subsumption-mark clause2) nil) + (unless (or (not (eql 1 (cdr subsumption-mark))) + (eq :subsumed (dp-clause-subsumption-mark clause))) + (let ((length2 (+ (dp-clause-number-of-unresolved-positive-literals clause2) + (dp-clause-number-of-unresolved-negative-literals clause2) + -1))) + (cond + ((and (eql 0 length) (eql 0 length2)) + ) ;don't make empty resolvent + ((eql (car subsumption-mark) length) + (resolve clause clause2 (eql (car subsumption-mark) length2))) + ((eql (car subsumption-mark) length2) + (resolve clause2 clause)))))))) + (setf candidates nil))))) + (when print-summary + (format t "~&Clause set subsumption ")) + (let ((p-clauses (make-dp-clause :next (dp-clause-set-p-clauses clause-set))) + (n-clauses (make-dp-clause :next (dp-clause-set-n-clauses clause-set))) + (m1-clauses (make-dp-clause :next (dp-clause-set-m1-clauses clause-set))) + (m2-clauses (make-dp-clause :next (dp-clause-set-m2-clauses clause-set)))) + (let (next) + (loop + (if (setf next (dp-clause-next m1-clauses)) + (subsumption (setf m1-clauses next)) + (if (setf next (dp-clause-next n-clauses)) + (subsumption (setf n-clauses next)) + (if (setf next (dp-clause-next m2-clauses)) + (subsumption (setf m2-clauses next)) + (if (setf next (dp-clause-next p-clauses)) + (subsumption (setf p-clauses next)) + (return)))))))) + (when *subsumption-show-count* + (show-count count nil t)) + (when changed + (dolist (atom (dp-clause-set-atoms clause-set)) + (let ((n 0)) + (setf (dp-atom-contained-positively-clauses atom) + (delete-if (lambda (clause) + (when (eq :subsumed (dp-clause-subsumption-mark clause)) + (incf n))) + (dp-atom-contained-positively-clauses atom))) + (setf (dp-atom-contained-negatively-clauses atom) + (delete-if (lambda (clause) + (when (eq :subsumed (dp-clause-subsumption-mark clause)) + (incf n))) + (dp-atom-contained-negatively-clauses atom))) + (decf (dp-atom-number-of-occurrences atom) n))) + (multiple-value-bind (first last) + (delete-clauses (dp-clause-set-p-clauses clause-set)) + (setf (dp-clause-set-p-clauses clause-set) first) + (setf (dp-clause-set-p-clauses-last clause-set) last)) + (multiple-value-bind (first last) + (delete-clauses (dp-clause-set-n-clauses clause-set)) + (setf (dp-clause-set-n-clauses clause-set) first) + (setf (dp-clause-set-n-clauses-last clause-set) last)) + (multiple-value-bind (first last) + (delete-clauses (dp-clause-set-m1-clauses clause-set)) + (setf (dp-clause-set-m1-clauses clause-set) first) + (setf (dp-clause-set-m1-clauses-last clause-set) last)) + (multiple-value-bind (first last) + (delete-clauses (dp-clause-set-m2-clauses clause-set)) + (setf (dp-clause-set-m2-clauses clause-set) first) + (setf (dp-clause-set-m2-clauses-last clause-set) last))) + (when print-summary + (format t "took ~,1F seconds" + (run-time-since start-time)) + (cond + (changed + (princ ".") + (dp-count clause-set t)) + (t + (princ " - no change.")))) + nil))) + +;;; Examples. +;;; Clauses are represented by lists of literals. +;;; Atomic formulas can be represented by numbers > 0 or S-expressions. +;;; Example literals and their negations include +;;; 3 -3 +;;; P (NOT P) +;;; (SUBSET A B) (NOT (SUBSET A B)) +;;; Clauses are added to a set of clauses by DP-INSERT. +;;; Tautologies and duplicate literals are automatically eliminated. +;;; +;;; Formulas can be converted to clause form and inserted by DP-INSERT-WFF. +;;; +;;; DP-SATISFIABLE-P is the main function used to test a set of clauses +;;; for satisfiability. Its input is created by calls on DP-INSERT that +;;; add single clauses to a set of clauses. +;;; +;;; DP-OUTPUT-CLAUSES-TO-FILE can be used to write a set of clauses to a file. +;;; DP-SATISFIABLE-FILE-P can then be used. +;;; +;;; An alternate file format that can be specified by the :dimacs-cnf-format +;;; flag represents literals by positive or negative integers and clauses by +;;; a sequence of integers separated by zeros. For example, a file might contain +;;; 1 2 0 1 -2 0 -1 2 0 -1 -2 0 to represent the clauses (1 2) (1 -2) (-1 2) (-1 -2). +;;; This is the form used by McCune's ANL-DP for propositional problems +;;; and is also the CNF format for SAT problems suggested by DIMACS. + +(defun allways-3-problem (&rest options) + ;; all signed combinations of three propositions + ;; this is not satisfiable + ;; you can omit some of the clauses to make the set + ;; satisfiable and observe dp-satisfiable-p's behavior + (let ((clause-set (make-dp-clause-set))) + (dp-insert '(1 2 3) clause-set) + (dp-insert '(1 2 -3) clause-set) + (dp-insert '(1 -2 3) clause-set) + (dp-insert '(1 -2 -3) clause-set) + (dp-insert '(-1 2 3) clause-set) + (dp-insert '(-1 2 -3) clause-set) + (dp-insert '(-1 -2 3) clause-set) + (dp-insert '(-1 -2 -3) clause-set) +;; could have been inserted as one or more wffs instead: +;; (dp-insert-wff '(or 1 +;; (and (or 2 3) +;; (implies 3 2) +;; (implies 2 3) +;; (or (not 2) (not 3)))) +;; clause-set) +;; (dp-insert-wff '(or -1 +;; (and (or 2 3) +;; (iff 2 3) +;; (not (and 2 3)))) +;; clause-set) +;; (dp-count clause-set t) +;; (dp-clauses #'print clause-set) + (apply #'dp-satisfiable-p clause-set options))) + +(defun pigeonhole-problem (nholes &rest options) + (apply #'dp-satisfiable-p + (pigeonhole-problem-clauses nholes (if (numberp (first options)) (first options) (+ nholes 1))) + (append (if (numberp (first options)) (rest options) options) (list :dependency-check nil)))) + +(defun queens-problem (n &rest options) + (apply #'dp-satisfiable-p + (queens-problem-clauses n) + (append options (list :atom-choice-function #'choose-an-atom-of-a-shortest-positive-clause-with-most-occurrences)))) + +(defun graph-coloring-problem (colors n &rest options) + (apply #'dp-satisfiable-p + (graph-coloring-problem-clauses colors n) + options)) + +(defun pigeonhole-problem-clauses (nholes &optional (nobjects (+ nholes 1))) + (let ((clause-set (make-dp-clause-set))) + #| + (loop for i from 1 to nobjects + do (dp-insert (loop for j from 1 to nholes collect `(p ,i ,j)) clause-set)) + (loop for j from 1 to nholes + do (loop for i1 from 1 to (- nobjects 1) + do (loop for i2 from (+ i1 1) to nobjects + do (dp-insert (list `(not (p ,i1 ,j)) `(not (p ,i2 ,j))) clause-set)))) + |# + ;; the methods above and below yield the same set of clauses + (dp-insert-wff `(and + (forall (i :in (ints 1 ,nobjects)) + (exists (j :in (ints 1 ,nholes)) + (p i j))) + (forall ((j :in (ints 1 ,nholes)) + (i1 :in (ints 1 (- ,nobjects 1))) + (i2 :in (ints (+ i1 1) ,nobjects))) + (or (not (p i1 j)) (not (p i2 j))))) + clause-set) + clause-set)) + +(defun queens-problem-clauses (n) + (let ((clause-set (make-dp-clause-set))) + (loop for i from 1 to n + do (dp-insert (loop for j from 1 to n collect `(q ,i ,j)) clause-set)) + (loop for j from 1 to n + do (dp-insert (loop for i from 1 to n collect `(q ,i ,j)) clause-set)) + (loop for i from 1 to n + do (loop for j from 1 to (- n 1) + do (loop for k from (+ j 1) to n + do (dp-insert (list `(not (q ,i ,j)) `(not (q ,i ,k))) clause-set) + (dp-insert (list `(not (q ,j ,i)) `(not (q ,k ,i))) clause-set)))) + (loop for i1 from 1 to (- n 1) + do (loop for i2 from (+ i1 1) to n + as d = (- i2 i1) + do (loop for j1 from 1 to n + when (>= (- j1 d) 1) + do (dp-insert (list `(not (q ,i1 ,j1)) `(not (q ,i2 ,(- j1 d)))) clause-set) + when (<= (+ j1 d) n) + do (dp-insert (list `(not (q ,i1 ,j1)) `(not (q ,i2 ,(+ j1 d)))) clause-set)))) + clause-set)) + +(defun graph-coloring-problem-clauses (colors n) + ;; a Ramsey problem: + ;; can the edges of a complete graph with n nodes be colored + ;; with colors so that there is no isochromatic triangle? + ;; + ;; (graph-coloring-problem '(red green) 5) is solvable but + ;; (graph-coloring-problem '(red green) 6) is not + ;; + ;; (graph-coloring-problem '(red green blue) 16) is solvable but + ;; (graph-coloring-problem '(red green blue) 17) is not + ;; but this is hard to show (symmetry elimination would help) + (let ((clause-set (make-dp-clause-set))) + (dp-insert-wff `(forall ((i :in (ints 1 ,n)) + (j :in (ints (+ i 1) ,n))) + (exists (c :in (list ,@colors)) (c i j))) + clause-set) + (dp-insert-wff `(forall ((i :in (ints 1 ,n)) + (j :in (ints (+ i 1) ,n)) + (c1 :in (list ,@colors)) + (c2 :in (list ,@colors) :after c1)) + (not (and (c1 i j) (c2 i j)))) + clause-set) + (dp-insert-wff `(forall ((i :in (ints 1 ,n)) + (j :in (ints (+ i 1) ,n)) + (k :in (ints j ,n) :except j) + (c :in (list ,@colors))) + (not (and (c i j) (c i k) (c j k)))) + clause-set) +;; (dp-clauses #'print clause-set) + clause-set)) + +;;; davis-putnam3.lisp EOF diff --git a/src/deque-system.lisp b/src/deque-system.lisp new file mode 100644 index 0000000..0775d3d --- /dev/null +++ b/src/deque-system.lisp @@ -0,0 +1,38 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: deque-system.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +(defpackage :snark-deque + (:use :common-lisp :snark-lisp) + (:export + #:make-deque + #:deque? + #:deque-empty? + #:deque-first #:deque-rest #:deque-pop-first #:deque-add-first #:deque-push-first + #:deque-last #:deque-butlast #:deque-pop-last #:deque-add-last #:deque-push-last + #:deque-length + #:deque-delete + #:deque-delete-if + #:mapnconc-deque + )) + +(loads "deque2") + +;;; deque-system.lisp EOF diff --git a/src/deque2.lisp b/src/deque2.lisp new file mode 100644 index 0000000..7c3021d --- /dev/null +++ b/src/deque2.lisp @@ -0,0 +1,228 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-deque -*- +;;; File: deque2.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-deque) + +(defstruct (deque + (:predicate deque?)) + (front nil :type list) + (last-of-front nil) + (rear nil :type list) + (last-of-rear nil)) + +(defun deque-empty? (deque) + (and (null (deque-front deque)) (null (deque-rear deque)))) + +(defun deque-first (deque) + ;; returns first item in deque, nil if deque is empty + (let ((front (deque-front deque))) + (if front (first front) (deque-last-of-rear deque)))) + +(defun deque-last (deque) + ;; returns last item in deque, nil if deque is empty + (let ((rear (deque-rear deque))) + (if rear (first rear) (deque-last-of-front deque)))) + +(defun deque-rest (deque) + ;; returns new deque with first item removed, deque if it is empty + (let ((front (deque-front deque)) + (rear (deque-rear deque))) + (cond + (front + (let ((front* (rest front))) + (make-deque + :front front* + :last-of-front (if front* (deque-last-of-front deque) nil) + :rear rear + :last-of-rear (deque-last-of-rear deque)))) + (rear + (let ((front* (rest (reverse rear)))) + (make-deque + :front front* + :last-of-front (if front* (first rear) nil) + :rear nil + :last-of-rear nil))) + (t + deque)))) + +(defun deque-butlast (deque) + ;; returns new deque with last item removed, deque if it is empty + (let ((front (deque-front deque)) + (rear (deque-rear deque))) + (cond + (rear + (let ((rear* (rest rear))) + (make-deque + :rear rear* + :last-of-rear (if rear* (deque-last-of-rear deque) nil) + :front front + :last-of-front (deque-last-of-front deque)))) + (front + (let ((rear* (rest (reverse front)))) + (make-deque + :rear rear* + :last-of-rear (if rear* (first front) nil) + :front nil + :last-of-front nil))) + (t + deque)))) + +(defun deque-pop-first (deque) + ;; like deque-rest, but return first item and destructively remove it from deque + (let ((front (deque-front deque)) + (rear (deque-rear deque))) + (cond + (front + (let ((front* (rest front))) + (setf (deque-front deque) front*) + (when (null front*) + (setf (deque-last-of-front deque) nil)) + (first front))) + (rear + (let ((item (deque-last-of-rear deque)) + (front* (rest (reverse rear)))) + (setf (deque-front deque) front*) + (setf (deque-last-of-front deque) (if front* (first rear) nil)) + (setf (deque-rear deque) nil) + (setf (deque-last-of-rear deque) nil) + item)) + (t + nil)))) + +(defun deque-pop-last (deque) + ;; like deque-butlast, but return last item and destructively remove it from deque + (let ((front (deque-front deque)) + (rear (deque-rear deque))) + (cond + (rear + (let ((rear* (rest rear))) + (setf (deque-rear deque) rear*) + (when (null rear*) + (setf (deque-last-of-rear deque) nil)) + (first rear))) + (front + (let ((item (deque-last-of-front deque)) + (rear* (rest (reverse front)))) + (setf (deque-rear deque) rear*) + (setf (deque-last-of-rear deque) (if rear* (first front) nil)) + (setf (deque-front deque) nil) + (setf (deque-last-of-front deque) nil) + item)) + (t + nil)))) + +(defun deque-add-first (deque item) + ;; returns new deque with new first item added + (let ((front (deque-front deque))) + (make-deque + :front (cons item front) + :last-of-front (if front (deque-last-of-front deque) item) + :rear (deque-rear deque) + :last-of-rear (deque-last-of-rear deque)))) + +(defun deque-add-last (deque item) + ;; returns new deque with new last item added + (let ((rear (deque-rear deque))) + (make-deque + :rear (cons item rear) + :last-of-rear (if rear (deque-last-of-rear deque) item) + :front (deque-front deque) + :last-of-front (deque-last-of-front deque)))) + +(defun deque-push-first (deque item) + ;; like deque-add-first, but returns same deque with new first item added destructively + (let ((front (deque-front deque))) + (setf (deque-front deque) (cons item front)) + (when (null front) + (setf (deque-last-of-front deque) item)) + deque)) + +(defun deque-push-last (deque item) + ;; like deque-add-last, but returns same deque with new last item added destructively + (let ((rear (deque-rear deque))) + (setf (deque-rear deque) (cons item rear)) + (when (null rear) + (setf (deque-last-of-rear deque) item)) + deque)) + +(defun deque-length (deque) + (+ (length (deque-front deque)) (length (deque-rear deque)))) + +(defun deque-delete (deque item) + ;; ad hoc function to delete single occurrence of item from deque destructively + (let ((front (deque-front deque)) + (rear (deque-rear deque))) + (cond + ((and front (eql item (first front))) + (when (null (setf (deque-front deque) (rest front))) + (setf (deque-last-of-front deque) nil)) + t) + ((and rear (eql item (first rear))) + (when (null (setf (deque-rear deque) (rest rear))) + (setf (deque-last-of-rear deque) nil)) + t) + ((dotails (l front nil) + (when (and (rest l) (eql item (second l))) + (when (null (setf (rest l) (rrest l))) + (setf (deque-last-of-front deque) (first l))) + (return t)))) + ((dotails (l rear nil) + (when (and (rest l) (eql item (second l))) + (when (null (setf (rest l) (rrest l))) + (setf (deque-last-of-rear deque) (first l))) + (return t)))) + (t + nil)))) + +(defun deque-delete-if (function deque) + ;; ad hoc function to delete items from deque destructively + (let* ((deleted nil) + (front* (prog-> + (delete-if (deque-front deque) ->* item) + (when (funcall function item) + (setf deleted t))))) + (when deleted + (setf (deque-front deque) front*) + (setf (deque-last-of-front deque) (first (last front*))))) + (let* ((deleted nil) + (rear* (prog-> + (delete-if (deque-rear deque) :from-end t ->* item) + (when (funcall function item) + (setf deleted t))))) + (when deleted + (setf (deque-rear deque) rear*) + (setf (deque-last-of-rear deque) (first (last rear*))))) + deque) + +(defun mapnconc-deque (function deque &key reverse) + ;; ad hoc function to nconc results of applying function to items in deque + (let ((front (deque-front deque)) + (rear (deque-rear deque)) + (result nil) result-last) + (dolist (item (if reverse rear front)) + (if (or (null function) (eq 'list function) (eq #'list function)) + (collect item result) + (ncollect (funcall function item) result))) + (dolist (item (if reverse (reverse front) (reverse rear))) + (if (or (null function) (eq 'list function) (eq #'list function)) + (collect item result) + (ncollect (funcall function item) result))) + result)) + +;;; deque2.lisp EOF diff --git a/src/dp-refute.lisp b/src/dp-refute.lisp new file mode 100644 index 0000000..3ba94ac --- /dev/null +++ b/src/dp-refute.lisp @@ -0,0 +1,250 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: dp-refute.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim (special map-atoms-first *subsuming* *frozen-variables*)) + +(defstruct (context + (:constructor make-context (formula &optional assignment substitution)) + (:print-function print-context)) + formula + (substitution nil) + (assignment nil)) + +(defun make-context2 (formula assignment substitution) + (make-context + (simplify-formula formula assignment substitution) ;should be incremental for efficiency + assignment + substitution)) + +(defun dp-refute-p (formula) + (prog-> + (dp-refute (make-context formula) ->* substitution) + (return-from dp-refute-p (or substitution t)))) + +(defun dp-refute (cc context) + (when (trace-dp-refute?) + (dp-refute-trace context)) + (cond + ((eq true (context-formula context)) + ) ;don't do anything if formula is not falsifiable (return failed context?) + ((eq false (context-formula context)) + (funcall cc (context-substitution context))) ;succeeded + (t + (prog-> + (refute-methods context ->* x) + (ecase (first x) + + (instantiate ;extend substitution + (second x -> substitution) +;; (cl:assert (and (neq (context-substitution context) substitution) +;; (tailp (context-substitution context) substitution))) + (dp-refute + (make-context2 + (context-formula context) + (context-assignment context) + substitution) + ->* substitution) + (funcall cc substitution)) + + (split + (second x -> atom) + (third x -> value) ;refute atom-value branch first + (if (eq true value) false true -> not-value) + (when (trace-dp-refute?) + (dp-refute-trace context atom value)) + (dp-refute + (make-context2 + (context-formula context) + (cons (list atom value) (context-assignment context)) + (context-substitution context)) + ->* substitution) + (when (trace-dp-refute?) + (dp-refute-trace context atom not-value)) + (dp-refute + (make-context2 + (context-formula context) + (cons (list atom not-value) (context-assignment context)) + substitution) + ->* substitution) + (funcall cc substitution)) + + (close-branch-and-refute-other-branch + (second x -> atom) + (third x -> value) + (fourth x -> substitution) + (if (eq true value) false true -> not-value) +;; (cl:assert (and (neq (context-substitution context) substitution) +;; (tailp (context-substitution context) substitution))) + (dp-refute + (make-context2 + (context-formula context) + (cons (list atom not-value) (context-assignment context)) + substitution) + ->* substitution) + (funcall cc substitution)))))) + nil) + +(defun dp-refute-trace (context &optional atom value) + (terpri) + (dolist (x (context-assignment context)) + (declare (ignorable x)) + (princ " ")) + (cond + ((null atom) + (princ "REFUTE: ") + (print-context context)) + (t + (princ " ") + (prin1 atom) + (princ " <- ") + (prin1 value)))) + +;;; simple versions of choose-atom, refute-methods, and simplify-formula +;;; that are suitable for SNARK are given +;;; STeP will require much more sophisticated versions + +(defun choose-atom (cc context) + ;; pick any atom not already assigned a value + ;; better heuristic selection is called for + (prog-> + (context-substitution context -> substitution) + (identity map-atoms-first -> maf) + (quote t -> map-atoms-first) + (map-atoms-in-wff (context-formula context) ->* atom polarity) + (declare (ignore polarity)) + (identity maf -> map-atoms-first) + (unless (member atom (context-assignment context) :key #'car :test (lambda (x y) (equal-p x y substitution))) + (funcall cc atom) + ;; quit after finding first one + ;; STeP may require additional choices, if falsifiability depends on order in which branches are explored + (return-from choose-atom atom)))) + +(defun refute-methods (cc context) + ;; pick an atom to assign + ;; attempt to refute it by unification with a complementary assignment + ;; there will be more ways to refute atoms when theories are interpreted + (let ((assignment (context-assignment context)) + (substitution (context-substitution context))) + (prog-> + (choose-atom context ->* atom) + (quote nil -> empty-substitution-works) + (prog-> + (dolist assignment ->* x) + (first x -> atom2) + (second x -> value2) + (if (eq true value2) false true -> value) + (unify atom atom2 substitution ->* substitution2) + (when (eq substitution2 substitution) + (setf empty-substitution-works t)) + (funcall cc `(close-branch-and-refute-other-branch ,atom ,value ,substitution2))) + (unless empty-substitution-works + (funcall cc `(split ,atom ,true)))))) + +(defun simplify-formula (formula assignment substitution) + (prog-> + (map-atoms-in-wff-and-compose-result formula ->* atom polarity) + (declare (ignore polarity)) + (or (second (assoc-p atom assignment substitution)) + (instantiate atom substitution)))) + +(defun print-context (context &optional (stream *standard-output*) depth) + (declare (ignore depth)) + (format stream "#") + context) + +(defun dp-subsume* (cc wff1 wff2 subst neg) + (cond + ((if neg + (or (eq false wff2) (eq true wff1)) + (or (eq true wff2) (eq false wff1))) + (funcall cc subst)) + ((if neg + (or (eq true wff2) (eq false wff1)) + (or (eq false wff2) (eq true wff1))) + ) + (t + (prog-> + (if neg + (maximum-and-minimum-clause-lengths-neg wff1 subst) + (maximum-and-minimum-clause-lengths wff1 subst) + -> max1 min1) + (declare (ignore min1)) + (if neg + (maximum-and-minimum-clause-lengths-neg wff2 subst) + (maximum-and-minimum-clause-lengths wff2 subst) + -> max2 min2) + (declare (ignore max2)) + (when (> max1 min2) + (return-from dp-subsume*))) + (dp-refute + cc + (make-context2 + (if neg (conjoin wff2 (negate wff1)) (conjoin (negate wff2) wff1)) + nil + subst))))) + +(defun dp-subsume-constraint-alists* (cc constraint-alist1 constraint-alist2 subst) + (cond + ((null constraint-alist1) + (funcall cc subst)) + (t + (prog-> + (first constraint-alist1 -> x) + (dp-subsume* (cdr x) (or (cdr (assoc (car x) constraint-alist2)) false) subst nil ->* subst) + (dp-subsume-constraint-alists* (rest constraint-alist1) constraint-alist2 subst ->* subst) + (funcall cc subst)))) + nil) + +(defun dp-subsume (cc wff1 wff2 subst neg) + (prog-> + (identity *subsuming* -> sb) + (quote t -> *subsuming*) + (identity *frozen-variables* -> fv) ;save list of frozen variables + (variables wff2 subst fv -> *frozen-variables*) ;add wff2's variables to frozen variables + (dp-subsume* wff1 wff2 subst neg ->* subst) + (identity sb -> *subsuming*) + (identity fv -> *frozen-variables*) ;restore list of frozen variables + (funcall cc subst))) + +(defun dp-subsume+ (row1 row2) + (prog-> + (row-wff row1 -> wff1) + (row-wff row2 -> wff2) + (row-constraints row1 -> constraint-alist1) + (row-constraints row2 -> constraint-alist2) + (row-answer row1 -> answer1) + (row-answer row2 -> answer2) + + (row-variables row2 *frozen-variables* -> *frozen-variables*) + + (dp-subsume* wff1 wff2 nil nil ->* subst) + (dp-subsume-constraint-alists* constraint-alist1 constraint-alist2 subst ->* subst) + (dp-subsume* answer1 answer2 subst nil ->* subst) + (declare (ignore subst)) + (return-from dp-subsume+ t))) + +;;; dp-refute.lisp EOF diff --git a/src/dpll-system.lisp b/src/dpll-system.lisp new file mode 100644 index 0000000..10ae9df --- /dev/null +++ b/src/dpll-system.lisp @@ -0,0 +1,46 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: dpll-system.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +(defpackage :snark-dpll + (:use :common-lisp :snark-lisp) + (:export + #:dp-prover #:dp-version + #:dp-tracing #:dp-tracing-state #:dp-tracing-models #:dp-tracing-choices + #:dp-satisfiable-p #:dp-satisfiable-file-p #:make-dp-clause-set + #:dp-insert #:dp-insert-sorted #:dp-insert-wff #:dp-insert-file + #:dp-count #:dp-clauses #:dp-output-clauses-to-file #:wff-clauses + #:dp-horn-clause-set-p + #:checkpoint-dp-clause-set #:restore-dp-clause-set #:uncheckpoint-dp-clause-set + #:choose-an-atom-of-a-shortest-clause + #:choose-an-atom-of-a-shortest-clause-randomly + #:choose-an-atom-of-a-shortest-clause-with-most-occurrences + #:choose-an-atom-of-a-shortest-clause-with-most-occurrences-randomly + #:choose-an-atom-of-a-shortest-positive-clause + #:choose-an-atom-of-a-shortest-positive-clause-randomly + #:choose-an-atom-of-a-shortest-positive-clause-with-most-occurrences + #:choose-an-atom-of-a-shortest-positive-clause-with-most-occurrences-randomly + #:lookahead-true #:lookahead-false + #:lookahead-true-false #:lookahead-false-true + )) + +(loads "davis-putnam3") + +;;; dpll-system.lisp EOF diff --git a/src/equal.lisp b/src/equal.lisp new file mode 100644 index 0000000..2b9e0cb --- /dev/null +++ b/src/equal.lisp @@ -0,0 +1,115 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: equal.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; EQ suffices to compare function, relation, and variable symbols +;;; EQL suffices to compare constant symbols +;;; string constants must be term-hashed to be EQ + +(defun equal-p (x y &optional subst) + (or (eql x y) + (dereference + x subst + :if-variable (dereference y subst :if-variable (eq x y)) + :if-constant (dereference y subst :if-constant (eql x y)) + :if-compound-cons (dereference + y subst + :if-compound-cons (and (equal-p (carc x) (carc y) subst) + (equal-p (cdrc x) (cdrc y) subst))) + :if-compound-appl (dereference + y subst + :if-compound-appl + (or (eq x y) + (let ((head (heada x))) + (cond + ((neq head (heada y)) + nil) + (t + (dolist (fun (function-equal-code head) (equal-p (argsa x) (argsa y) subst)) + (let ((v (funcall fun x y subst))) + (unless (eq none v) + (return v)))))))))))) + +(defun ac-equal-p (x y subst) + (let ((fn (head x)) + (terms1 (args x)) + (terms2 (args y))) + (and (similar-argument-list-ac1-p fn terms1 terms2 subst) + (progn + (setf terms2 (cons nil (copy-list (argument-list-a1 fn terms2 subst)))) + (loop for term1 in (argument-list-a1 fn terms1 subst) + always (loop for y1 = terms2 then y2 + for y2 on (cdr terms2) + thereis (if (equal-p term1 (car y2) subst) + (rplacd y1 (cdr y2)) ;non-nil + nil))))))) + +(defun commutative-equal-p (x y subst) + (mvlet (((list* x y z) (args x)) + ((list* u v w) (args y))) + (and (or (eq z w) (equal-p z w subst)) + (cond + ((equal-p x u subst) + (equal-p y v subst)) + ((equal-p x v subst) + (equal-p y u subst)) + (t + nil))))) + +(defun associative-equal-p (x y subst) + (let ((fn (head x)) + (terms1 (args x)) + (terms2 (args y))) + (and (eql (argument-count-a1 fn terms1 subst) + (argument-count-a1 fn terms2 subst)) + (let (x y) + (loop + (cond + ((null terms1) + (return (null terms2))) + ((null terms2) + (return nil)) + (t + (setf (values x terms1) (first-and-rest-of-vector terms1 subst fn none)) + (setf (values y terms2) (first-and-rest-of-vector terms2 subst fn none)) + (unless (equal-p x y subst) + (return nil))))))))) + +(defun member-p (item list &optional subst) + (or (member item list) + (dotails (l list nil) + (when (equal-p item (first l) subst) + (return l))))) + +(defun assoc-p (item alist &optional subst) + (or (assoc item alist) + (dolist (pair alist nil) + (when (equal-p item (car pair) subst) + (return pair))))) + +(defun literal-member-p (atom polarity list) + (or (dolist (x list nil) + (when (and (eq atom (first x)) (eq polarity (second x))) + (return x))) + (dolist (x list nil) + (when (and (eq polarity (second x)) (equal-p atom (first x))) + (return x))))) + +;;; equal.lisp EOF diff --git a/src/eval.lisp b/src/eval.lisp new file mode 100644 index 0000000..a007435 --- /dev/null +++ b/src/eval.lisp @@ -0,0 +1,350 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: eval.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *polarity*) + +(defun fifo (row) + (declare (ignore row)) + (values 0 nil)) + +(defun lifo (row) + (declare (ignore row)) + (values 0 t)) + +(defun row-depth (row) + (if (row-embedding-p row) + (row-depth (row-parent row)) + (wff-depth (row-wff row)))) + +(defun row-size (row) + (if (row-embedding-p row) + (row-size (row-parent row)) + (wff-size (row-wff row)))) + +(defun row-weight (row) + (if (row-embedding-p row) + (row-weight (row-parent row)) + (wff-weight (row-wff row)))) + +(defun row-size+depth (row) + (if (row-embedding-p row) + (row-size+depth (row-parent row)) + (wff-size+depth (row-wff row)))) + +(defun row-weight+depth (row) + (if (row-embedding-p row) + (row-weight+depth (row-parent row)) + (wff-weight+depth (row-wff row)))) + +(defun row-size+depth+level (row) + (if (row-embedding-p row) + (row-size+depth+level (row-parent row)) + (+ (wff-size+depth (row-wff row)) (row-level row)))) + +(defun row-weight+depth+level (row) + (if (row-embedding-p row) + (row-weight+depth+level (row-parent row)) + (+ (wff-weight+depth (row-wff row)) (row-level row)))) + +(defun row-priority (row) + (if (row-embedding-p row) + (row-priority (row-parent row)) + (+ (let ((f (row-priority-size-factor?))) + (if (= 0 f) 0 (* f (wff-size (row-wff row))))) + (let ((f (row-priority-weight-factor?))) + (if (= 0 f) 0 (* f (wff-weight (row-wff row))))) + (let ((f (row-priority-depth-factor?))) + (if (= 0 f) 0 (* f (wff-depth (row-wff row))))) + (let ((f (row-priority-level-factor?))) + (if (= 0 f) 0 (* f (row-level row))))))) + +(defun row-wff&answer-weight+depth (row) + (if (row-embedding-p row) + (row-wff&answer-weight+depth (row-parent row)) + (+ (wff-weight+depth (row-wff row)) (wff-weight+depth (row-answer row))))) + +(defun row-neg (row) + (if (row-embedding-p row) + (row-neg (row-parent row)) + (wff-neg (row-wff row)))) + +(defun row-neg-size+depth (row) + (if (row-embedding-p row) + (row-neg-size+depth (row-parent row)) + (list (wff-neg (row-wff row)) (wff-size+depth (row-wff row))))) + +(defun row-answer-weight (row) + (weight (row-answer row))) + +(defun wff-depth (wff &optional subst &key (polarity :pos)) + (prog-> + (wff-size* wff subst polarity ->* atom subst) + (depth atom subst))) + +(defun wff-size (wff &optional subst &key (polarity :pos)) + (prog-> + (wff-size* wff subst polarity ->* atom subst) + (size atom subst))) + +(defun wff-weight (wff &optional subst &key (polarity :pos)) + (prog-> + (wff-size* wff subst polarity ->* atom subst) + (weight atom subst))) + +(defun wff-size+depth (wff &optional subst &key (polarity :pos)) + (prog-> + (wff-size* wff subst polarity ->* atom subst) + (+ (size atom subst) (depth atom subst)))) + +(defun wff-weight+depth (wff &optional subst &key (polarity :pos)) + (prog-> + (wff-size* wff subst polarity ->* atom subst) + (+ (weight atom subst) (depth atom subst)))) + +(defun wff-length (wff &optional subst &key (polarity :pos)) + (prog-> + (wff-size* wff subst polarity ->* atom subst) + (declare (ignore atom subst)) + 1)) + +(defun wff-size* (atom-size-fun wff subst *polarity*) + (dereference + wff subst + :if-variable (funcall atom-size-fun wff subst) + :if-constant (cond + ((eq true wff) + (if (eq :pos *polarity*) 1000000 0)) + ((eq false wff) + (if (eq :pos *polarity*) 0 1000000)) + (t + (funcall atom-size-fun wff subst))) + :if-compound (let* ((head (head wff)) + (kind (function-logical-symbol-p head)) + (args (args wff))) + (ecase kind + (not + (wff-size* atom-size-fun (first args) subst (opposite-polarity *polarity*))) + ((and or) + (if (if (eq 'and kind) + (eq :pos *polarity*) + (eq :neg *polarity*)) + (let ((n 1000000)) + (dolist (arg args) + (let ((m (wff-size* atom-size-fun arg subst *polarity*))) + (when (< m n) + (setf n m)))) + n) + (let ((n 0)) + (dolist (arg args) + (incf n (wff-size* atom-size-fun arg subst *polarity*))) + n))) + (implies + (if (eq :pos *polarity*) + (+ (wff-size* atom-size-fun (first args) subst :neg) + (wff-size* atom-size-fun (second args) subst :pos)) + (min (wff-size* atom-size-fun (first args) subst :pos) + (wff-size* atom-size-fun (second args) subst :neg)))) + (implied-by + (if (eq :pos *polarity*) + (+ (wff-size* atom-size-fun (second args) subst :neg) + (wff-size* atom-size-fun (first args) subst :pos)) + (min (wff-size* atom-size-fun (second args) subst :pos) + (wff-size* atom-size-fun (first args) subst :neg)))) + ((iff xor) + (let ((y (if (null (cddr args)) + (second args) + (make-compound head (rest args))))) + (if (if (eq 'iff kind) + (eq :pos *polarity*) + (eq :neg *polarity*)) + (min (+ (wff-size* atom-size-fun (first args) subst :pos) + (wff-size* atom-size-fun y subst :neg)) + (+ (wff-size* atom-size-fun (first args) subst :neg) + (wff-size* atom-size-fun y subst :pos))) + (min (+ (wff-size* atom-size-fun (first args) subst :pos) + (wff-size* atom-size-fun y subst :pos)) + (+ (wff-size* atom-size-fun (first args) subst :neg) + (wff-size* atom-size-fun y subst :neg)))))) + ((if answer-if) + (if (eq :pos *polarity*) + (min (+ (wff-size* atom-size-fun (first args) subst :neg) + (wff-size* atom-size-fun (second args) subst :pos)) + (+ (wff-size* atom-size-fun (first args) subst :pos) + (wff-size* atom-size-fun (third args) subst :pos))) + (min (+ (wff-size* atom-size-fun (first args) subst :neg) + (wff-size* atom-size-fun (second args) subst :neg)) + (+ (wff-size* atom-size-fun (first args) subst :pos) + (wff-size* atom-size-fun (third args) subst :neg))))) + ((nil) ;atomic + (funcall atom-size-fun wff subst)))))) + +(defun wff-neg (wff &optional subst) + (dereference + wff subst + :if-constant 1 + :if-variable 1 + :if-compound (case (function-logical-symbol-p (head wff)) + ((not implies implied-by iff xor if) + 0) + ((and or) + (dolist (arg (args wff) 1) + (when (eql 0 (wff-neg arg subst)) + (return 0)))) + (otherwise + 1)))) + +(defun row-argument-count-limit-exceeded (row) + (prog-> + (row-argument-count-limit? ->nonnil lim) + (quote nil -> arguments) + (map-terms-in-wff (row-wff row) ->* term polarity) + (declare (ignore polarity)) + (cond + ((member-p term arguments) + ) + ((eql 0 lim) + (return-from prog-> t)) + (t + (decf lim) + (push term arguments))))) + +(defun row-weight-limit-exceeded (row) + (let ((lim (row-weight-limit?))) + (and lim + (not (row-input-p row)) + (not (row-embedding-p row)) + (< lim (row-weight row))))) + +(defun row-weight-before-simplification-limit-exceeded (row) + (let ((lim (row-weight-before-simplification-limit?))) + (and lim + (not (row-input-p row)) + (not (row-embedding-p row)) + (< lim (row-weight row))))) + +(defun row-proof-length-limit-exceeded (row lim) + (cond + ((member (row-reason row) '(assertion assumption negated_conjecture)) + nil) + (t + (let ((lim-1 (- lim 1)) + (row-numbers (make-sparse-vector :boolean t))) + (labels + ((row-proof-length-limit-exceeded* (row) + (unless (or (member (row-reason row) '(assertion assumption negated_conjecture)) + (sparef row-numbers (row-number row))) + (cond + ((= lim-1 (sparse-vector-count row-numbers)) + (return-from row-proof-length-limit-exceeded t)) + (t + (setf (sparef row-numbers (row-number row)) t) + (map-rows-in-reason #'row-proof-length-limit-exceeded* (row-reason row))))))) + (map-rows-in-reason #'row-proof-length-limit-exceeded* (row-reason row))))))) + +(defun maximum-and-minimum-clause-lengths (wff subst) + ;; return maximum and minimum lengths of clauses in cnf expansion of wff + (dereference + wff subst + :if-variable (values 1 1) + :if-constant (values 1 1) ;special case for true and false? + :if-compound (let* ((head (head wff)) + (kind (function-logical-symbol-p head))) + (ecase kind + (not + (maximum-and-minimum-clause-lengths-neg (arg1 wff) subst)) + (and + (let ((max 0) (min 1000000)) + (prog-> + (dolist (args wff) ->* arg) + (maximum-and-minimum-clause-lengths arg subst -> max1 min1) + (setf max (max max max1)) + (setf min (min min min1))) + (values max min))) + (or + (let ((max 0) (min 0)) + (prog-> + (dolist (args wff) ->* arg) + (maximum-and-minimum-clause-lengths arg subst -> max1 min1) + (setf max (+ max max1)) + (setf min (+ min min1))) + (values max min))) + (implies + (prog-> + (args wff -> args) + (maximum-and-minimum-clause-lengths-neg (first args) subst -> max1 min1) + (maximum-and-minimum-clause-lengths (second args) subst -> max2 min2) + (values (+ max1 max2) (+ min1 min2)))) + (implied-by + (prog-> + (args wff -> args) + (maximum-and-minimum-clause-lengths-neg (second args) subst -> max1 min1) + (maximum-and-minimum-clause-lengths (first args) subst -> max2 min2) + (values (+ max1 max2) (+ min1 min2)))) + ((iff xor if answer-if) + (unimplemented)) + ((nil) + (values 1 1)))))) + +(defun maximum-and-minimum-clause-lengths-neg (wff subst) + ;; return maximum and minimum lengths of clauses in cnf expansion of wff + (dereference + wff subst + :if-variable (values 1 1) + :if-constant (values 1 1) ;special case for true and false? + :if-compound (let* ((head (head wff)) + (kind (function-logical-symbol-p head))) + (ecase kind + (not + (maximum-and-minimum-clause-lengths (arg1 wff) subst)) + (and + (let ((max 0) (min 0)) + (prog-> + (dolist (args wff) ->* arg) + (maximum-and-minimum-clause-lengths-neg arg subst -> max1 min1) + (setf max (+ max max1)) + (setf min (+ min min1))) + (values max min))) + (or + (let ((max 0) (min 1000000)) + (prog-> + (dolist (args wff) ->* arg) + (maximum-and-minimum-clause-lengths-neg arg subst -> max1 min1) + (setf max (max max max1)) + (setf min (min min min1))) + (values max min))) + (implies + (prog-> + (args wff -> args) + (maximum-and-minimum-clause-lengths (first args) subst -> max1 min1) + (maximum-and-minimum-clause-lengths-neg (second args) subst -> max2 min2) + (values (max max1 max2) (min min1 min2)))) + (implied-by + (prog-> + (args wff -> args) + (maximum-and-minimum-clause-lengths (second args) subst -> max1 min1) + (maximum-and-minimum-clause-lengths-neg (first args) subst -> max2 min2) + (values (max max1 max2) (min min1 min2)))) + ((iff xor if answer-if) + (unimplemented)) + ((nil) + (values 1 1)))))) + +;;; eval.lisp EOF diff --git a/src/feature-system.lisp b/src/feature-system.lisp new file mode 100644 index 0000000..e213106 --- /dev/null +++ b/src/feature-system.lisp @@ -0,0 +1,37 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: feature-system.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2005. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +(defpackage :snark-feature + (:use :common-lisp :snark-lisp) + (:export + #:initialize-features + #:make-feature #:declare-feature + #:declare-features-incompatible + #:feature? #:feature-parent + #:the-feature + #:delete-feature #:feature-live? + #:feature-union #:feature-subsumes? + #:print-feature-tree + )) + +(loads "feature") + +;;; feature-system.lisp EOF diff --git a/src/feature-vector-index.lisp b/src/feature-vector-index.lisp new file mode 100644 index 0000000..4e48972 --- /dev/null +++ b/src/feature-vector-index.lisp @@ -0,0 +1,157 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: feature-vector-index.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *feature-vector-row-index*) +(defvar *feature-vector-term-index*) + +(defstruct (feature-vector-index + (:include trie) + (:constructor make-feature-vector-index0) + (:copier nil)) + (entry-counter (make-counter) :read-only t) + (retrieve-generalization-calls 0 :type integer) ;forward subsumption + (retrieve-generalization-count 0 :type integer) + (retrieve-instance-calls 0 :type integer) ;backward subsumption + (retrieve-instance-count 0 :type integer)) + +(defun make-feature-vector-row-index () + (setf *feature-vector-row-index* (make-feature-vector-index0))) + +(defun make-feature-vector-term-index () + (setf *feature-vector-term-index* (make-feature-vector-index0))) + +(defun feature-vector-index-entry-number (entry) + (cond + ((row-p entry) + (row-number entry)) + (t + (tme-number entry)))) + +(defun feature-vector-index-entry-keys (entry) + (cond + ((row-p entry) + (clause-feature-vector (row-wff entry))) + (t + (atom-or-term-feature-vector (index-entry-term entry))))) + +(defun feature-vector-index-insert (entry index) + (let* ((entry# (feature-vector-index-entry-number entry)) + (keys (feature-vector-index-entry-keys entry)) + (entries (trieref index keys))) + (cond + ((null entries) + (setf (sparef (setf (trieref index keys) (make-sparse-vector)) entry#) entry) + (increment-counter (feature-vector-index-entry-counter index))) + (t + (let ((c (sparse-vector-count entries))) + (setf (sparef entries entry#) entry) + (let ((c* (sparse-vector-count entries))) + (when (< c c*) + (increment-counter (feature-vector-index-entry-counter index))))))) + nil)) + +(defun feature-vector-index-delete (entry index) + (let* ((entry# (feature-vector-index-entry-number entry)) + (keys (feature-vector-index-entry-keys entry)) + (entries (trieref index keys))) + (unless (null entries) + (let ((c (sparse-vector-count entries))) + (setf (sparef entries entry#) nil) + (let ((c* (sparse-vector-count entries))) + (when (> c c*) + (decrement-counter (feature-vector-index-entry-counter index)) + (when (= 0 c*) + (setf (trieref index keys) nil)))))) + nil)) + +(defun map-feature-vector-row-index-forward-subsumption-candidates (function row) + (prog-> + (identity *feature-vector-row-index* -> index) + (incf (feature-vector-index-retrieve-generalization-calls index)) + (map-fv-trie<= index (clause-feature-vector (row-wff row)) ->* entries) + (incf (feature-vector-index-retrieve-generalization-count index) (sparse-vector-count entries)) + (map-sparse-vector function entries))) + +(defun map-feature-vector-row-index-backward-subsumption-candidates (function row) + (prog-> + (identity *feature-vector-row-index* -> index) + (incf (feature-vector-index-retrieve-instance-calls index)) + (map-fv-trie>= index (clause-feature-vector (row-wff row)) ->* entries) + (incf (feature-vector-index-retrieve-instance-count index) (sparse-vector-count entries)) + (map-sparse-vector function entries))) + +(defun map-feature-vector-term-index-generalizations (function term &optional subst) + (prog-> + (dereference term subst :if-variable none :if-constant term :if-compound (head term) -> head) + (identity *feature-vector-term-index* -> index) + (incf (feature-vector-index-retrieve-generalization-calls index)) + (map-fv-trie<= index (atom-or-term-feature-vector term subst) ->* entries) + (map-sparse-vector entries ->* entry) + (index-entry-term entry -> term2) + (dereference term2 nil :if-variable head :if-constant term2 :if-compound (head term2) -> head2) + (when (eql head head2) + (incf (feature-vector-index-retrieve-generalization-count index)) + (funcall function entry)))) + +(defun map-feature-vector-term-index-instances (function term &optional subst) + (prog-> + (dereference term subst :if-variable none :if-constant term :if-compound (head term) -> head) + (identity *feature-vector-term-index* -> index) + (incf (feature-vector-index-retrieve-instance-calls index)) + (map-fv-trie>= index (atom-or-term-feature-vector term subst) ->* entries) + (map-sparse-vector entries ->* entry) + (index-entry-term entry -> term2) + (dereference term2 nil :if-variable none :if-constant term2 :if-compound (head term2) -> head2) + (when (or (eq none head) (eql head head2)) + (incf (feature-vector-index-retrieve-instance-count index)) + (funcall function entry)))) + +(defun print-feature-vector-index1 (index format1 format2 format3 format4) + (let ((entries-count 0)) + (prog-> + (map-trie index ->* entries) + (setf entries-count (+ entries-count (sparse-vector-count entries)))) + (mvlet (((:values current peak added deleted) (counter-values (feature-vector-index-entry-counter index)))) + (format t format1 current peak added deleted)) + (mvlet (((:values current peak added deleted) (counter-values (feature-vector-index-node-counter index)))) + (format t format2 current peak added deleted)) + (unless (eql 0 (feature-vector-index-retrieve-generalization-calls index)) + (format t format3 (feature-vector-index-retrieve-generalization-count index) (feature-vector-index-retrieve-generalization-calls index))) + (unless (eql 0 (feature-vector-index-retrieve-instance-calls index)) + (format t format4 (feature-vector-index-retrieve-instance-count index) (feature-vector-index-retrieve-instance-calls index))))) + +(defun print-feature-vector-row-index () + (print-feature-vector-index1 + *feature-vector-row-index* + "~%; Feature-vector-row-index has ~:D entr~:@P (~:D at peak, ~:D added, ~:D deleted)." + "~%; Feature-vector-row-index has ~:D node~:P (~:D at peak, ~:D added, ~:D deleted)." + "~%; Retrieved ~:D possibly forward subsuming row~:P in ~:D call~:P." + "~%; Retrieved ~:D possibly backward subsumed row~:P in ~:D call~:P.")) + +(defun print-feature-vector-term-index () + (print-feature-vector-index1 + *feature-vector-term-index* + "~%; Feature-vector-term-index has ~:D entr~:@P (~:D at peak, ~:D added, ~:D deleted)." + "~%; Feature-vector-term-index has ~:D node~:P (~:D at peak, ~:D added, ~:D deleted)." + "~%; Retrieved ~:D possibly generalization term~:P in ~:D call~:P." + "~%; Retrieved ~:D possibly instance term~:P in ~:D call~:P.")) + +;;; feature-vector-index.lisp EOF diff --git a/src/feature-vector-trie.lisp b/src/feature-vector-trie.lisp new file mode 100644 index 0000000..2b3ab1e --- /dev/null +++ b/src/feature-vector-trie.lisp @@ -0,0 +1,76 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: feature-vector-trie.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; feature vector tries are indexed by keys in ascending value +;;; where each key combines a feature number and its value + +(definline fv-trie-key (feature-number feature-value) + (+ (* (+ $fv-maximum-feature-value 1) feature-number) feature-value)) + +(definline fv-trie-key-feature (key) + (nth-value 0 (floor key (+ $fv-maximum-feature-value 1)))) + +(definline fv-trie-key-value (key) + (mod key (+ $fv-maximum-feature-value 1))) + +(defun map-fv-trie<= (function trie keys) + (labels + ((mfvt (node keys done) + (unless done + (let ((d (trie-node-data node))) + (when d + (funcall function d)))) + (when keys + (prog-> + (rest keys -> r) + (mfvt node r t) + (trie-node-branches node ->nonnil b) + (first keys -> key) + ;; map over subtries for key-feature = 1 ... key-feature = key-value + (+ key (- 1 (fv-trie-key-value key)) -> key1) + (cond + ((= key1 key) + (sparef b key ->nonnil node) + (mfvt node r nil)) + (t + (map-sparse-vector b :min key1 :max key ->* node) + (mfvt node r nil))))))) + (mfvt (trie-top-node trie) keys nil))) + +(defun map-fv-trie>= (function trie keys) + (labels + ((mfvt (node keys) + (if (null keys) + (map-trie function node) + (prog-> + (trie-node-branches node ->nonnil b) + (rest keys -> r) + (first keys -> key) + (- key (fv-trie-key-value key) -> key0) + (map-sparse-vector-with-indexes b :max (+ key0 $fv-maximum-feature-value) ->* node k) + (cond + ((< k key0) + (mfvt node keys)) + ((>= k key) + (mfvt node r))))))) + (mfvt (trie-top-node trie) keys))) + +;;; feature-vector-trie.lisp EOF diff --git a/src/feature-vector.lisp b/src/feature-vector.lisp new file mode 100644 index 0000000..0e51d3e --- /dev/null +++ b/src/feature-vector.lisp @@ -0,0 +1,153 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: feature-vector.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defconstant $fv-maximum-feature-value 999) +(defconstant $fv-features-per-symbol 10) +(defconstant $fv-offset-pos-count 0) ;number of occurrences in positive literals +(defconstant $fv-offset-neg-count 1) ;number of occurrences in negative literals +(defconstant $fv-offset-pos-max-depth 2) ;maximum depth of occurrences in positive literals +(defconstant $fv-offset-neg-max-depth 3) ;maximum depth of occurrences in negative literals +(defconstant $fv-offset-pos-min-depth 4) ;minimum depth of occurrences in positive literals (negated) +(defconstant $fv-offset-neg-min-depth 5) ;minimum depth of occurrences in negative literals (negated) +(defconstant $fv-number-ground 0) ;pseudo symbol-number for ground literal counts, doesn't match any actual symbol-number + +(declare-snark-option feature-vector-symbol-number-folding 10 10) + +(defun new-feature-vector () + (make-sparse-vector :default-value 0)) + +(defun feature-vector-list (fv) + ;; convert to list form suitable for input to trie.lisp operations + (let ((fv* nil)) + (prog-> + (map-sparse-vector-with-indexes fv :reverse t ->* v k) + (cl:assert (< 0 v)) + (setf fv* (list* (fv-trie-key k v) fv*))) + fv*)) + +(defun update-feature-vector (symbol-number relation-symbol? arity polarity count depth fv) + (let* ((symbol-number* (let ((n (feature-vector-symbol-number-folding?))) + (if n + (+ (mod symbol-number n) + (if relation-symbol? ;fold relations and functions separately + (+ 1 (case arity (0 (* 1 n)) (1 (* 2 n)) (2 (* 3 n)) (otherwise (* 4 n)))) + (+ 1 (case arity (0 (* 5 n)) (1 (* 6 n)) (2 (* 7 n)) (otherwise (* 8 n)))))) + symbol-number))) + (base (* $fv-features-per-symbol symbol-number*)) + (pos (ecase polarity (:pos t) (:neg nil)))) + (cl:assert (and (<= 1 count) (<= 0 depth))) + (cond + (relation-symbol? + (let* ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count))) + (v (sparef fv count-index)) + (v* (min $fv-maximum-feature-value (+ v count)))) + (unless (= v v*) + (setf (sparef fv count-index) v*)))) + (t + (let* ((max-depth-index (+ base (if pos $fv-offset-pos-max-depth $fv-offset-neg-max-depth))) + (v (sparef fv max-depth-index)) + (v* (min $fv-maximum-feature-value (max v depth)))) + (unless (= v v*) + (setf (sparef fv max-depth-index) v*))) + (cond + ((test-option49?) + (let* ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count))) + (v (sparef fv count-index)) + (v* (min $fv-maximum-feature-value (+ v count)))) + (unless (= v v*) + (setf (sparef fv count-index) v*)))) + (t + (let* ((min-depth-index (+ base (if pos $fv-offset-pos-min-depth $fv-offset-neg-min-depth))) + (v (sparef fv min-depth-index)) ;translate lower depths to higher feature values + (v* (max 1 (max v (- $fv-maximum-feature-value depth))))) + (unless (= v v*) + (setf (sparef fv min-depth-index) v*)) + (cond + ((and (= 0 v) (< 1 count)) + (let ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count)))) + (setf (sparef fv count-index) (min $fv-maximum-feature-value count)))) + ((< 0 v) ;don't store count for single occurrence + (let* ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count))) + (v (sparef fv count-index)) + (v* (min $fv-maximum-feature-value (if (= 0 v) (+ 1 count) (+ v count))))) + (unless (= v v*) + (setf (sparef fv count-index) v*)))))))))) + fv)) + +(defun clause-feature-vector (clause &optional subst (convert-to-list? t)) + (let ((fv (new-feature-vector))) + (prog-> + (map-atoms-in-clause clause ->* atom polarity) + (atom-feature-vector atom subst polarity fv) + (unless (test-option50?) + (when (ground-p atom subst) + (incf (sparef fv (+ $fv-number-ground (if (eq :pos polarity) $fv-offset-pos-count $fv-offset-neg-count))))))) + (if convert-to-list? (feature-vector-list fv) fv))) + +(defun atom-or-term-feature-vector (x &optional subst (convert-to-list? t)) + (let ((fv (new-feature-vector))) + (if (dereference + x subst + :if-constant (constant-boolean-valued-p x) + :if-compound-appl (function-boolean-valued-p (heada x))) + (atom-feature-vector x subst :pos fv) + (term-feature-vector x subst :pos 0 fv)) + (if convert-to-list? (feature-vector-list fv) fv))) + +(defun atom-feature-vector (atom &optional subst (polarity :pos) (fv (new-feature-vector))) + (dereference + atom subst + :if-constant (update-feature-vector (constant-number atom) t 0 polarity 1 0 fv) + :if-compound (progn + (update-feature-vector (function-number (head atom)) t (function-arity (head atom)) polarity 1 0 fv) + (mapc #'(lambda (arg) (term-feature-vector arg subst polarity 0 fv)) (args atom)))) + fv) + +(defun term-feature-vector (term &optional subst (polarity :pos) (depth 0) (fv (new-feature-vector))) + ;; in (p a (f b)), depth(p)=depth(a)=depth(f)=0, depth(b)=1 + ;; compute count of associative function symbols as if term is in unflattened form + ;; count(f)=2 for f(a,b,c) + ;; compute depth of terms with associatve function symbols as if term is in flattened form + ;; depth(a)=1 for f(f(a,b),c) + (labels + ((tfv (term depth) + (dereference + term subst + :if-constant (update-feature-vector (constant-number term) nil 0 polarity 1 depth fv) + :if-compound (prog-> + (head term -> head) + (args term -> args) + (if (function-associative head) head nil -> head-if-associative) + (if head-if-associative + (update-feature-vector (function-number head) nil (function-arity head) polarity (max (- (length args) 1) 1) depth fv) + (update-feature-vector (function-number head) nil (function-arity head) polarity 1 depth fv)) + (mapc #'(lambda (arg) + (if (and head-if-associative + (dereference + arg subst + :if-compound (and head-if-associative (eq head-if-associative (head arg))))) + (tfv arg depth) + (tfv arg (+ depth 1)))) + args))))) + (tfv term depth)) + fv) + +;;; feature-vector.lisp EOF diff --git a/src/feature.lisp b/src/feature.lisp new file mode 100644 index 0000000..17b82c5 --- /dev/null +++ b/src/feature.lisp @@ -0,0 +1,831 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-feature -*- +;;; File: feature.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-feature) + +;;; a tree of features +;;; +;;; in the tree of features, if s2 is a descendant of s1, +;;; then s1 is less deep than s2 on same branch (feature< s1 s2) +;;; and s2 is more specific than s1 (feature> s2 s1) +;;; +;;; feature expressions are single features or length>1 lists of features +;;; feature expressions are maximally specific and nonredundant; +;;; in a list of features, no feature is >= another +;;; lists of features are ordered by feature-preorder-min +;;; +;;; when combining features, the union is formed of feature expressions +;;; +;;; children of a feature can be declared to be incompatible +;;; they and their descendants cannot be used together +;;; their union is nil (bottom value denoting incompatible features) +;;; +;;; features can be deleted rendering feature expressions that contain them "not live" +;;; deleting a feature also causes deletion of its descendant (more specific) features +;;; +;;; initialize-features - creates tree of features *feature-tree* with an undeletable root feature +;;; make-feature - creates a feature, can specify name and parent and children-incompatible=t/nil +;;; declare-feature - returns or creates a feature or associates a name with a conjunction of features +;;; declare-features-incompatible - declares a pair (or larger set) of features to be incompatible +;;; feature? - returns t for single feature, nil otherwise +;;; feature-parent - returns parent of feature, nil if root +;;; the-feature - coerces name to feature, nil, warn, or error if doesn't exist or deleted +;;; delete-feature - deletes feature from tree of features +;;; feature-live? - returns feature expression arg if its features are undeleted, nil otherwise +;;; feature-union - returns union of two feature expressions, nil if incompatible +;;; feature-subsumes? - returns t if 2nd arg is more specific feature or list of features than 1st, nil otherwise +;;; print-feature-tree - prints feature tree +;;; +;;; features can be declared only once +;;; features must be declared before they are used +;;; feature incompatibilities must be declared before incompatible features are used + +(defvar *feature-tree*) + +(defstruct (feature-tree + (:copier nil)) + (root nil :read-only t) + (name-table (make-hash-table) :read-only t) + (canonical-lists (make-hash-table :test #'equal))) + +(defstruct (feature + (:constructor make-feature0 (name parent children-incompatible depth)) + (:print-function print-feature3) + (:predicate feature?) + (:copier nil)) + (name nil) + (parent nil) + (children-incompatible nil) + (depth 0 :read-only t) + (type nil) ;nil, :deleted, or (:characteristic-feature ...) + (preorder-min 0) ;feature number + (preorder-max 0) ;subfeature numbers in [preorder-min+1,preorder-max] + (children nil) + (incompatible-features nil) ;(N incompat1 ... incompatN) for 2-ary nogoods + (users-in-name-table nil) + (users-in-canonical-lists nil) + (nogoods nil) + (code nil)) + +(defstruct (feature-combo + (:constructor make-feature-combo (list)) + (:print-function print-feature-combo3) + (:predicate feature-combo?) + (:copier nil)) + (name nil) + (list nil :read-only t)) + +(defun initialize-features () + (let ((root (make-feature0 'top nil nil 0))) + (setf *feature-tree* (make-feature-tree :root root)) + (setf (gethash 'top (feature-tree-name-table *feature-tree*)) root) + (declare-feature 'characteristic-feature) + root)) + +(defun make-feature1 (name parent children-incompatible) + (let* ((tree *feature-tree*) + (root (feature-tree-root tree))) + (unless parent + (setf parent root)) + (let ((new-node (make-feature0 name parent children-incompatible (+ (feature-depth parent) 1)))) + (when name + (setf (gethash name (feature-tree-name-table tree)) new-node)) + (let ((children (feature-children parent)) (n (feature-preorder-max parent)) m) + (cond + (children + (let ((last (last children))) + (setf m (+ (feature-preorder-max (first last)) 1)) + (setf (cdr last) (list new-node)))) + (t + (setf m (+ (feature-preorder-min parent) 1)) + (setf (feature-children parent) (list new-node)))) + (cond + ((<= m n) + (setf (feature-preorder-min new-node) m) + (setf (feature-preorder-max new-node) (floor (+ m n) 2))) + (t + (feature-tree-preorder-labeling root -1)))) + new-node))) + +(defun make-feature (&key name parent children-incompatible) + ;; always makes a new feature even if one by this name already exists + (when parent + (unless (feature? parent) + (let ((parent* (and (can-be-feature-name parent nil) (the-feature parent nil)))) + (if (feature? parent*) + (setf parent parent*) + (error "There is no feature ~S." parent))))) + (when name + (if (can-be-feature-name name 'error) + (delete-feature-name name) + (setf name nil))) + (make-feature1 name parent children-incompatible)) + +(defun declare-feature (name &key parent children-incompatible iff implies new-name alias) + ;; does not make a new feature if one by this name already exists + ;; should check that parent, children-incompatible, iff definition are compatible + (can-be-feature-name name 'error) + (declare-feature-aliases + (or (and new-name (not (eq name new-name)) (rename-feature name new-name)) + (lookup-feature-name name) + (cond + ((or implies iff) + (cl:assert (not (and iff children-incompatible))) + (cl:assert (null parent)) + (let ((cf nil)) + (when implies + (cl:assert (null iff)) + (setf implies (the-feature implies 'error 'error :dont-canonize)) + ;; use implies as parent if possible + (when (feature? implies) + (return-from declare-feature + (make-feature :name name :parent implies :children-incompatible children-incompatible))) + (setf iff (cons (setf cf (make-feature :parent (or (extract-a-characteristic-feature implies) 'characteristic-feature) + :children-incompatible children-incompatible)) + (mklist implies)))) + ;; make name designate the iff feature expression (a feature or list of features) + (let ((v (the-feature iff 'error))) + (setf (gethash name (feature-tree-name-table *feature-tree*)) v) + (cond + ((feature-combo? v) + (unless (eq v (lookup-feature-name (feature-combo-name v))) + (setf (feature-combo-name v) name)) + (dolist (v (feature-combo-list v)) + (push name (feature-users-in-name-table v)))) + (t + (push name (feature-users-in-name-table v)))) + (when cf + (setf (feature-name cf) (make-symbol (to-string "*" name "*"))) + (setf (feature-type cf) (list :characteristic-feature v))) + v))) + (t + (make-feature :name name :parent parent :children-incompatible children-incompatible)))) + alias)) + +(defun declare-feature-aliases (n alias) + (mapc #'(lambda (alias) (declare-feature alias :iff n)) (mklist alias)) + n) + +(defun characteristic-feature-type (n) + (let ((type (feature-type n))) + (and (consp type) (eq :characteristic-feature (first type)) type))) + +(defun extract-a-characteristic-feature (x) + (let ((l (characteristic-feature-restriction (feature-combo-list x)))) + (cond + ((null (rest l)) + (if (characteristic-feature-type (first l)) (first l) nil)) + (t + (dolist (x l nil) + (when (and (characteristic-feature-type x) (not (feature-children-incompatible x))) + (return x))))))) + +(defun rename-feature (name new-name) + (can-be-feature-name new-name 'error) + (when (lookup-feature-name new-name) + (error "Feature name ~S is already in use." new-name)) + (let ((v (lookup-feature-name name 'error)) + (name-table (feature-tree-name-table *feature-tree*))) + (remhash name name-table) + (setf (gethash new-name name-table) v) + (cond + ((eq name (feature-name v)) + (when (feature-combo? v) + (dolist (x (feature-combo-list v)) + (setf (feature-users-in-name-table x) (nsubstitute new-name name (feature-users-in-name-table x))))) + (setf (feature-name v) new-name)) + (t + (setf (feature-users-in-name-table v) (nsubstitute new-name name (feature-users-in-name-table v))))) + v)) + +(defun delete-feature (n1) + (let* ((tree *feature-tree*) + (name-table (feature-tree-name-table tree))) + (labels + ((delete-feature1 (n) + (setf (feature-type n) :deleted) + (setf (feature-parent n) nil) + ;; delete this feature from the name table + (let ((name (feature-name n))) + (when name + (remhash name name-table) + (setf (feature-name n) nil))) + (let ((names (feature-users-in-name-table n))) + (when names + (dolist (name names) + (remhash name name-table)) + (setf (feature-users-in-name-table n) nil))) + ;; delete every canonical list that contains this feature + ;; also delete references to deleted canonical lists from this and other features + (let ((cls (feature-users-in-canonical-lists n))) + (when cls + (let ((canonical-lists (feature-tree-canonical-lists tree))) + (dolist (cl cls) + (multiple-value-bind (v found) (gethash (feature-canonical-list-key cl) canonical-lists) + (cl:assert found) + (dolist (n2 cl) + (unless (eq n n2) + (setf (feature-users-in-canonical-lists n2) (delete cl (feature-users-in-canonical-lists n2) :count 1)) + (when (null v) + (setf (feature-nogoods n2) (delete cl (feature-nogoods n2) :count 1))))) + (remhash cl canonical-lists)))) + (setf (feature-users-in-canonical-lists n) nil) + (setf (feature-nogoods n) nil))) + ;; update information about incompatible pair of features + (let ((incompat (feature-incompatible-features n))) + (when incompat + (dolist (n2 (rest incompat)) + (let* ((incompat2 (feature-incompatible-features n2)) + (c (- (first incompat2) 1))) + (if (eql 0 c) + (setf (feature-incompatible-features n2) nil) + (let ((l (rest incompat2))) + (setf (rest incompat2) (if (eq n (first l)) (rest l) (delete n l :count 1)) + (first incompat2) c))))) + (setf (feature-incompatible-features n) nil))) + (let ((children (feature-children n))) + (when children + (dolist (child children) + (delete-feature1 child)) + (setf (feature-children n) nil))))) + (cl:assert (or (feature? n1) (can-be-feature-name n1 nil))) + (let ((n (the-feature n1 nil))) + (when n + (cond + ((feature-combo? n) + (delete-feature-name n1) ;delete the name of a list of features + (dolist (x (feature-combo-list n)) ;delete its characteristic feature if there is one + (let ((v (characteristic-feature-type x))) + (when (and v (eq n (second v))) + (delete-feature x) + (return))))) + (t + (let ((parent (feature-parent n))) + (cl:assert parent) ;can't delete root node + ;; detach this feature from the tree of features + (let ((l (feature-children parent))) + (setf (feature-children parent) (if (eq n (first l)) (rest l) (delete n l :count 1)))) + ;; mark this feature and all its descendants as deleted + (delete-feature1 n)))) + t))))) + +(definline feature-deleted? (node) + (eq :deleted (feature-type node))) + +(defun can-be-feature-name (x &optional action) + (or (and x (symbolp x) (not (eq 'and x)) (not (eq 'or x)) (not (eq 'not x))) + (and action (funcall action "~S cannot be the name of a feature." x)))) + +(defun lookup-feature-name (name &optional action) + (or (gethash name (feature-tree-name-table *feature-tree*)) + (and action (funcall action "There is no feature named ~S." name)))) + +(defun delete-feature-name (name) + (let* ((name-table (feature-tree-name-table *feature-tree*)) + (v (gethash name name-table))) + (when v + (cond + ((feature-combo? v) + (when (eq name (feature-combo-name v)) + (setf (feature-combo-name v) nil)) + (dolist (x (feature-combo-list v)) + (setf (feature-users-in-name-table x) (delete name (feature-users-in-name-table x) :count 1)))) + (t + (when (eq name (feature-name v)) + (setf (feature-name v) nil)) + (setf (feature-users-in-name-table v) (delete name (feature-users-in-name-table v) :count 1)))) + (remhash name name-table)))) + +(defun the-feature (x &optional (action 'error) (action2 action) canonize-option) + ;; returns + ;; feature from its name + ;; or conjunction of features from list of names + ;; feature or feature-combo structures can be used in place of names + (flet ((the-feature0 (x) + (if (or (feature? x) (feature-combo? x)) + (feature-live? x action) + (lookup-feature-name x action)))) + (cond + ((atom x) + (the-feature0 x)) + (t + (when (eq 'and (first x)) + (setf x (rest x))) + (let ((l (the-feature (first x) action action2 :dont-canonize))) + (cond + ((null l) + (return-from the-feature nil)) + (t + (dolist (x1 (rest x)) + (let ((x1* (the-feature x1 action action2 :dont-canonize))) + (if (null x1*) + (return-from the-feature nil) + (setf l (feature-union x1* l nil))))))) + (or (feature-canonize l canonize-option) + (and action2 (funcall action2 "The conjunction of ~A~{ and ~A~} are incompatible." (first x) (rest x))))))))) + +(defun feature-tree-preorder-labeling (node n) + (setf (feature-preorder-min node) (incf n)) + (dolist (c (feature-children node)) + (setf n (feature-tree-preorder-labeling c n))) + (setf (feature-preorder-max node) (+ n 999))) + +(definline feature> (n1 n2) + ;; is n1 a descendant of n2? + (and (not (eq n1 n2)) + (>= (feature-preorder-max n2) + (feature-preorder-min n1) + (feature-preorder-min n2)))) + +(definline feature>= (n1 n2) + (or (eq n1 n2) + (>= (feature-preorder-max n2) + (feature-preorder-min n1) + (feature-preorder-min n2)))) + +(definline feature< (n1 n2) + (feature> n2 n1)) + +(definline feature<= (n1 n2) + (feature>= n2 n1)) + +(defun feature-ancestor (node &optional (n 1)) +;;(cl:assert (<= 0 n (feature-depth node))) + (dotimes (i n) + (declare (ignorable i)) + (setf node (feature-parent node))) + node) + +(definline nearest-common-feature-ancestor (node1 node2) + ;; returns the nearest common ancestor of node1 and node2 + ;; also returns the counts of declared-incompatible-features along each path + (let ((d1 (feature-depth node1)) + (d2 (feature-depth node2)) + (nincompat1 0) + (nincompat2 0)) + (cond + ((> d1 d2) + (dotimes (i (- d1 d2)) + (declare (ignorable i)) + (let ((incompat (feature-incompatible-features node1))) + (when incompat + (incf nincompat1 (first incompat)))) + (setf node1 (feature-parent node1)))) + ((< d1 d2) + (dotimes (i (- d2 d1)) + (declare (ignorable i)) + (let ((incompat (feature-incompatible-features node2))) + (when incompat + (incf nincompat2 (first incompat)))) + (setf node2 (feature-parent node2))))) + (loop + (if (eq node1 node2) + (return (values node1 nincompat1 nincompat2)) + (progn + (let ((incompat (feature-incompatible-features node1))) + (when incompat + (incf nincompat1 (first incompat)))) + (let ((incompat (feature-incompatible-features node2))) + (when incompat + (incf nincompat2 (first incompat)))) + (setf node1 (feature-parent node1) + node2 (feature-parent node2))))))) + +(defun feature-incompatible0 (s1 s2) + ;; s1 and s2 are single features + (and (not (eq s1 s2)) + (multiple-value-bind (s nincompat1 nincompat2) (nearest-common-feature-ancestor s1 s2) + (and (not (eq s s1)) + (not (eq s s2)) + (or (feature-children-incompatible s) + (and (not (eql 0 nincompat1)) + (not (eql 0 nincompat2)) + (progn + (when (> nincompat1 nincompat2) + (psetf s1 s2 s2 s1)) + (loop ;is s2 a descendant of any feature in incompat1? + (cond + ((let ((incompat (feature-incompatible-features s1))) + (and incompat + (dolist (y (rest incompat) nil) + (when (feature<= y s2) + (return t))))) + (return t)) + ((eq s (setf s1 (feature-parent s1))) + (return nil))))))))))) + +(definline feature-incompatible1 (s1 s2) + ;; s1 is single feature, s2 is nonempty list of features + (dolist (s2 s2 nil) + (when (feature-incompatible0 s1 s2) + (return t)))) + +(definline feature-incompatible2 (s1 s2) + ;; s1 and s2 are nonempty lists of features + (dolist (s1 s1 nil) + (when (feature-incompatible1 s1 s2) + (return t)))) + +(defun feature-merge1 (s1 s2 &optional (n1 (feature-preorder-min s1))) + ;; s1 is single feature, s2 is nonempty list of features that does not contain s1 + (if (< n1 (feature-preorder-min (first s2))) + (cons s1 s2) + (cons (pop s2) (if (null s2) (list s1) (feature-merge1 s1 s2 n1))))) + +(defun feature-merge2 (s1 s2 &optional (n1 (feature-preorder-min (first s1))) (n2 (feature-preorder-min (first s2)))) + ;; s1 and s2 are nonempty lists of features with no common elements + (if (< n1 n2) + (cons (pop s1) (if (null s1) s2 (feature-merge2 s2 s1 n2))) + (cons (pop s2) (if (null s2) s1 (feature-merge2 s1 s2 n1))))) + +(defun feature-set-difference (s1 s2 test) + ;; need something like this because set-difference is not guaranteed to preserve order (and doesn't in MCL) +;;(cl:assert (not (null s1))) + (labels + ((fsd (s1) + (let ((x (first s1)) + (l (rest s1))) + (if (member x s2 :test test) + (if (null l) + nil + (fsd l)) + (if (null l) + s1 + (let ((l* (fsd l))) + (if (eq l l*) + s1 + (cons x l*)))))))) + (fsd s1))) + +(definline feature-subsumes1 (s1 s2) + (let ((s1min (feature-preorder-min s1)) + (s1max (feature-preorder-max s1))) + (dotails (l s2 nil) ;(some (lambda (s2) (feature<= s1 s2)) s2) + (let ((s2 (first l)) s2min) + (cond + ((eq s1 s2) + (return l)) + ((not (<= (setf s2min (feature-preorder-min s2)) s1max)) + (return nil)) + ((<= s1min s2min) + (return l))))))) + +(definline feature-subsumes2 (s1 s2) + ;; s1 and s2 are nonempty lists of features + (and (length<= s1 s2) + (dolist (s1 s1 t) ;(subsetp s1 s2 :test #'feature<=))) + (if (or (null s2) (null (setf s2 (feature-subsumes1 s1 s2)))) + (return nil) + (setf s2 (rest s2)))))) + +(defun feature-subsumes? (s1 s2) + ;; s1 and s2 are features or lists of features + ;; handle bottom value too: return nil if s1 or s2 is nil + (and s1 + s2 + (if (feature-combo? s1) + (if (feature-combo? s2) + (feature-subsumes2 (feature-combo-list s1) (feature-combo-list s2)) + nil) ;(every (lambda (s1) (feature<= s1 s2)) s1), can't happen if s1 is nonredundant + (if (feature-combo? s2) + (and (feature-subsumes1 s1 (feature-combo-list s2)) t) + (feature<= s1 s2))))) + +(defun feature-canonical-list-key (s) + (cons (let ((n 0)) + (dolist (s s) + (setf n (logxor n (or (feature-code s) (setf (feature-code s) (random most-positive-fixnum)))))) + n) + s)) + +(defun feature-canonical-list-unkey (k) + (rest k)) + +(defun feature-canonize (s &optional option) + ;; returns nil, a feature struct, or a canonical-list-indexed feature-combo struct + (when (and (eq :incompatible option) (consp s) (rest s)) + (setf s (characteristic-feature-restriction s))) + (cond + ((null s) + nil) + ((feature? s) + (if (eq :incompatible option) (error "Cannot declare single feature ~A to be incompatible." s) s)) + ((feature-combo? s) + (if (eq :incompatible option) (error "Incompatible features already used together.") s)) + ((null (rest s)) + (if (eq :incompatible option) (error "Cannot declare single feature ~A to be incompatible." (first s)) (first s))) + ((eq :dont-canonize option) + s) + (t + (let ((table (feature-tree-canonical-lists *feature-tree*)) + (k (feature-canonical-list-key s))) + (multiple-value-bind (v found) (gethash k table) + (cond + (found + (if (and v (eq :incompatible option)) (error "Incompatible features already used together.") v)) + ;; lists of features created by feature-union are certain to be pairwise compatible + ;; check them for n-ary incompatibility + ;; inefficient test of s being subsumed by >=3-ary incompatiblity constraint + ((and (rrest s) + (let ((s* nil) (x nil)) + (and (let ((len 0) (n 0)) + (dolist (s1 s (<= 3 len)) ;find at least 3 features relevant to nogoods + (let ((y s1) (m 0)) + (loop + (let ((ngs (feature-nogoods y))) + (when ngs + (incf m (if (null (rest ngs)) 1 (length ngs))))) + (when (null (setf y (feature-parent y))) + (unless (eql 0 m) + (push s1 s*) + (incf len) + (when (or (null x) (> n m)) + (setf x s1 n m))) + (return)))))) + (let ((y x)) ;x in s* has fewest nogoods; test s* against them + (loop + (when (dolist (ng (feature-nogoods y) nil) + (when (feature-subsumes2 ng (nreverse s*)) + (return t))) + (return t)) + (when (null (setf y (feature-parent y))) + (return nil))))))) + nil) + ((eq :incompatible option) + (cond + ((null (rrest s)) + ;; add 2-ary incompatibility constraint + (let* ((n1 (first s)) + (n2 (second s)) + (incompat1 (feature-incompatible-features n1)) + (incompat2 (feature-incompatible-features n2))) + (if incompat1 + (setf (first incompat1) (+ (first incompat1) 1) (rest incompat1) (cons n2 (rest incompat1))) + (setf (feature-incompatible-features n1) (list 1 n2))) + (if incompat2 + (setf (first incompat2) (+ (first incompat2) 1) (rest incompat2) (cons n1 (rest incompat2))) + (setf (feature-incompatible-features n2) (list 1 n1)))) + nil) + (t + ;; add n-ary incompatibility constraint + (dolist (x s) + (push s (feature-nogoods x)) + (push s (feature-users-in-canonical-lists x))) + (setf (gethash k table) nil)))) + (t + (dolist (x s) + (push s (feature-users-in-canonical-lists x))) + (setf (gethash k table) (make-feature-combo s))))))))) + +(defun characteristic-feature-restriction (l) + ;; removes other features from feature list for which there are characteristic features + ;; so that restricted list can be used as shorter nogood + (remove-if (lambda (n1) + (some (lambda (n2) + (and (not (eq n1 n2)) + (let ((v (characteristic-feature-type n2))) + (and v (member n1 (feature-combo-list (second v))))))) + l)) + l)) + +(definline feature-union0 (s1 s2) + ;; s1 and s2 are single features + (cond + ((eq s1 s2) + s1) + (t + (let ((mins1 (feature-preorder-min s1)) + (mins2 (feature-preorder-min s2))) + (cond + ((< mins1 mins2) + (cond + ((<= mins2 (feature-preorder-max s1)) ;(feature> s2 s1) + s2) + ((feature-incompatible0 s1 s2) + nil) + (t + (list s1 s2)))) + (t ;(> mins2 mins1) + (cond + ((<= mins1 (feature-preorder-max s2)) ;(feature> s1 s2) + s1) + ((feature-incompatible0 s1 s2) + nil) + (t + (list s2 s1))))))))) + +(definline feature-union1 (s1 s2) + ;; s1 is single feature, s2 is nonempty list of features + (cond + ((feature-subsumes1 s1 s2) + s2) + ((null (setf s2 (remove s1 s2 :test #'feature>))) + s1) + ((feature-incompatible1 s1 s2) + nil) + (t + (feature-merge1 s1 s2)))) + +(definline feature-union2 (s1 s2) + ;; s1 and s2 are nonempty lists of features + (cond + ((null (setf s1 (feature-set-difference s1 s2 #'feature<=))) + s2) + ((null (setf s2 (feature-set-difference s2 s1 #'feature<))) + s1) + ((feature-incompatible2 s1 s2) + nil) + (t + (feature-merge2 s1 s2)))) + +(defun feature-union (s1 s2 &optional (canonize t)) + ;; s1 and s2 are features or lists of compatible features sorted by feature-preorder-min + ;; return their nonredundant union sorted by feature-preorder-min if compatible, nil if incompatible + ;; handle bottom value too: return nil if s1 or s2 is nil + (and s1 + s2 + (let ((v (if (or (consp s1) (feature-combo? s1)) + (if (or (consp s2) (feature-combo? s2)) + (feature-union2 (if (consp s1) s1 (feature-combo-list s1)) (if (consp s2) s2 (feature-combo-list s2))) + (feature-union1 s2 (if (consp s1) s1 (feature-combo-list s1)))) + (if (or (consp s2) (feature-combo? s2)) + (feature-union1 s1 (if (consp s2) s2 (feature-combo-list s2))) + (feature-union0 s1 s2))))) + (cond + ((atom v) + v) + ((null (rest v)) + (first v)) + ((and (feature-combo? s1) (eq (feature-combo-list s1) v)) + s1) + ((and (feature-combo? s2) (eq (feature-combo-list s2) v)) + s2) + ((not canonize) + v) + (t + (feature-canonize v)))))) + +(defun feature-live? (s &optional action) + ;; returns s if s is undeleted feature or list of undeleted features, nil otherwise + (and s + (if (feature-combo? s) + (dolist (s (feature-combo-list s) t) + (when (feature-deleted? s) + (return (and action (funcall action "Feature ~A has been deleted." s))))) + (or (not (feature-deleted? s)) + (and action (funcall action "Feature ~A has been deleted." s)))) + s)) + +(defun declare-features-incompatible (n1 n2 &rest more) + (the-feature (list* n1 n2 more) 'error nil :incompatible)) + +(defun unthe-feature (x) + ;; inverse of the-feature: + ;; if x is composed of named features, + ;; creates an expression such that (the-feature expr) = x + (cond + ((feature? x) + (feature-name x)) + ((feature-combo? x) + (or (let ((name (feature-combo-name x))) + (and name (symbol-package name) name)) ;don't return uninterned symbols created by feature-sym + (let ((l nil)) + (dolist (x (characteristic-feature-restriction (feature-combo-list x)) (if (null (rest l)) (first l) (cons 'and (nreverse l)))) + (let ((v (characteristic-feature-type x))) + (if (setf v (if v (feature-combo-name (second v)) (feature-name x))) + (setf l (cons v l)) + (return nil))))))) + (t + nil))) + +(defun feature-sym (x) + (cond + ((feature? x) + (feature-name x)) + ((feature-combo? x) + (or (feature-combo-name x) + (let ((expr (unthe-feature x))) + (if (atom expr) expr (setf (feature-combo-name x) (make-symbol (apply 'to-string (second expr) (mapcan #'(lambda (x) (list "&" x)) (rrest expr))))))))) + (t + nil))) + +(defun print-feature3 (node stream depth) + (declare (ignore depth)) + (let ((n node) (l nil)) + (loop + (cond + ((null n) + (print-unreadable-object (node stream :type t :identity nil) + (format stream "~S~{ ~S~}" (first l) (rest l))) + (return)) + ((feature-name n) + (if (null l) + (format stream "~A" (feature-name n)) + (print-unreadable-object (node stream :type t :identity nil) + (format stream "~S~{ ~S~}" (feature-name n) l))) + (return)) + (t + (push (feature-preorder-min n) l) + (setf n (feature-parent n))))))) + +(defun print-feature-combo3 (x stream depth) + (declare (ignore depth)) + (let ((name (feature-sym x))) + (if name + (princ name stream) + (print-unreadable-object (x stream :type t :identity nil) + (format stream "~S~{ ~S~}" (first (feature-combo-list x)) (rest (feature-combo-list x))))))) + +(defun print-feature (n) + (prin1 (or (feature-name n) (feature-preorder-min n))) + n) + +(defun print-feature-list (l) + (print-feature (first l)) + (dolist (x (rest l)) + (princ " and ") + (print-feature x)) + l) + +(defun print-feature-tree (&key node numbers) + (labels + ((print-node (n) + (terpri) + (when numbers + (format t "[~9D,~9D] " (feature-preorder-min n) (feature-preorder-max n))) + (let ((depth (if node (- (feature-depth n) (feature-depth node)) (feature-depth n)))) + (unless (eql 0 depth) + (dotimes (i depth) + (princ (if (eql 0 (mod i 5)) (if (eql 0 i) " " "| ") ": "))))) + (print-feature n) + (when (feature-children-incompatible n) + (princ ", with incompatible children")) + (let ((incompat (feature-incompatible-features n))) + (when (and incompat (< 0 (first incompat))) + (princ ", incompatible with ") + (print-feature-list (rest incompat)))) + (dolist (child (feature-children n)) + (print-node child))) + (print-defn (name defn) + (terpri) + (prin1 name) + (princ " is defined as ") + (cond + ((feature-combo? defn) + (princ "the conjunction of ") + (print-feature-list (feature-combo-list defn))) + (t + (print-feature defn))) + (princ "."))) + (let ((tree *feature-tree*)) + (unless (or (null node) (feature? node)) + (let ((node* (and (can-be-feature-name node 'warn) (the-feature node 'warn)))) + (cond + ((feature-combo? node*) + (print-defn node node*) + (return-from print-feature-tree)) + (t + (setf node node*))))) + (print-node (or node (feature-tree-root tree))) + (let ((l nil)) + (maphash (lambda (k v) + (let ((s (feature-canonical-list-unkey k))) + (when (and (null v) (implies node (some (lambda (x) (feature<= node x)) s))) + (push s l)))) + (feature-tree-canonical-lists tree)) + (when l + (terpri) + (dolist (k l) + (terpri) + (princ "The conjunction of ") + (print-feature-list k) + (princ " is incompatible.")))) + (let ((l nil)) + (maphash (lambda (name v) + (when (if (feature-combo? v) + (implies node (some (lambda (x) (feature<= node x)) (feature-combo-list v))) + (and (not (eq name (feature-name v))) (implies node (feature<= node v)))) + (push (cons name v) l))) + (feature-tree-name-table tree)) + (when l + (terpri) + (dolist (v (sort l #'string< :key #'car)) + (print-defn (car v) (cdr v)))))))) + +;;; feature.lisp EOF diff --git a/src/functions.lisp b/src/functions.lisp new file mode 100644 index 0000000..084b558 --- /dev/null +++ b/src/functions.lisp @@ -0,0 +1,414 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: functions.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim (special *subsuming*)) + +(defvar *name*) + +(defstruct (function-symbol + (:constructor make-function-symbol0 (name arity)) + (:copier nil) + (:print-function print-function-symbol) + (:conc-name :function-)) + (name nil) + (arity nil :read-only t) + (number nil) + (hash-code (make-atom-hash-code) :read-only t) + (boolean-valued-p nil) + (constructor nil) + (injective nil) + (magic t) ;nil means don't make magic-set goal for this relation + (allowed-in-answer t) + (kbo-weight 1) + (weight 1) + (constraint-theory nil) + (sort (top-sort)) + (argument-sort-alist nil) + (logical-symbol-p nil) + (logical-symbol-dual nil) + (polarity-map nil) ;list of unary functions to compute polarity of arguments + (ordering-status nil) ;:left-to-right, :right-to-left, :multiset, or :ac comparison of argument lists + (make-compound*-function nil) + (input-code nil) + (weight-code nil) + (satisfy-code nil) ;Lisp functions for making atoms headed by this relation true + (falsify-code nil) ;Lisp functions for making atoms headed by this relation false + (paramodulate-code nil) ;Lisp functions for paramodulating terms headed by this function + (rewrite-code nil) ;Lisp functions for rewriting terms headed by this function + (equality-rewrite-code nil) ;Lisp functions for rewriting equality of two terms headed by this function + (arithmetic-relation-rewrite-code nil) ;Lisp functions for rewriting equality of a number and an arithmetic term + (sort-code nil) ;Lisp functions for computing sort of a term + (equal-code nil) + (variant-code nil) + (unify-code nil) + (associative nil) + (commutative nil) +;;(idempotent nil) ;unifiable terms may have different heads +;;(inverse nil) ;unifiable terms may have different heads + (identity none) ;unifiable terms may have different heads (none means no identity) + (index-type nil) + (rewritable-p nil) ;if nil, no rewrite rule exists with this symbol as lhs head + #+ignore (canonical-variants (make-sparse-vector)) ;for instance-graphs + #+ignore (instance-graph ;for instance-graphs + (make-instance-graph + :name (to-string "for " *name*))) + #+ignore (term-memory-entries (make-sparse-vector)) ;for instance-graphs + (plist nil)) ;property list for more properties + +(define-plist-slot-accessor function :locked) +(define-plist-slot-accessor function :documentation) +(define-plist-slot-accessor function :author) +(define-plist-slot-accessor function :source) +(define-plist-slot-accessor function :code-name0) +(define-plist-slot-accessor function :macro) +(define-plist-slot-accessor function :complement) ;complement of the symbol P is the symbol ~P +(define-plist-slot-accessor function :skolem-p) +(define-plist-slot-accessor function :created-p) +(define-plist-slot-accessor function :to-lisp-code) +(define-plist-slot-accessor function :rewrites) +(define-plist-slot-accessor function :injective-supplied) +(define-plist-slot-accessor function :do-not-resolve) +(define-plist-slot-accessor function :do-not-factor) +(define-plist-slot-accessor function :do-not-paramodulate) +(define-plist-slot-accessor function :keep-head) ;keep (fn) and (fn arg) instead of identity and arg respectively + +(definline function-rpo-status (fn) + (or (function-ordering-status fn) (rpo-status?))) + +(definline function-kbo-status (fn) + (or (function-ordering-status fn) (kbo-status?))) + +(defun make-function-symbol (name arity) + (let* ((*name* name) + (fn (make-function-symbol0 name arity))) + (setf (function-number fn) (funcall *standard-eql-numbering* :lookup fn)) + fn)) + +(defun function-kind (fn) + (cond + ((function-logical-symbol-p fn) + :logical-symbol) + ((function-boolean-valued-p fn) + :relation) + (t + :function))) + +(defun function-has-arity-p (fn arity) + (let ((a (function-arity fn))) + (or (eql arity a) (eq :any a) (function-associative fn)))) + +(defun function-identity2 (fn) + (if (and *subsuming* (not (test-option45?))) none (function-identity fn))) + +(defun function-name-lessp (x y) + (string< x y)) + +(defun function-name-arity-lessp (fn1 fn2) + (let ((name1 (function-name fn1)) + (name2 (function-name fn2))) + (and (string<= name1 name2) + (implies (string= name1 name2) + (let ((arity1 (function-arity fn1))) + (and (numberp arity1) + (let ((arity2 (function-arity fn2))) + (and (numberp arity2) (< arity1 arity2))))))))) + +#+ignore +(defun right-identity-e-term-rewriter (term subst) + ;; function-rewrite-code example + ;; (fn x e) -> x + (mvlet (((list x y) (args term))) + (if (equal-p y 'e subst) x none))) ;return value or none + +#+ignore +(defun right-identity-e-term-paramodulater (cc term subst) + ;; function-paramodulate-code example + ;; (fn x y) -> x after unifying y with e + (prog-> + (args term -> (list x y)) + (unify y 'e subst ->* subst) + (funcall cc x subst))) ;call cc with value and substitution + +(defmacro set-function-code (code) + (let ((code-supplied (intern (to-string code :-supplied) :snark)) + (function-code (intern (to-string :function- code) :snark))) + `(when ,code-supplied + (setf (,function-code symbol) + (if (listp ,code) + (remove-duplicates ,code :from-end t) ;replace + (cons ,code (remove ,code (,function-code symbol)))))))) ;add + +(defun declare-function-symbol0 (symbol + &key + new-name + alias + sort + locked + (documentation nil documentation-supplied) + (author nil author-supplied) + (source nil source-supplied) + (macro nil macro-supplied) + (weight nil weight-supplied) + (allowed-in-answer nil allowed-in-answer-supplied) + (ordering-status nil ordering-status-supplied) + (constructor nil constructor-supplied) + (injective nil injective-supplied) + (skolem-p nil skolem-p-supplied) + (created-p nil created-p-supplied) + (kbo-weight nil kbo-weight-supplied) + (complement nil complement-supplied) + (magic t magic-supplied) + (constraint-theory nil constraint-theory-supplied) + (polarity-map nil polarity-map-supplied) + (make-compound*-function nil make-compound*-function-supplied) + (input-code nil input-code-supplied) + (to-lisp-code nil to-lisp-code-supplied) + (weight-code nil weight-code-supplied) + (rewrite-code nil rewrite-code-supplied) + (equality-rewrite-code nil equality-rewrite-code-supplied) + (arithmetic-relation-rewrite-code nil arithmetic-relation-rewrite-code-supplied) + (sort-code nil sort-code-supplied) + (equal-code nil equal-code-supplied) + (variant-code nil variant-code-supplied) + (unify-code nil unify-code-supplied) + (paramodulate-code nil paramodulate-code-supplied) + (satisfy-code nil satisfy-code-supplied) + (falsify-code nil falsify-code-supplied) + (associative nil associative-supplied) + (commutative nil commutative-supplied) + (identity nil identity-supplied) + (index-type nil index-type-supplied) + (infix nil infix-supplied) + (do-not-resolve nil do-not-resolve-supplied) + (do-not-factor nil do-not-factor-supplied) + (do-not-paramodulate nil do-not-paramodulate-supplied) + (keep-head nil keep-head-supplied) + ) + (cl:assert (implies satisfy-code-supplied (eq :relation (function-kind symbol)))) + (cl:assert (implies falsify-code-supplied (eq :relation (function-kind symbol)))) + (cl:assert (implies constructor-supplied (eq :function (function-kind symbol)))) + (cl:assert (implies skolem-p-supplied (eq :function (function-kind symbol)))) + (cl:assert (implies complement-supplied (eq :relation (function-kind symbol)))) + (cl:assert (implies magic-supplied (eq :relation (function-kind symbol)))) + (cl:assert (implies polarity-map-supplied (eq :logical-symbol (function-kind symbol)))) + (cl:assert (implies constraint-theory-supplied (or (eq :function (function-kind symbol)) (eq :relation (function-kind symbol))))) + (cl:assert (implies associative-supplied (and (member (function-kind symbol) '(:function :logical-symbol)) + (member (function-arity symbol) '(2 :any))))) + (cl:assert (implies identity-supplied (member (function-kind symbol) '(:function :logical-symbol)))) + (cl:assert (implies (and kbo-weight-supplied (consp kbo-weight)) (eql (function-arity symbol) (length (rest kbo-weight))))) + ;; doesn't do anything if no keywords are supplied + (when new-name + (rename-function-symbol symbol new-name)) + (when alias + (create-aliases-for-symbol symbol alias)) + (when sort + (declare-function-sort symbol sort)) + (when locked + (setf (function-locked symbol) locked)) ;once locked, stays locked + (set-slot-if-supplied function documentation) + (set-slot-if-supplied function author) + (set-slot-if-supplied function source) + (set-slot-if-supplied function macro) + (set-slot-if-supplied function weight) + (set-slot-if-supplied function allowed-in-answer) + (set-slot-if-supplied function ordering-status) + (set-slot-if-supplied function constructor) + (cond + (injective-supplied + (setf (function-injective symbol) injective) + (setf (function-injective-supplied symbol) t)) + ((and constructor (not (function-injective-supplied symbol))) + (setf (function-injective symbol) t))) ;declare constructors to be injective unless explicitly declared otherwise + (set-slot-if-supplied function skolem-p) + (set-slot-if-supplied function created-p) + (set-slot-if-supplied function kbo-weight) + (set-slot-if-supplied function complement) + (set-slot-if-supplied function magic) + (set-slot-if-supplied function constraint-theory) + (set-slot-if-supplied function polarity-map) + (set-slot-if-supplied function make-compound*-function) + (set-function-code input-code) ;first non-none result of function call is returned + (set-function-code to-lisp-code) ;first non-none result of function call is returned + (set-function-code weight-code) ;first non-none result of function call is returned + (set-function-code rewrite-code) ;first non-none result of function call is returned + (set-function-code equality-rewrite-code) ;first non-none result of function call is returned + (set-function-code arithmetic-relation-rewrite-code) ;first non-none result of function call is returned + (set-function-code sort-code) ;first non-none result of function call is returned + (when associative-supplied + (when associative ;can't undeclare it + (declare-function-associative symbol))) + (when commutative-supplied + (when commutative ;can't undeclare it + (declare-function-commutative symbol))) + (set-function-code equal-code) ;first non-none result of function call is returned + (set-function-code variant-code) ;all functions called with continuation + (set-function-code unify-code) ;all functions called with continuation + (set-function-code paramodulate-code) ;all functions called with continuation + (set-function-code satisfy-code) ;all functions called with continuation + (set-function-code falsify-code) ;all functions called with continuation + (when identity-supplied + (unless (eq none identity) + (cond + ((equal '(function) identity) ;e.g., use (bag-union) as identity for bag-union function + (setf identity (make-compound symbol))) + (t + (setf identity (declare-constant identity)))) + (setf (function-identity symbol) identity))) + (set-slot-if-supplied function index-type) + (set-slot-if-supplied function do-not-resolve) + (set-slot-if-supplied function do-not-factor) + (set-slot-if-supplied function do-not-paramodulate) + (set-slot-if-supplied function keep-head) + (when (and (function-constructor symbol) (or (function-associative symbol) (function-commutative symbol))) + (setf (function-injective symbol) nil)) + (when (and (neq none (function-identity symbol)) (function-associative symbol)) + (let ((rewrite-code-supplied t) + (paramodulate-code-supplied t) + (rewrite-code 'associative-identity-rewriter) + (paramodulate-code 'associative-identity-paramodulater)) + (set-function-code rewrite-code) + (set-function-code paramodulate-code))) + (cl:assert (implies (consp (function-kbo-weight symbol)) + (and (member (function-kbo-status symbol) '(:left-to-right :right-to-left)) + (not (function-associative symbol))))) + (when infix-supplied + (declare-operator-syntax (string (function-name symbol)) + (first infix) ;one of :xfx, :xfy, :yfx, :yfy, :fx, :fy, :xf, :yf + (second infix) ;numerical precedence + (function-name symbol))) + symbol) + +(defun declare-function-symbol1 (symbol keys-and-values) + (cond + ((null keys-and-values) + symbol) + (t + (apply 'declare-function-symbol0 + symbol + (cond + ((and (function-locked symbol) (eq none (getf keys-and-values :locked none))) + (changeable-keys-and-values + symbol + keys-and-values + (if (function-logical-symbol-p symbol) '(:alias) (changeable-properties-of-locked-function?)))) + (t + keys-and-values)))))) + +(defun declare-function (name arity &rest keys-and-values) + (declare (dynamic-extent keys-and-values)) + (declare-function-symbol1 (input-function-symbol name arity) keys-and-values)) + +(defun declare-relation (name arity &rest keys-and-values) + (declare (dynamic-extent keys-and-values)) + (declare-function-symbol1 (input-relation-symbol name arity) keys-and-values)) + +(defun declare-logical-symbol (name &rest keys-and-values) + (declare-function-symbol1 (input-logical-symbol name t) `(,@keys-and-values :locked t))) + +(defun declare-function-associative (function) + (setf (function-associative function) t) +;;(setf (function-input-code function) (cons (lambda (h a p) (require-n-or-more-arguments h a p 2)) (function-input-code function))) + (cond + ((function-commutative function) + (declare-function-symbol0 + function + :ordering-status :ac + :equal-code (cons 'ac-equal-p (remove 'commutative-equal-p (function-equal-code function))) + :variant-code (cons 'variant-bag (remove 'variant-commute (function-variant-code function))) + :unify-code (cons 'ac-unify (remove 'commutative-unify (function-unify-code function))) + :index-type nil)) + (t + (declare-function-symbol0 + function +;; :ordering-status :ac + :equal-code 'associative-equal-p + :variant-code 'variant-vector + :unify-code 'associative-unify + :index-type nil))) +;;(check-associative-function-sort function) + nil) + +(defun declare-function-commutative (function) + (setf (function-commutative function) t) + (cond + ((function-associative function) + (declare-function-symbol0 + function + :ordering-status :ac + :equal-code (cons 'ac-equal-p (remove 'associative-equal-p (function-equal-code function))) + :variant-code (cons 'variant-bag (remove 'variant-vector (function-variant-code function))) + :unify-code (cons 'ac-unify (remove 'associative-unify (function-unify-code function))) + :index-type nil)) + (t + (declare-function-symbol0 + function + :ordering-status :commutative + :equal-code 'commutative-equal-p + :variant-code 'variant-commute + :unify-code 'commutative-unify + :index-type :commute))) + nil) + +(defun function-code-name (symbol) + (or (function-code-name0 symbol) + (setf (function-code-name0 symbol) (intern (to-string :code-for- (function-name symbol)) :keyword)))) + +(defun function-resolve-code (fn v) + (cond + ((or (eq true v) (eq :neg v)) + (function-satisfy-code fn)) + (t + (cl:assert (or (eq false v) (eq :pos v))) + (function-falsify-code fn)))) + +(defun declare-function1 (name arity &rest options) + (apply 'declare-function name arity + `(,@options + :locked t))) + +(defun declare-function2 (name arity &rest options) + (apply 'declare-function name arity + `(,@options + ;; :unify-code (dont-unify) ;omitted in 20120808r008 + :do-not-paramodulate t + :locked t))) + +(defun declare-relation1 (name arity &rest options) + (apply 'declare-relation name arity + `(:sort nil ;ignore sort declarations + ,@options + :locked t + :magic nil))) + +(defun declare-relation2 (name arity &rest options) + (apply 'declare-relation name arity + `(,@options + :do-not-resolve t + :do-not-factor t + :locked t + :magic nil))) + +(defun declare-characteristic-relation (name pred sort &rest options) + (apply 'declare-relation2 name 1 + `(,@options + :rewrite-code ,(make-characteristic-atom-rewriter pred sort)))) + +;;; functions.lisp EOF diff --git a/src/globals.lisp b/src/globals.lisp new file mode 100644 index 0000000..c962f23 --- /dev/null +++ b/src/globals.lisp @@ -0,0 +1,352 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: globals.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *snark-globals* + (nconc (mapcar 'first snark-lisp::*clocks*) + (mapcar 'second snark-lisp::*clocks*) + '( + snark-lisp::*clocks* + snark-lisp::*excluded-clocks* + snark-lisp::*first-real-time-value* + snark-lisp::*first-run-time-value* + snark-lisp::*last-run-time-value* + snark-lisp::*run-time-mark* + snark-lisp::*total-seconds* + snark-infix-reader::*infix-operators* + snark-infix-reader::*prefix-operators* + snark-infix-reader::*postfix-operators* + *nonce* + *outputting-comment* + snark-lisp::*running-clocks* + snark-feature::*feature-tree* + *standard-eql-numbering* + + *cons* + *singleton-bag* + *bag-union* + *=* + *not* + *and* + *or* + *implies* + *implied-by* + *iff* + *xor* + *if* + *forall* + *exists* + *answer-if* + *date-point* + *utime-point* + *date-interval* + *utime-interval* + + *a-function-with-left-to-right-ordering-status* + *a-function-with-multiset-ordering-status* + *agenda* + *agenda-of-backward-simplifiable-rows-to-process* + *agenda-of-false-rows-to-process* + *agenda-of-input-rows-to-give* + *agenda-of-input-rows-to-process* + *agenda-of-new-embeddings-to-process* + *agenda-of-rows-to-give* + *agenda-of-rows-to-process* + *assert-rewrite-polarity* + *assertion-analysis-function-info* + *assertion-analysis-patterns* + *assertion-analysis-relation-info* + *atom-hash-code* + *conditional-answer-connective* + *constant-info-table* + *constraint-rows* + *current-row-context* + *cycl-data* + *cycl-read-action-table* + *cycl-read-actionn-table* + *date-interval-primitive-relations* + *date-day-function* + *date-hour-function* + *date-minute-function* + *date-month-function* + *date-scenario-constant* + *date-second-function* + *date-year-function* + *date-year-function2* + *default-hash-term-set-count-down-to-hashing* + *dp-sort-intersections* + *dr-universal-time-function-symbol* + *embedding-variables* + *extended-variant* + *false-rows* + *feature-vector-row-index* + *feature-vector-term-index* + *find-else-substitution* + *finish-time-function-symbol* + *form-author* + *form-documentation* + *form-name* + *form-source* + *frozen-variables* + *gensym-variable-alist* + *hint-rows* + *hints-subsumed* + *input-proposition-variables* + *input-wff-substitution2* + *input-wff-new-antecedents* + *less* + *manual-ordering-results* + *new-symbol-prefix* + *new-symbol-table* + *next-variable-number* + *nonce* + *number-info-table* + *number-of-new-symbols* + *path-index* + *pp-margin* + *pp?* + *print-pretty2* + *processing-row* + *product* + *proof* + *propositional-abstraction-of-input-wffs* + *propositional-abstraction-term-to-lisp* + *reciprocal* + *renumber-by-sort* + *renumber-first-number* + *renumber-ignore-sort* + *rewrite-count-warning* + *rewrites-used* + *root-row-context* + *row-count* + *row-names* + *rowsets* + *rows* + *skolem-function-alist* + *snark-is-running* + *string-info-table* + *subsuming* + *sum* + *symbol-ordering* + *symbol-table* + *szs-conjecture* + *szs-filespec* + *term-by-hash-array* + *term-memory* + *terpri-indent* + *trie-index* + *unify-special* + *variables* + *world-path-function-alist* + clause-subsumption + critique-options + it + *last-row-number-before-interactive-operation* + map-atoms-first + modal-input-wff + *number-of-agenda-full-deleted-rows* + *number-of-backward-eliminated-rows* + *number-of-given-rows* + *number-of-rows* + *%checking-well-sorted-p%* + *%check-for-well-sorted-atom%* + options-have-been-critiqued + options-print-mode + ordering-is-total + recursive-unstore + *%rewrite-count%* + rewrite-strategy + rewrites-initialized + *simplification-ordering-compare-equality-arguments-hash-table* + subsumption-mark + *top-sort* + + + ;LDPP' + dp-tracing + dp-tracing-choices + dp-tracing-models + dp-tracing-state + *assignment-count* + *default-atom-choice-function* + *default-atom-cost-function* + *default-branch-limit* + *default-convert-to-clauses* + *default-cost-bound* + *default-cost-bound-function* + *default-dependency-check* + *default-dimacs-cnf-format* + *default-find-all-models* + *default-minimal-models-only* + *default-minimal-models-suffice* + *default-model-test-function* + *default-more-units-function* + *default-print-summary* + *default-print-warnings* + *default-pure-literal-check* + *default-time-limit* + *default-subsumption* + *dp-start-time* + *subsumption-show-count* + *verbose-lookahead* + *verbose-lookahead-show-count* + *verbose-subsumption* + ))) + +(defvar *snark-nonsave-globals* + '( + *%assoc-cache-special-item%* + *prog->-function-second-forms* + *prog->-special-forms* + + $number-of-variable-blocks + $number-of-variables-per-block + $number-of-variables-in-blocks + + $fv-features-per-symbol + $fv-maximum-feature-value + $fv-offset-neg-count + $fv-offset-neg-max-depth + $fv-offset-neg-min-depth + $fv-offset-pos-count + $fv-offset-pos-max-depth + $fv-offset-pos-min-depth + $fv-number-ground + + *all-both-polarity* + *check-for-disallowed-answer* + *hash-dollar-package* + *hash-dollar-readtable* + *hash-term-not-found-action* + *hash-term-only-computes-code* + *hash-term-uses-variable-numbers* + *input-wff* ;bound only by input-wff + *printing-deleted-messages* + *redex-path* ;bound only by rewriter + *resolve-functions-used* + *rewriting-row-context* ;bound only for rewriter + *rpo-cache* ;bound only by rpo-compare-terms-top + *rpo-cache-numbering* ;bound only by rpo-compare-terms-top + *ac-rpo-cache* ;bound only by rpo-compare-terms-top + *snark-globals* + *snark-nonsave-globals* + *snark-options* + *tptp-environment-variable* + *tptp-format* + *tptp-input-directory* + *tptp-input-directory-has-domain-subdirectories* + *tptp-input-file-type* + *tptp-output-directory* + *tptp-output-directory-has-domain-subdirectories* + *tptp-output-file-type* + + rcc8-jepd-relation-names + rcc8-more-relation-names + time-ip-jepd-relation-names + time-pp-jepd-relation-names + time-ii-jepd-relation-names + time-pi-jepd-relation-names + time-ip-more-relation-names + time-pp-more-relation-names + time-ii-more-relation-names + time-pi-more-relation-names + + $rcc8-composition-table *rcc8-composition-table* + $time-iii-composition-table *time-iii-composition-table* + $time-iip-composition-table + $time-ipi-composition-table *time-ipi-composition-table* + $time-ipp-composition-table + $time-pii-composition-table *time-pii-composition-table* + $time-pip-composition-table *time-pip-composition-table* + $time-ppi-composition-table *time-ppi-composition-table* + $time-ppp-composition-table *time-ppp-composition-table* + $rcc8-relation-code + $time-ii-relation-code + $time-ip-relation-code + $time-pi-relation-code + $time-pp-relation-code + + dp-prover + dp-version + false + float-internal-time-units-per-second + initialization-functions + none + true + )) + +;;; more than one copy of SNARK can be run alternately +;;; by using SUSPEND-SNARK and RESUME-SNARK +;;; +;;; SUSPEND-SNARK re-initializes SNARK so the run can be continued +;;; only after RESUME-SNARK; a suspended SNARK can only be resumed once +;;; +;;; SUSPEND-SNARK saves the values of SNARK's global variables; +;;; RESUME-SNARK restores them +;;; +;;; SUSPEND-AND-RESUME-SNARK suspends the current SNARK and resumes +;;; another without unnecessarily re-initializing + +(defun suspend-snark* () + (let ((state (gensym))) + (setf (symbol-value state) + (mapcar (lambda (var) + (cons var + (if (boundp var) + (symbol-value var) + '%unbound%))) + *snark-globals*)) + state)) + +(defun resume-snark (state) + (let ((l (and (boundp state) (symbol-value state)))) + (cond + ((consp l) + (setf (symbol-value state) nil) + (mapc (lambda (x) + (if (eq '%unbound% (cdr x)) + (makunbound (car x)) + (setf (symbol-value (car x)) (cdr x)))) + l)) + (t + (error "Cannot resume SNARK from state ~S." state))) + nil)) + +(defun suspend-snark () + (prog1 + (suspend-snark*) + (initialize))) + +(defun suspend-and-resume-snark (state) + (prog1 + (suspend-snark*) + (resume-snark state))) + +(defun audit-snark-globals () + ;; used for suspend/resume to make sure all necessary values are saved; + ;; prints names of symbols that might have been overlooked + (dolist (package-name '(:snark-lisp :snark)) + (let ((package (find-package package-name))) + (do-symbols (x package) + (when (and (boundp x) (eq package (symbol-package x))) + (unless (or (member x *snark-globals*) (member x *snark-nonsave-globals*)) + (print x))))))) + +;;; globals.lisp EOF diff --git a/src/infix-operators.lisp b/src/infix-operators.lisp new file mode 100644 index 0000000..d9f9490 --- /dev/null +++ b/src/infix-operators.lisp @@ -0,0 +1,105 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-infix-reader -*- +;;; File: infix-operators.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-infix-reader) + +(defvar *infix-operators* nil) +(defvar *prefix-operators* nil) +(defvar *postfix-operators* nil) + +(defparameter infix-types '(:xfx :xfy :yfx :yfy)) +(defparameter prefix-types '(:fx :fy)) +(defparameter postfix-types '(:xf :yf)) + +(defstruct (operator + (:copier nil)) + (input-string nil :read-only t) + (type nil :read-only t) + (precedence nil :read-only t) + (output-symbol nil :read-only t)) + +(definline infix-operator-p (op) + (and (operator-p op) (member (operator-type op) infix-types))) + +(definline prefix-operator-p (op) + (and (operator-p op) (member (operator-type op) prefix-types))) + +(definline postfix-operator-p (op) + (and *postfix-operators* (operator-p op) (member (operator-type op) postfix-types))) + +(defun initialize-operator-syntax () + (setf *infix-operators* nil) + (setf *prefix-operators* nil) + (setf *postfix-operators* nil)) + +(definline operator-lookup0 (input-string list) + (dolist (op list nil) + (when (string= input-string (operator-input-string op)) + (return op)))) + +(definline infix-operator-lookup (input-string) + (operator-lookup0 input-string *infix-operators*)) + +(definline prefix-operator-lookup (input-string) + (operator-lookup0 input-string *prefix-operators*)) + +(definline postfix-operator-lookup (input-string) + (operator-lookup0 input-string *postfix-operators*)) + +(defun update-operator-syntax (input-string op listname) + (let ((l (remove input-string (symbol-value listname) :key #'operator-input-string :test #'string=))) + (setf (symbol-value listname) (if op (cons op l) l)))) + +(defun declare-operator-syntax (input-string type &optional (precedence nil precedence-supplied) (output-symbol input-string)) + ;; (declare-operator-syntax "<=>" :xfy 505) declares <=> as a type xfy operator with precedence 505 + ;; (declare-operator-syntax "<=>" :xfy nil) undeclares <=> as a type xfy operator + ;; (declare-operator-syntax "<=>" nil) undeclares <=> as any kind of operator + (if (null type) + (cl:assert (null precedence)) + (progn + (cl:assert (or (member type infix-types) (member type prefix-types) (member type postfix-types))) + (cl:assert precedence-supplied) + (cl:assert (implies precedence (integerp precedence))))) + (unless (stringp input-string) + (setf input-string (string input-string))) + (unless (implies (and type precedence) (symbolp output-symbol)) + (setf output-symbol (intern (string output-symbol)))) + (let ((op (and type precedence (make-operator :input-string input-string :type type :precedence precedence :output-symbol output-symbol)))) + (cond + ((member type infix-types) + (update-operator-syntax input-string op '*infix-operators*)) + ((member type prefix-types) + (update-operator-syntax input-string op '*prefix-operators*)) + ((member type postfix-types) + (update-operator-syntax input-string op '*postfix-operators*)) + (t + (update-operator-syntax input-string op '*infix-operators*) + (update-operator-syntax input-string op '*prefix-operators*) + (update-operator-syntax input-string op '*postfix-operators*))) + op)) + +(definline reduce-before? (op1 op2) + (let ((p1 (operator-precedence op1)) + (p2 (operator-precedence op2))) + (or (< p1 p2) + (and (eql p1 p2) + (member (operator-type op2) '(:yfx :yfy :yf)) + (member (operator-type op1) '(:xfx :yfx :fx)))))) + +;;; infix-operators.lisp EOF diff --git a/src/infix-reader-system.lisp b/src/infix-reader-system.lisp new file mode 100644 index 0000000..2ce4ce7 --- /dev/null +++ b/src/infix-reader-system.lisp @@ -0,0 +1,31 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: infix-reader-system.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2004. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +(defpackage :snark-infix-reader + (:use :common-lisp :snark-lisp) + (:export + #:initialize-operator-syntax #:declare-operator-syntax + #:tokenize #:read-infix-term + #:--)) + +(loads "infix-operators" "infix-reader") + +;;; infix-reader-system.lisp EOF diff --git a/src/infix-reader.lisp b/src/infix-reader.lisp new file mode 100644 index 0000000..7447b6f --- /dev/null +++ b/src/infix-reader.lisp @@ -0,0 +1,441 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-infix-reader -*- +;;; File: infix-reader.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-infix-reader) + +;;; no operator should be declared to be both infix and postfix +;;; to ease parsing as in ISO Prolog standard + +;;; = + (but first character cannot be a digit) +;;; = [] + + for floats +;;; [] + + for ratios +;;; [] + for integers + +(definline ordinary-char-p (char) + (or (alpha-char-p char) + (digit-char-p char) + (eql #\_ char) + (eql #\? char) ;for SNARK variables + (eql #\$ char))) ;for builtins + +(definline separator-char-p (char) + (or (eql #\, char) ;comma is not an operator + (eql #\( char) + (eql #\) char) + (eql #\[ char) + (eql #\] char) + (eql #\. char))) ;dot is not an operator + +(definline whitespace-char-p (char) + (or (eql #\space char) + (eql #\tab char) + (eql #\newline char) + (eql #\return char) + (eql #\linefeed char) + (eql #\page char))) + +(definline quotation-char-p (char) + (or (eql #\" char) + (eql #\' char))) + +(definline comment-char-p (char) + (eql #\% char)) + +(defun tokenize1 (stream &key (case :preserve) (upper-case-var-prefix #\?) rationalize) + (labels + ((tokenize-identifier (ch) + (let ((chars (list ch))) + (loop + (cond + ((eq :eof (setf ch (read-char stream nil :eof))) + (return)) + ((ordinary-char-p ch) + (push ch chars)) + (t + (unread-char ch stream) + (return)))) + (setf chars (nreverse chars)) + ;; so that variables can be distingished from nonvariables even after upcasing + ;; if upper-case-var-prefix is a character such as #\? + ;; tokenize adds it to the front of each identifier that starts with + ;; either an upper-case character + ;; or one or more of it followed by an alphabetic character + ;; (read-infix-term "r(x,?,?1,X,?X,??X)") -> (R X ? ?1 ?X ??X ???X) + (when (and upper-case-var-prefix + (or (upper-case-p (first chars)) + (and (eql upper-case-var-prefix (first chars)) + (dolist (c (rest chars) nil) + (cond + ((alpha-char-p c) + (return t)) + ((not (eql upper-case-var-prefix c)) + (return nil))))))) + (setf chars (cons upper-case-var-prefix chars))) + (operator-lookup + (ecase (if (and (eql #\$ (first chars)) (rest chars) (eql #\$ (second chars))) + (readtable-case *readtable*) ; use Lisp reader case for $$ words so that $$sum is read as $$SUM if reader upcases + case) + (:preserve (coerce chars 'string)) + (:invert (if (iff (some #'upper-case-p chars) (some #'lower-case-p chars)) (coerce chars 'string) (map 'string #'char-invert-case chars))) + (:upcase (if (notany #'lower-case-p chars) (coerce chars 'string) (map 'string #'char-upcase chars))) + (:downcase (if (notany #'upper-case-p chars) (coerce chars 'string) (map 'string #'char-downcase chars))))))) + (tokenize-special (ch) + (let ((chars (list ch))) + (loop + (cond + ((eq :eof (setf ch (read-char stream nil :eof))) + (return)) + ((and (not (ordinary-char-p ch)) + (not (separator-char-p ch)) + (not (whitespace-char-p ch)) + (not (quotation-char-p ch)) + (not (comment-char-p ch))) + (push ch chars)) + (t + (unread-char ch stream) + (return)))) + (operator-lookup (coerce (nreverse chars) 'string)))) + (tokenize-number (ch) + (let ((num (digit-char-p ch)) (n 0) (d 1) cv float ratio (exponent nil)) + (loop + (cond + ((eq :eof (setf ch (read-char stream nil :eof))) + (return)) + ((setf cv (digit-char-p ch)) + (cond + (float + (setf n (+ (* 10 n) cv) d (* 10 d))) + (ratio + (setf n (+ (* 10 n) cv))) + (t + (setf num (+ (* 10 num) cv))))) + ((and (not (or float ratio)) (eql #\. ch)) + (setf float t)) + ((and (not (or float ratio)) (eql #\/ ch)) + (setf ratio t)) + ((and (not ratio) (or (eql #\E ch) (eql #\e ch))) + (setf exponent (tokenize-exponent)) + (return)) + (t + (unread-char ch stream) + (return)))) + (cond + (float + (setf num (+ num (/ n d)))) + (ratio + (setf num (/ num n)))) + (when exponent + (setf num (* num (expt 10 exponent)))) + (when (and float (not rationalize)) + (setf num (float num))) + num)) + (tokenize-exponent () + (let ((negative nil) (exponent 0) ch cv) + (cond + ((eq :eof (setf ch (read-char stream nil :eof))) + (return-from tokenize-exponent nil)) + ((setf cv (digit-char-p ch)) + (setf exponent cv)) + ((eql #\- ch) + (setf negative t)) + ((eql #\+ ch) + ) + (t + (unread-char ch stream) + (return-from tokenize-exponent nil))) + (loop + (cond + ((eq :eof (setf ch (read-char stream nil :eof))) + (return)) + ((setf cv (digit-char-p ch)) + (setf exponent (+ (* 10 exponent) cv))) + (t + (unread-char ch stream) + (return)))) + (if negative (- exponent) exponent))) + (tokenize-string (quotechar) + (let ((chars nil) ch) + (loop + (cond + ((eql quotechar (setf ch (read-char stream t))) + (setf chars (nreverse chars)) + (return (ecase quotechar + (#\" + (coerce chars 'string)) + (#\' + ;; any characters can be put into a symbol by using '...' quotation + ;; this suppresses default case mangling, var-prefixing, and operator lookup + ;; to disambiguate tokenization of ? and '?' etc. + ;; '?...' is tokenized as |^A?...| that is later replaced by ($$quote ?...) + (cond + ((and chars + (or (eql upper-case-var-prefix (first chars)) + (eql (code-char 1) (first chars)))) + (make-symbol (coerce (cons (code-char 1) chars) 'string))) + (t + (intern (coerce chars 'string)))))))) + ((eql #\\ ch) + (push (read-char stream t) chars)) + (t + (push ch chars)))))) + (operator-lookup (name) + ;; return an operator interpretation if there is one + ;; we can lookup the correct interpretation later + (or (infix-operator-lookup name) + (prefix-operator-lookup name) + (postfix-operator-lookup name) + (intern name)))) + (let (ch) + (loop + (cond + ((eq :eof (setf ch (read-char stream nil :eof))) + (return-from tokenize1 none)) + ((whitespace-char-p ch) + ) + ((comment-char-p ch) + ;; comment from comment-char through end of line + (loop + (when (or (eql #\newline (setf ch (read-char stream t))) (eql #\return ch) (eql #\linefeed ch)) + (return)))) + ((and (eql #\/ ch) (eql #\* (peek-char nil stream nil :eof))) + ;; comment from /* through */ + (read-char stream) + (loop + (when (eql #\* (read-char stream t)) + (if (eql #\/ (setf ch (read-char stream t))) + (return) + (when (eql #\* ch) + (unread-char ch stream)))))) + ((separator-char-p ch) + (return ch)) + ((digit-char-p ch) + (return (tokenize-number ch))) + ((ordinary-char-p ch) + (return (tokenize-identifier ch))) + ((quotation-char-p ch) + (return (tokenize-string ch))) + ((or (eql #\- ch) (eql #\+ ch)) + (return (if (digit-char-p (peek-char nil stream nil #\a)) + (let ((v (tokenize-number (read-char stream)))) + (if (eql #\- ch) (- v) v)) + (tokenize-special ch)))) + (t + (return (tokenize-special ch)))))))) + +(defun tokenize (stream &key (case :preserve) (upper-case-var-prefix #\?) rationalize) + (let ((tokens nil)) + (loop + (let ((token (tokenize1 stream :case case :upper-case-var-prefix upper-case-var-prefix :rationalize rationalize))) + (if (eq none token) + (return) + (push token tokens)))) + (nreverse tokens))) + +;;; converts "p(a,b,c)" to (p a b c) +;;; converts "[a,b,c]" to ($$list a b c) +;;; converts "[a,b|c]" to ($$list* a b c) + +(defun tokens-to-lisp (tokens) + (let ((stack '(#\.)) ;stack contains terms, operators, #\(s, #\. + token1) + (labels + ((tokens-to-lisp1 () + (cond + ((or (eql #\( token1) (numberp token1) (stringp token1)) + (cond + ((starting-term) + (push token1 stack)) + (t + (syntax-error 1)))) + ((symbolp token1) + (cond + ((starting-term) + (push (if (eql #\( (first tokens)) + (progn + (setf tokens (rest tokens)) + (cons token1 (tokens-to-lisp2 '(#\))))) + token1) + stack)) + (t + (syntax-error 2)))) + ((eql #\[ token1) + (cond + ((starting-term) + (push (tokens-to-lisp2 '(#\])) stack)) + (t + (syntax-error 3)))) + ((eql #\) token1) + (cond + ((not (starting-term)) + (reduce-all #\()) + (t + (syntax-error 4)))) + ((operator-p token1) + ;; is it the right kind of operator? + ;; if not, just use it as a symbol + (setf token1 (operator-input-string token1)) + (cond + ((starting-term) + (cond + ((operator-p (setf token1 (or (prefix-operator-lookup token1) (intern token1)))) + (push token1 stack)) + (t + (tokens-to-lisp1)))) + (t + (cond + ((operator-p (setf token1 (or (infix-operator-lookup token1) (postfix-operator-lookup token1) (intern token1)))) + (reduce-before token1) + (push token1 stack)) + (t + (tokens-to-lisp1)))))) + (t + (syntax-error 5)))) + (tokens-to-lisp2 (brackets) + ;; convert lists and argument lists + (let ((list* nil) + (args nil) + (l nil)) + (loop + (cond + ((or (null tokens) (eql #\. (setf token1 (pop tokens)))) + (syntax-error 6)) + ((eql #\( token1) + (push #\) brackets) + (push token1 l)) + ((eql #\[ token1) + (push #\] brackets) + (push token1 l)) + ((or (eql #\) token1) (eql #\] token1)) + (cond + ((not (eql token1 (pop brackets))) + (syntax-error 7)) + ((null brackets) + (cond + ((null l) + (when args + (syntax-error 8))) + (t + (push (tokens-to-lisp (nreverse l)) args))) + (setf args (nreverse args)) + (return (if (eql #\] token1) (cons (if list* '$$list* '$$list) args) args))) + (t + (push token1 l)))) + ((and (null (rest brackets)) + (eql #\] (first brackets)) + ;; treat vertical bar as a separator only in lists + (cond + ((symbolp token1) + (when (string= "|" (symbol-name token1)) + (setf token1 #\|)) + nil) + ((operator-p token1) + (when (string= "|" (operator-input-string token1)) + (setf token1 #\|)) + nil) + (t + nil))) + ) + ((and (null (rest brackets)) (or (eql #\, token1) (and (eq #\| token1) (eql #\] (first brackets))))) + (cond + ((null l) + (syntax-error 9)) + (list* + (syntax-error 10)) + (t + (push (tokens-to-lisp (nreverse l)) args))) + (setf l nil) + (setf list* (eq #\| token1))) + (t + (push token1 l)))))) + (reduce-once () + (let ((x (pop stack)) (y (pop stack)) z) + (cond + ((infix-operator-p y) + (if (and (operand-p (setf z (pop stack))) (operand-p x)) + (push (list (operator-output-symbol y) z x) stack) + (syntax-error 11))) + ((prefix-operator-p y) + (if (operand-p x) + (push (list (operator-output-symbol y) x) stack) + (syntax-error 12))) + ((postfix-operator-p x) + (if (operand-p y) + (push (list (operator-output-symbol x) y) stack) + (syntax-error 13))) + (t + (syntax-error 14))))) + (reduce-before (op) + (loop + (if (cond + ((operator-p (first stack)) + (reduce-before? (first stack) op)) + ((operator-p (second stack)) + (reduce-before? (second stack) op)) + (t + nil)) + (reduce-once) + (return)))) + (reduce-all (start) + (loop + (cond + ((and (operand-p (first stack)) (eql start (second stack))) + (setf stack (cons (first stack) (rrest stack))) + (return)) + (t + (reduce-once))))) + (starting-term () + (let ((top (first stack))) + (not (or (operand-p top) (postfix-operator-p top))))) + (operand-p (x) + (not (or (eql #\( x) (eql #\. x) (operator-p x)))) + (syntax-error (name) + (error "Syntax error ~A at or before~{ ~S~}~% token1 = ~S~% stack =~{ ~S~}" name (firstn tokens 20) token1 stack))) + (loop + (cond + ((or (null tokens) (eql #\. (setf token1 (pop tokens)))) + (reduce-all #\.) + (return)) + (t + (tokens-to-lisp1)))) + (values (if (null (rest stack)) (first stack) stack) tokens)))) + +(defun read-infix-term (x &key (case :preserve) (upper-case-var-prefix #\?) rationalize) + ;; read one term from x and return it and list of leftover tokens + ;; if x is a string, tokenize it + ;; if x is a list, assume it is a tokenized string (with correct case and upper-case-var-prefix) + (when (stringp x) + (with-input-from-string (stream x) + (setf x (tokenize stream :case case :upper-case-var-prefix upper-case-var-prefix :rationalize rationalize)))) + (cl:assert (consp x)) + (tokens-to-lisp x)) + +(defun read-infix-terms (x &key (case :preserve) (upper-case-var-prefix #\?) rationalize) + (when (string x) + (with-input-from-string (stream x) + (setf x (tokenize stream :case case :upper-case-var-prefix upper-case-var-prefix :rationalize rationalize)))) + (let ((terms nil) terms-last term) + (loop + (cond + ((null x) + (return terms)) + (t + (setf (values term x) (tokens-to-lisp x)) + (collect term terms)))))) + +;;; infix-reader.lisp EOF diff --git a/src/input.lisp b/src/input.lisp new file mode 100644 index 0000000..0c5f352 --- /dev/null +++ b/src/input.lisp @@ -0,0 +1,984 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: input.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *skolem-function-alist* nil) +(defvar *input-wff* nil) +(defvar *input-wff-substitution*) ;alist of (variable-name . variable) or (variable-name . skolem-term) pairs +(defvar *input-wff-substitution2*) +(defvar *input-wff-new-antecedents*) +(defvar *input-wff-modal-prefix*) +(defvar *input-proposition-variables* nil) ;for cnf and boolean ring rewrites + +(defun keyword-argument-list-p (x) + (or (null x) + (and (consp x) + (keywordp (first x)) + (consp (rest x)) + (keyword-argument-list-p (rrest x))))) + +(defun can-be-name1 (x &optional ?ok) + (and (symbolp x) + (not (null x)) + (neq none x) + (neq true x) + (neq false x) + (let ((s (symbol-name x))) + (and (<= 1 (length s)) + (if ?ok t (not (variable-symbol-prefixed-p s))))))) + +(defun can-be-free-variable-name (x &optional action) + ;; a free variable in an input formula is represented + ;; by a symbol that starts with a variable-symbol-prefix + (or (and (can-be-name1 x t) + (variable-symbol-prefixed-p x)) + (and action (funcall action "~S cannot be the name of a free variable." x)))) + +(defun can-be-variable-name (x &optional action) + ;; a bound variable is represented like a free variable, or by an ordinary symbol + (or (can-be-name1 x t) + (and action (funcall action "~S cannot be the name of a variable." x)))) + +(defun can-be-constant-name (x &optional action) + (or (can-be-name1 x) + (null x) + (builtin-constant-p x) + (and (symbolp x) (= 0 (length (symbol-name x)))) + (and action (funcall action "~S cannot be the name of a constant." x)))) + +(defun can-be-constant-alias (x &optional action) + (or (can-be-name1 x) + (and (symbolp x) (= 0 (length (symbol-name x)))) + (and action (funcall action "~S cannot be the alias of a constant." x)))) + +(defun can-be-proposition-name (x &optional action) + (or (or (eq true x) ;allow internal true and false values in input + (eq false x) + (can-be-name1 x)) + (and action (funcall action "~S cannot be the name of a proposition." x)))) + +(defun can-be-function-name (x &optional action) + (or (can-be-name1 x) + (and action (funcall action "~S cannot be the name of a function." x)))) + +(defun can-be-relation-name (x &optional action) + (or (and (can-be-name1 x) + (neq '$$quote x)) + (and action (funcall action "~S cannot be the name of a relation." x)))) + +(defun can-be-logical-symbol-name (x &optional action) + (or (can-be-name1 x) + (and action (funcall action "~S cannot be the name of a logical symbol." x)))) + +(defun can-be-sort-name (x &optional action) + ;; disallow names with "&" to avoid confusion with SNARK created sorts + ;; disallow names with variable-sort-marker that is used to mark sorts in variable names + (or (top-sort-name? x) + (and (can-be-name1 x) + (not (eq 'and x)) + (not (eq 'or x)) + (not (eq 'not x)) + (let ((s (symbol-name x))) + (and (not (find (variable-sort-marker?) s)) + (or (null (symbol-package x)) (not (find #\& s)))))) + (and action (funcall action "~S cannot be the name of a sort." x)))) + +(defun can-be-row-name (x &optional action) + (or (can-be-name1 x) + (and action (funcall action "~S cannot be the name of a row." x)))) + +(defun can-be-constant-or-function-name (x &optional action) + (or (can-be-constant-name x) + (can-be-function-name x) + (and action (funcall action "~S cannot be the name of a constant or function." x)))) + +(defun check-usable-head1 (head) + ;; some operations cannot deal with function/relation symbols + ;; with special input handling + (when (function-input-code head) + (with-standard-io-syntax2 + (error "~S cannot be used as a ~A here." (function-name head) (function-kind head)))) + head) + +(defun cerror1 (datum &rest args) + (apply #'cerror "Input it anyway, but this may result in additional errors." datum args)) + +(defun cerror2 (datum &rest args) + (apply #'cerror "Ignore this sort declaration, but this may result in additional errors." datum args)) + +(defun variable-symbol-prefixed-p (x &optional (prefixes (variable-symbol-prefixes?))) + ;; check whether symbol or string x begins with variable prefixes (like ?, _, @, or "...") + ;; if so, return the number of characters in the prefix + ;; otherwise return nil + (let* ((s (string x)) + (len (length s)) + (pos 0)) + (loop + (dolist (prefix prefixes (return-from variable-symbol-prefixed-p (and (/= 0 pos) pos))) + (cond + ((characterp prefix) + (when (and (> len pos) (eql prefix (char s pos))) + (setf pos (+ pos 1)) + (return))) + (t + (let* ((prefix (string prefix)) + (plen (length prefix))) + (when (and (>= len (+ pos plen)) (string= prefix s :start2 pos :end2 (+ pos plen))) + (setf pos (+ pos plen)) + (return))))))))) + +(defun unsortable-variable-name (name) + ;; SNARK output uses ?, ?X, ?Y, ?Z, ?U, ?V, ?W, ?X1, ?Y1, ?Z1, ?U1, ?V1, ?W1, ... + ;; as unsorted variables; to enable SNARK to faithfully input its own output, + ;; don't allow these variables to be declared with a sort + (let* ((s (symbol-name name)) + (v (variable-symbol-prefixed-p s (list (first (variable-symbol-prefixes?)))))) + (and v + (let ((len (length s))) + (or (eql len v) + (and (member (char s v) '(#\X #\Y #\Z #\U #\V #\W #\x #\y #\z #\u #\v #\w)) + (or (eql (+ 1 v) len) + (null (position-if-not #'digit-char-p s :start (+ 1 v)))))))))) + +(defun sort-from-variable-name (name) + ;; ?name.sort is the preferred way to input sorted variables + ;; ?sort* works too with deprecated use-variable-name-sorts option (but not for sort names that end in digits or sorts named x,y,z,u,v,w) + (let* ((s (symbol-name name)) + (p (position (variable-sort-marker?) s :from-end t))) + (cond + (p ;interpret variable names that end with #sort like ?i2#integer + (the-sort (intern (subseq s (+ p 1)) :snark-user))) + ((use-variable-name-sorts?) ;old style try to interpret as a sort the substring between ?* at start and digit* at end + (let ((m (or (variable-symbol-prefixed-p s) 0)) + (n (position-if-not #'digit-char-p s :from-end t))) + (cond + ((> m n) + none) + ((and (= m n) (< 0 m) (member (char s m) '(#\X #\Y #\Z #\U #\V #\W #\x #\y #\z #\u #\v #\w))) + none) + (t + (mvlet (((values sym found) (find-symbol (subseq s m (+ n 1)) :snark-user))) + (if found (find-symbol-table-entry sym :sort) none)))))) + (t + none)))) + +(defun declare-variable (name &key (sort (top-sort-name) sort-supplied-p)) + ;; return same variable every time for same input free variable + (can-be-variable-name name 'error) + (setf sort (the-sort sort)) + (let* ((v (find-or-create-symbol-table-entry name :variable)) + (vsort (variable-sort v))) + (when (eq none (variable-sort v)) ;new variable + (unless (eq none (setf vsort (sort-from-variable-name name))) + (setf (variable-sort v) vsort))) + (cond + ((eq none vsort) + (cl:assert (not (and (not (top-sort? sort)) (unsortable-variable-name name))) + () + "Cannot declare ~A as variable of sort ~A; ~A is unsorted." + name (sort-name sort) name) + (setf (variable-sort v) sort)) + (sort-supplied-p + (cl:assert (same-sort? sort vsort) () + "Cannot declare ~A as variable of sort ~A; ~A is of sort ~A." + name (sort-name sort) name (sort-name vsort)))) + v)) + +;;; Convert Lisp S-expression for formula into correct internal form for theorem prover +;;; Also eliminate quantifiers and modal operators + +;;; after input-wff, *input-wff-substitution2* contains the substitutions for all +;;; bound variables in the wff; it will be misleading if bound variable names are +;;; repeated or if variable names occur unbound as constants + +(defun input-wff (wff &key (polarity :pos) (clausify nil) (*input-wff-substitution* nil)) + (when (stringp wff) + (setf wff (read-tptp-term wff :case (readtable-case *readtable*)))) + (let ((*input-wff* wff) + (*input-wff-substitution2* nil) + (*input-wff-new-antecedents* true) + (*input-wff-modal-prefix* nil)) + (let ((usr (use-sort-relativization?))) + (when usr + (let ((l nil)) + (dolist (x (input-variables-in-form wff nil nil)) + (when (variable-p (cdr x)) + (let ((sort (variable-sort (cdr x)))) + (unless (top-sort? sort) + (push `(,(sort-name sort) ,(car x)) l))))) + (when l + (setf wff (list 'implies + (if (null (rest l)) + (first l) + (cons 'and (nreverse l))) + wff)))))) + (let ((wff* (input-wff1 wff polarity))) + (unless (eq true *input-wff-new-antecedents*) + (setf wff* (make-implication *input-wff-new-antecedents* wff*))) + (when clausify + (setf wff* (clausify wff*))) + (values wff* nil *input-wff* *input-wff-substitution2*)))) + +(defun input-wff1 (wff polarity) + (when (stringp wff) + (setf wff (read-tptp-term wff :case (readtable-case *readtable*)))) + (cond + ((atom wff) + (input-atom wff polarity)) + (t + (let ((head (input-logical-symbol (first wff)))) + (if (neq none head) + (dolist (fun (function-input-code head) (make-compound* head (input-wffs1 head (rest wff) polarity))) + (let ((v (funcall fun head (rest wff) polarity))) + (unless (eq none v) + (return v)))) + (input-atom wff polarity)))))) + +(defun input-wffs1 (head args polarity) + (input-wffs2 args polarity (function-polarity-map head))) + +(defun input-wffs2 (wffs polarity polarity-map) + (lcons (input-wff1 (first wffs) (map-polarity (first polarity-map) polarity)) + (input-wffs2 (rest wffs) polarity (rest polarity-map)) + wffs)) + +(defun input-quoted-constant (head args polarity) + (require-n-arguments head args polarity 1) + (input-constant-symbol (cons '$$quote args))) + +(defun input-equality (head args polarity) + ;; see related code in input-function-as-relation + (require-n-arguments head args polarity 2) + (let (fn) + (cond + ((and (consp (first args)) + (member 'input-function-as-relation + (function-input-code (setf fn (input-function-symbol (first (first args)) (length (rest (first args)))))))) + (input-atom `(,(function-name fn) ,@(rest (first args)) ,(second args)) polarity)) + ((and (consp (second args)) + (member 'input-function-as-relation + (function-input-code (setf fn (input-function-symbol (first (second args)) (length (rest (second args)))))))) + (input-atom `(,(function-name fn) ,@(rest (second args)) ,(first args)) polarity)) + (t + (input-form* head args polarity))))) + +(defun input-disequality (head args polarity) + (declare (ignore head)) + (make-compound *not* (input-equality *=* args (opposite-polarity polarity)))) + +(defun input-negation (head args polarity) + (if (and (test-option6?) (use-clausification?)) + (negate0 (input-wffs1 head args polarity)) + (negate* (input-wffs1 head args polarity)))) + +(defun input-conjunction (head args polarity) + (conjoin* (input-wffs1 head args polarity))) + +(defun input-disjunction (head args polarity) + (disjoin* (input-wffs1 head args polarity))) + +(defun input-implication (head args polarity) + (if (eql 2 (length args)) + (make-implication* (input-wffs1 head args polarity)) + (input-kif-forward-implication head args polarity t))) + +(defun input-reverse-implication (head args polarity) + (if (eql 2 (length args)) + (make-reverse-implication* (input-wffs1 head args polarity)) + (input-kif-backward-implication head args polarity t))) + +(defun input-kif-forward-implication (head args polarity &optional rep) + (require-n-or-more-arguments head args polarity 1) + (when rep + (report-not-2-arguments-implication head args)) + (input-wff1 + (cond + ((null (rest args)) + (first args)) + ((null (rrest args)) + `(implies ,(first args) ,(second args))) + (t + `(implies (and ,@(butlast args)) ,(first (last args))))) + polarity)) + +(defun input-kif-backward-implication (head args polarity &optional rep) + (require-n-or-more-arguments head args polarity 1) + (when rep + (report-not-2-arguments-implication head args)) + (input-wff1 + (cond + ((null (rest args)) + (first args)) + ((null (rrest args)) + `(implied-by ,(first args) ,(second args))) + (t + `(implied-by ,(first args) (and ,@(rest args))))) + polarity)) + +(defun input-nand (head args polarity) + (declare (ignore head)) + (input-wff1 `(not (and ,@args)) polarity)) + +(defun input-nor (head args polarity) + (declare (ignore head)) + (input-wff1 `(not (or ,@args)) polarity)) + +(defun input-lisp-list (head args polarity) + (declare (ignore head)) + (input-terms args polarity)) + +(defun input-lisp-list* (head args polarity) + (require-n-or-more-arguments head args polarity 1) + (nconc (input-terms (butlast args) polarity) (input-term1 (first (last args)) polarity))) + +(defun input-function-as-relation-result-sort2 (head args) + (let* ((arity (+ (length args) 1)) + (rel (find-symbol-table-entry (function-name head) :relation arity))) + (if (eq none rel) + (top-sort) + (asa-arg-sort (function-argument-sort-alist rel) arity)))) + +(defun input-function-as-relation-result-sort (head args) + (let ((resultsort (sort-intersection + (function-sort head) + (input-function-as-relation-result-sort2 head args)))) + (cl:assert resultsort) + resultsort)) + +(defun input-function-as-relation (head args polarity &optional (new-head-name (function-name head))) + ;; see related code in input-equality + (let* ((resultsort (input-function-as-relation-result-sort head args)) + (resultvar (if (top-sort? resultsort) + (make-symbol (to-string (first (variable-symbol-prefixes?)) (nonce))) + (make-symbol (to-string (first (variable-symbol-prefixes?)) resultsort (nonce))))) + (antecedent (input-wff1 (cons new-head-name (append args (list resultvar))) :neg))) + (setf *input-wff-new-antecedents* (conjoin *input-wff-new-antecedents* antecedent)) + (input-term1 resultvar polarity))) + +(defun input-float-function-as-relation (head args polarity) + (let* ((str (symbol-name (function-name head))) + (len (length str))) + (cl:assert (string-equal str "_float" :start1 (- len 6):end1 len)) + (input-function-as-relation head args polarity (intern (subseq str 0 (- len 6)) :snark)))) + +(defun input-relation-as-function (head args polarity) + (input-atom (list '= (cons (function-name head) (butlast args)) (first (last args))) polarity)) + +(defun input-equivalence (head args polarity) + (cond + ((null args) + true) + ((null (rest args)) + (input-wff1 (first args) polarity)) + ((and (not (null (cddr args))) (eql 2 (function-arity head))) + (input-equivalence head (list (first args) (cons (function-name head) (rest args))) polarity)) + ((eq :both polarity) + (make-equivalence* (input-wffs1 head args polarity))) + ((catch 'needs-strict-polarity + (make-equivalence* (input-wffs1 head args polarity))) + ) + (t + (let ((x (first args)) + (y (if (null (cddr args)) (second args) (cons (function-name head) (rest args))))) + (input-wff1 (if (eq :neg polarity) + `(or (and ,x ,y) (and (not ,x) (not ,y))) + `(and (implies ,x ,y) (implied-by ,x ,y))) + polarity))))) + +(defun input-exclusive-or (head args polarity) + (cond + ((null args) + false) + ((null (rest args)) + (input-wff1 (first args) polarity)) + ((and (not (null (cddr args))) (eql 2 (function-arity head))) + (input-exclusive-or + head (list (first args) (cons (function-name head) (rest args))) polarity)) + ((eq :both polarity) + (make-exclusive-or* (input-wffs1 head args polarity))) + ((catch 'needs-strict-polarity + (make-exclusive-or* (input-wffs1 head args polarity))) + ) + (t + (let ((x (first args)) + (y (if (null (cddr args)) (second args) (cons (function-name head) (rest args))))) + (input-wff1 (if (eq :neg polarity) + `(or (and ,x (not ,y)) (and (not ,x) ,y)) + `(and (or ,x ,y) (or (not ,x) (not ,y)))) + polarity))))) + +(defun input-conditional (head args polarity) + (require-n-arguments head args polarity 3) + (cond + ((eq :both polarity) + (make-conditional + (input-wff1 (first args) :both) + (input-wff1 (second args) polarity) + (input-wff1 (third args) polarity))) + ((catch 'needs-strict-polarity + (make-conditional + (input-wff1 (first args) :both) + (input-wff1 (second args) polarity) + (input-wff1 (third args) polarity))) + ) + (t + (input-wff1 (if (eq :neg polarity) + `(or (and ,(first args) ,(second args)) + (and (not ,(first args)) ,(third args))) + `(and (implies ,(first args) ,(second args)) + (implies (not ,(first args)) ,(third args)))) + polarity)))) + +(defun input-conditional-answer (head args polarity) + (require-n-arguments head args polarity 3) + (make-conditional-answer + (input-wff1 (first args) :both) + (input-wff1 (second args) polarity) + (input-wff1 (third args) polarity))) + +(defun input-quantification (head args polarity) + (cond + ((eq :both polarity) + (throw 'needs-strict-polarity nil)) + (t + (unless (eql 2 (length args)) + ;; (forall (vars) form . forms) means (forall (vars) (implies (and . forms) form)) + ;; (exists (vars) form . forms) means (exists (vars) (and form . forms)) + (require-n-or-more-arguments head args polarity 2) + (report-not-2-arguments-quantification head args) + (setf args + (list (first args) + (cond + ((eq *forall* head) + `(=> ,@(rest args))) + ((eq *exists* head) + `(and ,@(rest args))))))) + (let ((var-specs (input-quantifier-variables (first args))) + (form (second args)) + (substitution *input-wff-substitution*) + *input-wff-substitution*) + (cond + ((or (and (eq :pos polarity) (eq *forall* head)) + (and (eq :neg polarity) (eq *exists* head))) + ;; add (variable-name . variable) pairs to substitution + (dolist (var-spec var-specs) + (let ((var (first var-spec))) + (push (cons var (make-variable-from-var-spec var-spec)) substitution) + (push (car substitution) *input-wff-substitution2*))) + (setf *input-wff-substitution* substitution)) + ((or (and (eq :pos polarity) (eq *exists* head)) + (and (eq :neg polarity) (eq *forall* head))) + (let ((free-vars-in-form (input-variables-in-form form (mapcar #'first var-specs) substitution))) + ;; add (variable-name . skolem-term) pairs to substitution + (dolist (var-spec var-specs) + (let ((var (first var-spec))) + (push (cons var (if (use-quantifier-preservation?) + (make-variable-from-var-spec var-spec) + (create-skolem-term var-spec form free-vars-in-form polarity))) + substitution) + (push (car substitution) *input-wff-substitution2*)))) + (setf *input-wff-substitution* substitution)) + (t + (unimplemented))) + (when (or (eq *forall* head) + (eq *exists* head)) + (let ((usr (use-sort-relativization?)) + (l nil)) + (dolist (var-spec var-specs) + (let ((sort (getf (rest var-spec) :sort))) + (when (and (not (top-sort-name? sort)) + (or usr (getf (rest var-spec) :sort-unknown))) + (push `(,(sort-name sort) ,(first var-spec)) l)))) + (when l + (setf form (list (if (eq *forall* head) 'implies 'and) + (if (null (rest l)) (first l) (cons 'and (nreverse l))) + form))))) + (cond + ((use-quantifier-preservation?) + (make-compound + head + (input-terms (mapcar #'first var-specs) polarity) + (input-wff1 form polarity))) + (t + (input-wff1 form polarity))))))) + +(defun input-quantifier-variable (var-spec) + ;; var-spec should be of form + ;; variable-name + ;; or + ;; (variable-name . keyword-argument-list) + ;; such as + ;; (variable-name :sort sort-name) + ;; or + ;; (variable-name restriction-name . keyword-argument-list) + ;; such as + ;; (variable-name restriction-name) - KIF + ;; interpeted as + ;; (variable-name :sort restriction-name . keyword-argument-list) + ;; + ;; output is always of form + ;; (variable-name . keyword-argument-list) + (cond + ((atom var-spec) + (setf var-spec (list var-spec))) + ((and (evenp (length var-spec)) (top-sort-name? (second var-spec))) + ;; ignore top-sort restriction iff :sort is specified + (setf var-spec + (if (getf (cddr var-spec) :sort) + (list* (first var-spec) (cddr var-spec)) + (list* (first var-spec) :sort (second var-spec) (cddr var-spec))))) + ((evenp (length var-spec)) + ;; restriction-name is interpreted as sort (possibly unknown) + (cl:assert (equal (second var-spec) (getf (cddr var-spec) :sort (second var-spec))) () + "In quantification, ~S has both a restriction and a sort." var-spec) + (setf var-spec + (cond + ((sort-name-expression? (second var-spec)) + (list* (first var-spec) :sort (second var-spec) (cddr var-spec))) + (t + (list* (first var-spec) :sort (second var-spec) :sort-unknown t (cddr var-spec))))))) + (cl:assert (keyword-argument-list-p (rest var-spec)) () + "In quantification, ~S is not a keyword argument list." (rest var-spec)) + (let ((var (first var-spec)) + (sort (getf (rest var-spec) :sort none)) + (sort-unknown (getf (rest var-spec) :sort-unknown))) + (cl:assert (can-be-variable-name var) () "In quantification, ~S is not a variable name." var) + (cond + ((neq none sort) + (cond + (sort-unknown + (declare-variable var)) + (t + ;; sort must have been declared + (the-sort sort) + (declare-variable var))) + (append var-spec + '(:skolem-p t) + `(:allowed-in-answer ,(allow-skolem-symbols-in-answers?)))) + (t + (append var-spec + `(:sort ,(sort-name (variable-sort (declare-variable var)))) + '(:skolem-p t) + `(:allowed-in-answer ,(allow-skolem-symbols-in-answers?))))))) + +(defun make-variable-from-var-spec (var-spec) + (if (getf (rest var-spec) :sort-unknown) + (make-variable) + (make-variable (the-sort (getf (rest var-spec) :sort))))) + +(defun input-quantifier-variables (var-specs) + ;; CycL requires single variable-name, + ;; KIF 3.0 allows it, + ;; KIF proposed ANSI standard disallows it + (unless (listp var-specs) + (setf var-specs (list var-specs))) + (cl:assert (and (listp var-specs) (not (keywordp (second var-specs)))) () + "Quantifier requires a list of bound variables.") + (setf var-specs (mapcar #'input-quantifier-variable var-specs)) + (setf var-specs (remove-duplicates + var-specs + :test (lambda (x y) + (when (eq (first x) (first y)) + (funcall (if (equal (rest x) (rest y)) 'warn 'error) + "In quantification, variable ~A is being rebound." + (first x)) + t)))) + (dolist (x var-specs) + (when (assoc (first x) *input-wff-substitution*) + (warn "In quantification, variable ~A is being rebound." (first x)))) + var-specs) + +(defun input-variables-in-form (expr vars substitution &optional result) + ;; excluding vars + (cond + ((atom expr) + (let ((v nil)) + (cond + ((member expr vars) + result) + ((setf v (assoc expr substitution)) + (cond + ((variable-p (cdr v)) + (if (rassoc (cdr v) result) result (nconc result (list v)))) + ((compound-p (cdr v)) + (dolist (x (args (cdr v))) + (unless (rassoc x result) + (setf result (nconc result (list (cons (car (rassoc x substitution)) x)))))) + result) + (t + result))) + ((can-be-free-variable-name expr) + (setf v (declare-variable expr)) + (if (rassoc v result) result (nconc result (list (cons expr v))))) + (t + result)))) + ((eq 'quote (first expr)) + result) + ((let ((v (input-logical-symbol (first expr)))) + (or (eq *forall* v) (eq *exists* v))) + (dolist (var-spec (input-quantifier-variables (second expr))) + (pushnew (first var-spec) vars)) + (input-variables-in-form + (third expr) + vars + substitution + result)) + (t + (dolist (x (rest expr)) + (setf result (input-variables-in-form x vars substitution result))) + result))) + +(defun create-skolem-term (var-spec form free-vars-in-form polarity) + (let ((sort (getf (rest var-spec) :sort)) + (sort-unknown (getf (rest var-spec) :sort-unknown)) + (newskfn (create-skolem-symbol var-spec form (mapcar #'car free-vars-in-form) polarity))) + (setf var-spec (copy-list var-spec)) + (remf (rest var-spec) :sort) + (remf (rest var-spec) :sort-unknown) + (remf (rest var-spec) :conc-name) + (cond + ((null free-vars-in-form) + (setf newskfn (apply #'declare-constant newskfn (rest var-spec))) + (when (and (not (top-sort-name? sort)) (not sort-unknown)) + (declare-constant-sort newskfn sort)) + newskfn) + (t + (setf newskfn (apply #'declare-function newskfn (length free-vars-in-form) (rest var-spec))) + (when (and (not (top-sort-name? sort)) (not sort-unknown)) + (declare-function-sort newskfn (cons sort (consn (top-sort-name) nil (length free-vars-in-form))))) + (make-compound* newskfn (mapcar #'cdr free-vars-in-form)))))) + +(defun create-skolem-symbol (var-spec form free-vars-in-form polarity) + ;; this code for generating skolem function names and world path function names + ;; stores the generated name in an alist so that if the exact same wff is input + ;; again, the same names will be generated + ;; thus, + ;; (assert '(forall (x) (exists (y) (p x y)))) + ;; followed by + ;; (assert '(forall (x) (exists (y) (p x y)))) + ;; will result in two occurrences of the same wff with the same skolem function + ;; + ;; this could be improved by checking for variants rather than equality so that + ;; (assert '(forall (u) (exists (v) (p u v)))) + ;; would also produce the same wff with the same skolem function + (let ((key (list var-spec form free-vars-in-form polarity))) + (or (cdr (assoc key *skolem-function-alist* :test #'equal)) + (let* (conc-name + sort + (x (cond + ((setf conc-name (getf (rest var-spec) :conc-name)) + (newsym2 conc-name)) + ((and (not (getf (rest var-spec) :sort-unknown)) + (not (top-sort-name? (setf sort (getf (rest var-spec) :sort))))) + (newsym :name :skolem :sort sort)) + (t + (newsym :name :skolem))))) +;; (push (cons key x) *skolem-function-alist*) ;skolem symbol reuse disabled pending fix + x)))) + +;;; *new-symbol-prefix* is included in created (including skolem) constant and function symbol names +;;; to give them hopefully unambiguous internable names across SNARK runs +;;; to allow import and export of created symbols without conflict + +(defvar *new-symbol-prefix*) ;set to "unique" value by (initialize) +(defvar *number-of-new-symbols*) ;set to 0 by (initialize) +(defvar *new-symbol-table*) ;set to hash table by (initialize) + +(defun newsym-prefix () + (let ((alphabet (symbol-name :abcdefghijklmnopqrstuvwxyz)) + (n (get-internal-run-time)) + (l nil)) + (dotimes (i 4) + (push (char alphabet (rem n 26)) l) + (setf n (floor n 26))) + (coerce l 'string))) + +(defun newsym (&key (name :newsym) sort) + (intern (if sort + (to-string name *new-symbol-prefix* (incf *number-of-new-symbols*) (variable-sort-marker?) sort) + (to-string name *new-symbol-prefix* (incf *number-of-new-symbols*))) + :snark-user)) + +(defun newsym2 (conc-name) + (let ((n (gethash conc-name *new-symbol-table* 0))) + (cond + ((= 0 n) + (setf (gethash conc-name *new-symbol-table*) 1) + conc-name) + (t + (setf (gethash conc-name *new-symbol-table*) (+ 1 n)) + (intern (to-string conc-name n) :snark-user))))) + +(defun input-form* (head terms polarity) + (make-compound* head (input-terms terms polarity))) + +(defun input-form (head terms polarity) + (dolist (fun (function-input-code head) (input-form* head terms polarity)) + (let ((v (funcall fun head terms polarity))) + (unless (eq none v) + (return v))))) + +(defun input-atom (atom polarity) + (cond + ((can-be-proposition-name atom) + (cond + ((cdr (assoc atom *input-wff-substitution*)) + (unimplemented)) ;proposition variables + (t + (input-proposition-symbol atom)))) + ((and (consp atom) (can-be-function-name (first atom))) + (check-for-well-sorted-atom + (input-form (input-head-relation-symbol atom) (rest atom) polarity))) + ((and *input-proposition-variables* (can-be-free-variable-name atom)) + (declare-variable atom)) + (t + (error "Cannot understand ~S as an atomic formula." atom)))) + +(defun input-term (term &key (polarity :pos) (*input-wff-substitution* nil)) + (let ((*input-wff-new-antecedents* true) + (*input-wff-modal-prefix* nil)) + (check-well-sorted (input-term1 term polarity)))) + +(defun input-term1 (term polarity) + (cond + ((variable-p term) + term) + ((cdr (assoc term *input-wff-substitution*)) + ) + ((atom term) + (cond + ((can-be-free-variable-name term) + (declare-variable term)) + (t + (input-constant-symbol term)))) + (t + (can-be-function-name (first term) 'error) + (input-form (input-head-function-symbol term) (rest term) polarity)))) + +(defun input-terms (terms polarity) + (lcons (input-term1 (first terms) polarity) + (input-terms (rest terms) polarity) + terms)) + +(defun map-polarity (fun polarity) + (if fun (funcall fun polarity) polarity)) + +(defun opposite-polarity (polarity) + (ecase polarity + (:pos + :neg) + (:neg + :pos) + (:both + :both))) + +(defun input-atom-with-keyword-arguments (head args polarity keywords) + ;; (declare-relation 'person :any + ;; :sort '((1 string) (2 real) (3 string)) + ;; :input-code (atom-with-keywords-inputter '(:name :age :sex))) + ;; allows arguments of 3-ary person relation to be specified positionally, by keyword, or a combination + ;; (person "john" 21 "male"), + ;; (person "john" :age 21 :sex "male"), + ;; (person "john" :sex "male" :age 21), + ;; and (person :sex "male" :age 21 :name "john") + ;; all yield (person "john" 21 "male") + ;; argument list is scanned left-to-right, processed positionally until first keyword, then as keyword/value pairs + ;; (keywords must be syntactically distinguishable from values for this to work properly) + ;; missing arguments are replaced by existentially quantified variables + (let ((arity (length keywords))) + (cond + ((and (length= arity args) (null (intersection keywords args))) + none) + (t + (let ((args* (make-array (length keywords) :initial-element none))) + (let ((l args) + (processing-keyword-arguments nil) + (i 0) + pos) + (loop + (when (endp l) + (return)) + (cond + ((setf pos (position (first l) keywords)) + (cl:assert (eq none (svref args* pos)) () "~S argument given twice in ~S." (first l) (cons (function-name head) args)) + (cl:assert (not (endp (setf l (rest l)))) () "Too few arguments in ~S." (cons (function-name head) args)) + (setf processing-keyword-arguments t)) + (t + (cl:assert (not processing-keyword-arguments) () "Expected ~S to be a keyword in ~S." (first l) (cons (function-name head) args)) + (cl:assert (< i arity) () "Too many arguments in ~S." (cons (function-name head) args)) + (setf pos i) + (setf i (+ 1 i)))) + (setf (svref args* pos) (pop l)))) + (let ((vars nil)) + (dotimes (i arity) + (when (eq none (svref args* i)) + (let ((var (gensym)) + (sort (asa-arg-sort (function-argument-sort-alist head) (+ 1 i)))) + (setf (svref args* i) var) + (push (if (top-sort? sort) var (list var :sort sort)) vars)))) + (let ((atom (cons (function-name head) (coerce args* 'list)))) + (input-wff1 (if vars (list 'exists (nreverse vars) atom) atom) polarity)))))))) + +(defun atom-with-keywords-inputter (keywords) + #'(lambda (head args polarity) (input-atom-with-keyword-arguments head args polarity keywords))) + +(defun clausify (wff &optional map-fun) + ;; apply map-fun to each clause in the clause form of wff + ;; if map-fun is NIL, return CNF of wff + (let ((clauses nil) clauses-last) + (labels + ((clausify* (cc wff pos lits) + (cond + ((and pos (test-option6?) (clause-p wff t)) + (funcall cc (cons wff lits))) + (t + (ecase (head-is-logical-symbol wff) + ((nil) + (cond + ((eq true wff) + (unless pos + (funcall cc lits))) + ((eq false wff) + (when pos + (funcall cc lits))) + (t + (let ((-wff (make-compound *not* wff))) + (dolist (lit lits (funcall cc (cons (if pos wff -wff) lits))) + (cond + ((equal-p lit wff) + (when pos + (funcall cc lits)) + (return)) + ((equal-p lit -wff) + (unless pos + (funcall cc lits)) + (return)))))))) + (not + (clausify* cc (first (args wff)) (not pos) lits)) + (and + (let ((args (args wff))) + (if pos + (if (and lits (some (lambda (arg) (member-p arg lits)) args)) + (funcall cc lits) + (dolist (arg args) + (clausify* cc arg t lits))) + (let ((y (make-a1-compound* *and* true (rest args)))) + (clausify* (lambda (l) (clausify* cc y nil l)) (first args) nil lits))))) + (or + (let ((args (args wff))) + (if pos + (let ((y (make-a1-compound* *or* false (rest args)))) + (clausify* (lambda (l) (clausify* cc y t l)) (first args) t lits)) + (if (and lits (some (lambda (arg) (member-p (negate arg) lits)) args)) + (funcall cc lits) + (dolist (arg args) + (clausify* cc arg nil lits)))))) + (implies + (let* ((args (args wff)) (x (first args)) (y (second args))) + (if pos + (clausify* (lambda (l) (clausify* cc y t l)) x nil lits) + (progn + (clausify* cc x t lits) + (clausify* cc y nil lits))))) + (implied-by + (let* ((args (args wff)) (x (first args)) (y (second args))) + (if pos + (clausify* (lambda (l) (clausify* cc y nil l)) x t lits) + (progn + (clausify* cc y t lits) + (clausify* cc x nil lits))))) + (iff + (let* ((args (args wff)) (x (first args)) (y (make-a1-compound* *iff* true (rest args)))) + (if pos + (progn + (clausify* (lambda (l) (clausify* cc y t l)) x nil lits) + (clausify* (lambda (l) (clausify* cc y nil l)) x t lits)) + (progn + (clausify* (lambda (l) (clausify* cc y nil l)) x nil lits) + (clausify* (lambda (l) (clausify* cc y t l)) x t lits))))) + (xor + (let* ((args (args wff)) (x (first args)) (y (make-a1-compound* *xor* false (rest args)))) + (if pos + (progn + (clausify* (lambda (l) (clausify* cc y nil l)) x nil lits) + (clausify* (lambda (l) (clausify* cc y t l)) x t lits)) + (progn + (clausify* (lambda (l) (clausify* cc y t l)) x nil lits) + (clausify* (lambda (l) (clausify* cc y nil l)) x t lits))))) + (if + (let* ((args (args wff)) (x (first args)) (y (second args)) (z (third args))) + (clausify* (lambda (l) (clausify* cc y pos l)) x nil lits) + (clausify* (lambda (l) (clausify* cc z pos l)) x t lits)))))))) + (clausify* (lambda (lits) + (let ((clause (make-a1-compound* *or* false (reverse lits)))) + (if map-fun (funcall map-fun clause) (collect clause clauses)))) + wff t nil) + (if map-fun nil (make-a1-compound* *and* true clauses))))) + +(defun report-not-2-arguments-quantification (head args) + (case (use-extended-quantifiers?) + ((nil) + (with-standard-io-syntax2 + (cerror "Convert it to a 2-ary quantification." + "~S does not have exactly 2 arguments as ~A ~S wants." + (cons (function-name head) args) (function-kind head) (function-name head)))) + (warn + (with-standard-io-syntax2 + (warn "~S does not have exactly 2 arguments as ~A ~S wants. It will be converted." + (cons (function-name head) args) (function-kind head) (function-name head)))))) + +(defun report-not-2-arguments-implication (head args) + (case (use-extended-implications?) + ((nil) + (with-standard-io-syntax2 + (cerror "Convert it to a 2-ary implication." + "~S does not have exactly 2 arguments as ~A ~S wants." + (cons (function-name head) args) (function-kind head) (function-name head)))) + (warn + (with-standard-io-syntax2 + (warn "~S does not have exactly 2 arguments as ~A ~S wants. It will be converted." + (cons (function-name head) args) (function-kind head) (function-name head)))))) + +;;; the following functions can be used as in +;;; (declare-relation 'product :any :input-code (lambda (h a p) (require-n-arguments h a p 3))) +;;; so that that there is only one product relation symbol +;;; (not more than one of different arities as is usually allowed) +;;; and it always has three arguments +;;; (not arbitrarily many as is usual for :any arity relations) + +(defun require-n-arguments (head args polarity n) + ;; if no error, returns none to cause later input-function-code to be used + (declare (ignore polarity)) + (unless (length= n args) + (with-standard-io-syntax2 + (cerror1 "~S does not have exactly ~D argument~:P as ~A ~S requires." + (cons (function-name head) args) n (function-kind head) (function-name head)))) + none) + +(defun require-n-or-more-arguments (head args polarity n) + ;; if no error, returns none to cause later input-function-code to be used + (declare (ignore polarity)) + (unless (length<= n args) + (with-standard-io-syntax2 + (cerror1 "~S does not have at least ~D argument~:P as ~A ~S requires." + (cons (function-name head) args) n (function-kind head) (function-name head)))) + none) + +;;; input.lisp EOF diff --git a/src/interactive.lisp b/src/interactive.lisp new file mode 100644 index 0000000..6c00e97 --- /dev/null +++ b/src/interactive.lisp @@ -0,0 +1,140 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: interactive.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2006. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; notes: +;;; clean up *interactive? *row2* interface to resolve.lisp code +;;; (paramodulate wff) isn't implemented +;;; add rewrite operation + +(declaim + (special + *negative-hyperresolution* + *interactive? + *row2*)) + +(defvar it nil) ;set to row name or number of last result + +(defvar *last-row-number-before-interactive-operation*) + +(defun row-to-designator-string (row) ;needed by Amphion? + (prin1-to-string (row-name-or-number row))) + +(defun before-interactive-operation () + (let-options ((use-closure-when-satisfiable t) + (print-rows-when-derived nil) + (print-summary-when-finished nil)) + (closure :only-unnumbered-rows t)) + (setf *last-row-number-before-interactive-operation* + (let ((last-row (last-row))) + (if last-row + (row-number last-row) + 0)))) + +(defun after-interactive-operation (op) + (let-options ((use-closure-when-satisfiable t) + (print-rows-when-derived t) + (print-summary-when-finished nil)) + (closure :only-unnumbered-rows t)) + (prog-> + (map-rows :reverse t ->* row) + (cond + ((>= *last-row-number-before-interactive-operation* (row-number row)) + (return-from after-interactive-operation (setf it nil))) + ((implies op (let ((reason (row-reason row))) + (and (consp reason) (eq op (first reason))))) + (return-from after-interactive-operation (setf it (row-name-or-number row)))))) + (setf it nil)) + +(defmacro wrap-interactive-operation (op &rest forms) + `(progn + (before-interactive-operation) + ,@forms + (after-interactive-operation ',op))) + +(defun mark-as-given (wff) + ;; mark wff as given + (store-given-row (row wff 'error))) + +(defun give (wff) + ;; perform all selected inference operations + ;; between wff and previously given wffs + (wrap-interactive-operation + nil + (let-options ((print-rows-when-given nil)) + (giver (row wff 'error))))) + +(defun factor (wff) + (wrap-interactive-operation + factor + (with-clock-on factoring + (factorer (row wff 'error))))) + +(defun resolve (wff1 &optional wff2) + (wrap-interactive-operation + resolve + (let ((*interactive? t) + (*row2* (and wff2 (row wff2 'error)))) + (with-clock-on resolution + (resolver (row wff1 'error)))))) + +(defun hyperresolve (nucleus &rest electrons) + (wrap-interactive-operation + hyperresolve + (cl:assert (not (row-positive-p (row nucleus 'error)))) ;make sure it's a nucleus + (let ((*interactive? t) + (*row2* (mapcar (lambda (e) (row e 'error)) electrons)) + (*negative-hyperresolution* nil)) + (with-clock-on resolution + (hyperresolver (row nucleus 'error)))))) + +(defun negative-hyperresolve (nucleus &rest electrons) + (wrap-interactive-operation + negative-hyperresolve + (cl:assert (not (row-negative-p (row nucleus 'error)))) ;make sure it's a nucleus + (let ((*interactive? t) + (*row2* (mapcar (lambda (e) (row e 'error)) electrons)) + (*negative-hyperresolution* t)) + (with-clock-on resolution + (hyperresolver (row nucleus 'error)))))) + +(defun ur-resolve (nucleus &rest electrons) + (wrap-interactive-operation + ur-resolve + (cl:assert (row-clause-p (row nucleus 'error))) ;make sure it's a nucleus + (let ((*interactive? t) + (*row2* (mapcar (lambda (e) (row e 'error)) electrons))) + (with-clock-on resolution + (ur-resolver1 (row nucleus 'error)))))) + +(defun paramodulate (wff &optional wff-with-equality) + (if wff-with-equality + (paramodulate-by wff-with-equality wff) + (error "(PARAMODULATE wff) is unimplemented; use (PARAMODULATE wff wff-with-equality)."))) + +(defun paramodulate-by (wff-with-equality &optional wff) + (wrap-interactive-operation + paramodulate + (let ((*interactive? t) + (*row2* (and wff (row wff 'error)))) + (with-clock-on paramodulation + (paramodulater-from (row wff-with-equality 'error)))))) + +;;; interactive.lisp EOF diff --git a/src/jepd-relations-tables.lisp b/src/jepd-relations-tables.lisp new file mode 100644 index 0000000..d691d97 --- /dev/null +++ b/src/jepd-relations-tables.lisp @@ -0,0 +1,511 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: jepd-relations-tables.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2002. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defparameter $rcc8-relation-code + '((tpp . 0) (ntpp . 1) (dc . 2) (ec . 3) (po . 4) (eq . 5) (ntppi . 6) (tppi . 7))) + +(defparameter $time-ii-relation-code + '((< . 0) (d . 1) (o . 2) (m . 3) (s . 4) (f . 5) (= . 6) + (fi . 7) (si . 8) (mi . 9) (oi . 10) (di . 11) (> . 12))) + +(defparameter $time-pp-relation-code + '((p

p . 2))) + +(defparameter $time-pi-relation-code + '((pi . 4))) + +(defparameter $time-ip-relation-code + '((i>p . 0) (i_si_p . 1) (i_di_p . 2) (i_fi_p . 3) (i

< > d di o oi m mi s si f fi =) + (< d < d o m s) + (< di <) + (< o <) + (< oi < d o m s) + (< m <) + (< mi < d o m s) + (< s <) + (< si <) + (< f < d o m s) + (< fi <) + (< = <) + (> < < > d di o oi m mi s si f fi =) + (> > >) + (> d > d oi mi f) + (> di >) + (> o > d oi mi f) + (> oi >) + (> m > d oi mi f) + (> mi >) + (> s > d oi mi f) + (> si >) + (> f >) + (> fi >) + (> = >) + (d < <) + (d > >) + (d d d) + (d di < > d di o oi m mi s si f fi =) + (d o < d o m s) + (d oi > d oi mi f) + (d m <) + (d mi >) + (d s d) + (d si > d oi mi f) + (d f d) + (d fi < d o m s) + (d = d) + (di < < di o m fi) + (di > > di oi mi si) + (di d d di o oi s si f fi =) + (di di di) + (di o di o fi) + (di oi di oi si) + (di m di o fi) + (di mi di oi si) + (di s di o fi) + (di si di) + (di f di oi si) + (di fi di) + (di = di) + (o < <) + (o > > di oi mi si) + (o d d o s) + (o di < di o m fi) + (o o < o m) + (o oi d di o oi s si f fi =) + (o m <) + (o mi di oi si) + (o s o) + (o si di o fi) + (o f d o s) + (o fi < o m) + (o = o) + (oi < < di o m fi) + (oi > >) + (oi d d oi f) + (oi di > di oi mi si) + (oi o d di o oi s si f fi =) + (oi oi > oi mi) + (oi m di o fi) + (oi mi >) + (oi s d oi f) + (oi si > oi mi) + (oi f oi) + (oi fi di oi si) + (oi = oi) + (m < <) + (m > > di oi mi si) + (m d d o s) + (m di <) + (m o <) + (m oi d o s) + (m m <) + (m mi f fi =) + (m s m) + (m si m) + (m f d o s) + (m fi <) + (m = m) + (mi < < di o m fi) + (mi > >) + (mi d d oi f) + (mi di >) + (mi o d oi f) + (mi oi >) + (mi m s si =) + (mi mi >) + (mi s d oi f) + (mi si >) + (mi f mi) + (mi fi mi) + (mi = mi) + (s < <) + (s > >) + (s d d) + (s di < di o m fi) + (s o < o m) + (s oi d oi f) + (s m <) + (s mi mi) + (s s s) + (s si s si =) + (s f d) + (s fi < o m) + (s = s) + (si < < di o m fi) + (si > >) + (si d d oi f) + (si di di) + (si o di o fi) + (si oi oi) + (si m di o fi) + (si mi mi) + (si s s si =) + (si si si) + (si f oi) + (si fi di) + (si = si) + (f < <) + (f > >) + (f d d) + (f di > di oi mi si) + (f o d o s) + (f oi > oi mi) + (f m m) + (f mi >) + (f s d) + (f si > oi mi) + (f f f) + (f fi f fi =) + (f = f) + (fi < <) + (fi > > di oi mi si) + (fi d d o s) + (fi di di) + (fi o o) + (fi oi di oi si) + (fi m m) + (fi mi di oi si) + (fi s o) + (fi si di) + (fi f f fi =) + (fi fi fi) + (fi = fi) + (= < <) + (= > >) + (= d d) + (= di di) + (= o o) + (= oi oi) + (= m m) + (= mi mi) + (= s s) + (= si si) + (= f f) + (= fi fi) + (= = =))) + +(defparameter $time-ppp-composition-table + '((p

p p

p p=p) + (p

p p

p p=p) + (p>p p>p p>p) + (p>p p=p p>p) + (p=p p

p p>p) + (p=p p=p p=p))) + +(defparameter $time-pii-composition-table + '((p pi p_d_i p_s_i p_f_i) + (pi < pi p_d_i p_s_i p_f_i) + (p>i > p>i) + (p>i d p>i p_d_i p_f_i) + (p>i di p>i) + (p>i o p>i p_d_i p_f_i) + (p>i oi p>i) + (p>i m p>i p_d_i p_f_i) + (p>i mi p>i) + (p>i s p>i p_d_i p_f_i) + (p>i si p>i) + (p>i f p>i) + (p>i fi p>i) + (p>i = p>i) + (p_d_i < p p>i) + (p_d_i d p_d_i) + (p_d_i di pi p_d_i p_s_i p_f_i) + (p_d_i o pi p_d_i p_f_i) + (p_d_i m pi) + (p_d_i s p_d_i) + (p_d_i si p>i p_d_i p_f_i) + (p_d_i f p_d_i) + (p_d_i fi p p>i) + (p_s_i d p_d_i) + (p_s_i di p p>i) + (p_f_i d p_d_i) + (p_f_i di p>i) + (p_f_i o p_d_i) + (p_f_i oi p>i) + (p_f_i m p_s_i) + (p_f_i mi p>i) + (p_f_i s p_d_i) + (p_f_i si p>i) + (p_f_i f p_f_i) + (p_f_i fi p_f_i) + (p_f_i = p_f_i))) + +(defparameter $time-ppi-composition-table + '((p

i pi p_d_i p_s_i p_f_i) + (p

p pi p_d_i p_s_i p_f_i) + (p>p p>i p>i) + (p>p p_d_i p>i p_d_i p_f_i) + (p>p p_s_i p>i p_d_i p_f_i) + (p>p p_f_i p>i) + (p=p pi p>i) + (p=p p_d_i p_d_i) + (p=p p_s_i p_s_i) + (p=p p_f_i p_f_i))) + +(defparameter $time-pip-composition-table + '((pp p

p p=p) + (pi i>p p>p) + (p>i i

p p=p) + (p>i i_di_p p>p) + (p>i i_si_p p>p) + (p>i i_fi_p p>p) + (p_d_i i>p p>p) + (p_d_i i

p p=p) + (p_d_i i_si_p p>p) + (p_d_i i_fi_p pp p>p) + (p_s_i i

p p>p) + (p_f_i i

p) + (p_f_i i_si_p p>p) + (p_f_i i_fi_p p=p))) + +(defparameter $time-ipi-composition-table + '((i>p p d di o oi m mi s si f fi =) + (i>p p>i >) + (i>p p_d_i > d oi mi f) + (i>p p_s_i > d oi mi f) + (i>p p_f_i >) + (i

i < > d di o oi m mi s si f fi =) + (i

i > di oi mi si) + (i_di_p p_d_i d di o oi s si f fi =) + (i_di_p p_s_i di o fi) + (i_di_p p_f_i di oi si) + (i_si_p pi >) + (i_si_p p_d_i d oi f) + (i_si_p p_s_i s si =) + (i_si_p p_f_i mi) + (i_fi_p pi > di oi mi si) + (i_fi_p p_d_i d o s) + (i_fi_p p_s_i m) + (i_fi_p p_f_i f fi =))) + +(defparameter $time-iip-composition-table + '((< i>p i>p i

i>p i>p) + (> i

p i

i_di_p i>p) + (> i_si_p i>p) + (> i_fi_p i>p) + (d i>p i>p) + (d i

p i

p) + (d i_fi_p ip i>p i_di_p i_si_p) + (di i

p i>p i_di_p i_si_p) + (o i

p i>p) + (oi i

p i_di_p i_si_p) + (oi i_si_p i>p) + (oi i_fi_p i_di_p) + (m i>p i>p i_di_p i_si_p) + (m i

p i>p) + (mi i

p) + (mi i_si_p i>p) + (mi i_fi_p i_si_p) + (s i>p i>p) + (s i

p i>p) + (si i

p i>p) + (f i

p i_di_p i_si_p) + (f i_si_p i>p) + (f i_fi_p i_fi_p) + (fi i>p i>p i_di_p i_si_p) + (fi i

p i>p) + (= i

p p

p i

p p>p i>p) + (i>p p=p i>p) + (i

p i>p i

p i>p i_di_p i_si_p) + (i_di_p p=p i_di_p) + (i_si_p p

p i>p) + (i_si_p p=p i_si_p) + (i_fi_p p

p i>p i_di_p i_si_p) + (i_fi_p p=p i_fi_p))) + +;;; jepd-relations-tables.lisp diff --git a/src/jepd-relations.lisp b/src/jepd-relations.lisp new file mode 100644 index 0000000..d21090c --- /dev/null +++ b/src/jepd-relations.lisp @@ -0,0 +1,731 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: jepd-relations.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; reasoning facilities for jointly-exhaustive and pairwise-disjoint sets of binary relations +;;; including +;;; spatial regions (RCC8) +;;; time intervals (Allen) +;;; time points +;;; that use composition tables to derive consequences and determine local consistency + +;;; for theories implemented here, the main functions are +;;; declare-rcc8-relations +;;; declare-time-relations +;;; these declare the appropriate relation symbols +;;; (determined by the values of rcc8-jepd-relation-names, rcc8-more-relation-names, etc.) +;;; and declare procedural attachments for composing and intersecting disjunctions of +;;; jepd binary relations + +;;; in the following encodings, +;;; a primitive relation allowed to be true is signified by the constant 1 +;;; a primitive relation required to be false is signified by a variable +;;; encoding "no" by variables this way makes factoring and subsumption do the right thing + +;;; for example, here is the encoding of time interval-interval relations +;;; they are all translated to positive occurrences of time-ii-relation +;;; 0 (before a b) ($$time-ii a b (list 1 ? ? ? ? ? ? ? ? ? ? ? ?)) +;;; 1 (during a b) ($$time-ii a b (list ? 1 ? ? ? ? ? ? ? ? ? ? ?)) +;;; 2 (overlaps a b) ($$time-ii a b (list ? ? 1 ? ? ? ? ? ? ? ? ? ?)) +;;; 3 (meets a b) ($$time-ii a b (list ? ? ? 1 ? ? ? ? ? ? ? ? ?)) +;;; 4 (starts a b) ($$time-ii a b (list ? ? ? ? 1 ? ? ? ? ? ? ? ?)) +;;; 5 (finishes a b) ($$time-ii a b (list ? ? ? ? ? 1 ? ? ? ? ? ? ?)) +;;; 6 (equal a b) ($$time-ii a b (list ? ? ? ? ? ? 1 ? ? ? ? ? ?)) +;;; 7 (finished-by a b) ($$time-ii a b (list ? ? ? ? ? ? ? 1 ? ? ? ? ?)) +;;; 8 (started-by a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? 1 ? ? ? ?)) +;;; 9 (met-by a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? ? 1 ? ? ?)) +;;; 10 (overlapped-by a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? ? ? 1 ? ?)) +;;; 11 (contains a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? ? ? ? 1 ?)) +;;; 12 (after a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? ? ? ? ? 1)) +;;; (disjoint a b) ($$time-ii a b (list 1 ? ? 1 ? ? ? ? ? 1 ? ? 1)) +;;; (not (before a b)) ($$time-ii a b (list ? 1 1 1 1 1 1 1 1 1 1 1 1)) +;;; (not (during a b)) ($$time-ii a b (list 1 ? 1 1 1 1 1 1 1 1 1 1 1)) +;;; etc. + +;;; these SNARK options can be used to specify the sort and relation names to be used +;;; by setting them BEFORE executing (declare-rcc8-relations) or (declare-time-relations) + +(declare-snark-option rcc8-region-sort-name 'region 'region) +(declare-snark-option time-interval-sort-name 'time-interval 'time-interval) +(declare-snark-option time-point-sort-name 'time-point 'time-point) + +(defparameter rcc8-jepd-relation-names + '($$rcc8-tpp ;0 tangential proper part - inverse of 7 + $$rcc8-ntpp ;1 nontangential proper part - inverse of 6 + $$rcc8-dc ;2 disconnected - self inverse + $$rcc8-ec ;3 externally connected - self inverse + $$rcc8-po ;4 partially overlaps - self inverse + $$rcc8-eq ;5 equality - self inverse + $$rcc8-ntppi ;6 nontangential proper part inverse + $$rcc8-tppi)) ;7 tangential proper part inverse + +(defparameter rcc8-more-relation-names ;composite relations and aliases + '($$rcc8-dr (2 3) ; discrete (complement of overlaps) + $$rcc8-pp (0 1) ; proper part + $$rcc8-p (0 1 5) ; part + $$rcc8-ppi (6 7) ; proper part inverse + $$rcc8-pi (5 6 7) ; part inverse + $$rcc8-o (0 1 4 5 6 7) ; overlaps (complement of discrete) + $$rcc8-c (0 1 3 4 5 6 7) ; connected (complement of disconnected) + $$rcc8-tp (0 5) ; tangential part + $$rcc8-tpi (5 7) ; tangential part inverse + + ;; rcc8-not-tpp etc. are unnecessary for input + ;; since (not (rcc8-tpp ...)) etc. can be written instead + ;; they are used to improve output using only positive literals + $$rcc8-not-tpp (1 2 3 4 5 6 7) + $$rcc8-not-ntpp (0 2 3 4 5 6 7) + $$rcc8-not-ec (0 1 2 4 5 6 7) + $$rcc8-not-po (0 1 2 3 5 6 7) + $$rcc8-not-eq (0 1 2 3 4 6 7) + $$rcc8-not-ntppi (0 1 2 3 4 5 7) + $$rcc8-not-tppi (0 1 2 3 4 5 6) + $$rcc8-not-pp (2 3 4 5 6 7) + $$rcc8-not-p (2 3 4 6 7) + $$rcc8-not-ppi (0 1 2 3 4 5) + $$rcc8-not-pi (0 1 2 3 4) + $$rcc8-not-tp (1 2 3 4 6 7) + $$rcc8-not-tpi (0 1 2 3 4 6) + )) + +(defparameter time-ii-jepd-relation-names + '($$time-ii-before ;0 - inverse of 12 + $$time-ii-during ;1 - inverse of 11 + $$time-ii-overlaps ;2 - inverse of 10 + $$time-ii-meets ;3 - inverse of 9 + $$time-ii-starts ;4 - inverse of 8 + $$time-ii-finishes ;5 - inverse of 7 + $$time-ii-equal ;6 - self inverse + $$time-ii-finished-by ;7 + $$time-ii-started-by ;8 + $$time-ii-met-by ;9 + $$time-ii-overlapped-by ;10 + $$time-ii-contains ;11 + $$time-ii-after)) ;12 + +(defparameter time-ii-more-relation-names ;composite relations and aliases + '($$time-ii-starts-before (0 2 3 7 11) + $$time-ii-starts-equal (4 6 8) + $$time-ii-starts-after (1 5 9 10 12) + $$time-ii-finishes-before (0 1 2 3 4) + $$time-ii-finishes-equal (5 6 7) + $$time-ii-finishes-after (8 9 10 11 12) + $$time-ii-subsumes (6 7 8 11) + $$time-ii-subsumed-by (1 4 5 6) + $$time-ii-disjoint (0 3 9 12) + $$time-ii-intersects (1 2 4 5 6 7 8 10 11) ;complement of disjoint + + ;; time-ii-not-before etc. are unnecessary for input + ;; since (not (before ...)) etc. can be written instead + ;; they are used to improve output using only positive literals + $$time-ii-not-before (1 2 3 4 5 6 7 8 9 10 11 12) + $$time-ii-not-during (0 2 3 4 5 6 7 8 9 10 11 12) + $$time-ii-not-overlaps (0 1 3 4 5 6 7 8 9 10 11 12) + $$time-ii-not-meets (0 1 2 4 5 6 7 8 9 10 11 12) + $$time-ii-not-starts (0 1 2 3 5 6 7 8 9 10 11 12) + $$time-ii-not-finishes (0 1 2 3 4 6 7 8 9 10 11 12) + $$time-ii-not-equal (0 1 2 3 4 5 7 8 9 10 11 12) + $$time-ii-not-finished-by (0 1 2 3 4 5 6 8 9 10 11 12) + $$time-ii-not-started-by (0 1 2 3 4 5 6 7 9 10 11 12) + $$time-ii-not-met-by (0 1 2 3 4 5 6 7 8 10 11 12) + $$time-ii-not-overlapped-by (0 1 2 3 4 5 6 7 8 9 11 12) + $$time-ii-not-contains (0 1 2 3 4 5 6 7 8 9 10 12) + $$time-ii-not-after (0 1 2 3 4 5 6 7 8 9 10 11) + $$time-ii-not-starts-before (1 4 5 6 8 9 10 12) + $$time-ii-not-starts-equal (0 1 2 3 5 7 9 10 11 12) + $$time-ii-not-starts-after (0 2 3 4 6 7 8 11) + $$time-ii-not-finishes-before (5 6 7 8 9 10 11 12) + $$time-ii-not-finishes-equal (0 1 2 3 4 8 9 10 11 12) + $$time-ii-not-finishes-after (0 1 2 3 4 5 7 7) + $$time-ii-not-subsumes (0 1 2 3 4 5 9 10 12) + $$time-ii-not-subsumed-by (0 2 3 7 8 9 10 11 12) + + $$time-ii-contained-by (1) ;alias of time-ii-during + )) + +(defparameter time-pp-jepd-relation-names + '($$time-pp-before ;0 - inverse of 2 + $$time-pp-equal ;1 - self inverse + $$time-pp-after)) ;2 + +(defparameter time-pp-more-relation-names ;composite relations and aliases + '($$time-pp-not-before (1 2) + $$time-pp-not-equal (0 2) + $$time-pp-not-after (0 1) + )) + +(defparameter time-pi-jepd-relation-names + '($$time-pi-before ;0 + $$time-pi-starts ;1 + $$time-pi-during ;2 + $$time-pi-finishes ;3 + $$time-pi-after)) ;4 + +(defparameter time-pi-more-relation-names ;composite relations and aliases + '($$time-pi-disjoint (0 4) + $$time-pi-intersects (1 2 3) ;complement of disjoint + $$time-pi-not-before (1 2 3 4) + $$time-pi-not-starts (0 2 3 4) + $$time-pi-not-during (0 1 3 4) + $$time-pi-not-finishes (0 1 2 4) + $$time-pi-not-after (0 1 2 3) + $$time-pi-contained-by (2) ;alias of time-pi-during + )) + +;;; interval-point relations are converted to point-interval relations + +(defparameter time-ip-jepd-relation-names + '($$time-ip-after ;0 + $$time-ip-started-by ;1 + $$time-ip-contains ;2 + $$time-ip-finished-by ;3 + $$time-ip-before)) ;4 + +(defparameter time-ip-more-relation-names ;composite relations and aliases + '($$time-ip-disjoint (0 4) + $$time-ip-intersects (1 2 3) ;complement of disjoint + $$time-ip-not-after (1 2 3 4) + $$time-ip-not-started-by (0 2 3 4) + $$time-ip-not-contains (0 1 3 4) + $$time-ip-not-finished-by (0 1 2 4) + $$time-ip-not-before (0 1 2 3) + )) + +(defun jepd-relation-input-function (head args polarity rel reverse n i) + (cond + ((eq :both polarity) + (throw 'needs-strict-polarity nil)) + (t + (require-n-arguments head args polarity 2) + (let ((atom `(,rel ,@(if reverse (reverse args) args) ($$list ,@(1-or-?s n i polarity))))) + (input-wff1 (if (eq :pos polarity) atom `(not ,atom)) polarity))))) + +(defun 1-or-?s (n i &optional (polarity :pos)) + (let ((l nil) l-last) + (dotimes (k n) + (collect (if (if (consp i) (member k i) (eql i k)) + (if (eq :pos polarity) 1 (make-variable)) + (if (eq :pos polarity) (make-variable) 1)) + l)) + l)) + +(defun 1s-count (x &optional subst) + (dereference + x subst + :if-variable 0 + :if-constant 0 + :if-compound-appl 0 + :if-compound-cons (let ((x1 (carc x))) + (if (dereference x1 subst :if-constant (eql 1 x1)) + (+ (1s-count (cdrc x)) 1) + (1s-count (cdrc x)))))) + +(defun 1-indexes (x &optional subst (n 0)) + (dereference + x subst + :if-variable nil + :if-constant nil + :if-compound-appl nil + :if-compound-cons (let ((x1 (carc x))) + (if (dereference x1 subst :if-constant (eql 1 x1)) + (cons n (1-indexes (cdrc x) subst (+ n 1))) + (1-indexes (cdrc x) subst (+ n 1)))))) + +(defun jepd-relation-composition-rewriter (atom subst fun) + (let* ((args (args atom)) + (l1 (pop args)) + (l2 (pop args)) + (x (pop args)) + (y (pop args)) + (z (first args))) + (cond + ((or (equal-p x y subst) ;don't compose (r1 a a) and (r2 a b) + (equal-p y z subst) ;don't compose (r1 a b) and (r2 b b) + (and (test-option17?) + (equal-p x z subst))) ;don't compose (r1 a b) and (r2 b a) + true) + ((and (dereference l1 subst :if-compound-cons t) + (dereference l2 subst :if-compound-cons t)) + (funcall fun l1 l2 x y z subst)) ;get result using theory's composition table + (t + none)))) ;useless consequences of the axioms? + +(defun jepd-relation-composition-rewriter1 (atom subst rel table &optional (n (first (array-dimensions table)))) + (jepd-relation-composition-rewriter + atom + subst + (lambda (l1 l2 x y z subst) + (declare (ignore y)) + (let ((result (make-array n :initial-element nil)) + (i 0)) + (dolist (v l1) + (when (dereference v subst :if-constant t) + (let ((j 0)) + (dolist (v l2) + (when (dereference v subst :if-constant t) + (dolist (v (aref table i j)) + (setf (svref result v) t))) + (incf j)))) + (incf i)) + (cond + ((every #'identity result) + true) + (t + (make-compound + rel + x + z + (let ((l nil) l-last) + (dotimes (i n) + (collect (if (svref result i) 1 (make-and-freeze-variable)) l)) + l)))))))) + +(defun reversem (l m &optional (n (length l))) + (nconc (nreverse (subseq l (- n m) n)) + (subseq l m (- n m)) + (nreverse (subseq l 0 m)))) + +(defun xx-intersection (l1 l2 subst) + ;; fresh variables returned + (dereference l1 subst) + (dereference l2 subst) + (if (null l1) + nil + (cons (or (let ((x (first l1))) (dereference x subst :if-variable (make-and-freeze-variable))) + (let ((x (first l2))) (dereference x subst :if-variable (make-and-freeze-variable))) + 1) + (xx-intersection (rest l1) (rest l2) subst)))) + +(defun jepd-relation-intersection-rewriter1 (rel atom subst invert) + (let* ((args (args atom)) + (l1 (pop args)) + (l2 (pop args))) + (cond + ((and (dereference l1 subst :if-compound-cons t) + (dereference l2 subst :if-compound-cons t)) + (let ((l (xx-intersection l1 l2 subst))) + (cond + ((not (member 1 l)) + false) + ((and invert (test-option17?)) + (make-compound rel (second args) (first args) (reversem l invert))) + (t + (make-compound rel (first args) (second args) l))))) + ((and (dereference l1 subst :if-variable t) + (dereference l2 subst :if-variable t) + (eq l1 l2)) + true) ;useless consequences of the axioms? + (t + none)))) + +(defun jepd-relation-atom-weight (x &optional subst) + (let ((args (args x))) + (+ (weight (pop args) subst) + (weight (pop args) subst) + (1s-count (first args) subst) + (function-weight (head x))))) + +(defun declare-jepd-relation (relname sort names more-names invert) + (let ((use-special-unification (and invert (not (test-option17?))))) + (declare-relation1 + relname 3 + :rewrite-code 'jepd-relation-atom-rewriter + :sort sort + :equal-code (and use-special-unification + (lambda (x y subst) + (equal-jepd-relation-atom-args-p (args x) (args y) subst invert))) + :variant-code (and use-special-unification + (lambda (cc x y subst matches) + (variant-jepd-relation-atom-args cc (args x) (args y) subst matches invert))) + :unify-code (and use-special-unification + (lambda (cc x y subst) + (unify-jepd-relation-atom-args cc (args x) (args y) subst invert))) + :index-type (and use-special-unification :jepd) + :ordering-status (if use-special-unification :commutative :left-to-right) + :to-lisp-code #'(lambda (head args subst) (jepd-atom-to-lisp head args subst names more-names)) + :weight-code 'jepd-relation-atom-weight))) + +(defun declare-jepd-relation-input (relname names more-names n reverse) + (let ((i 0)) + (dolist (name names) + (declare-relation1 + name :any + :macro t + :input-code (let ((i i)) + (lambda (head args polarity) + (jepd-relation-input-function head args polarity relname reverse n i)))) + (incf i))) + (do ((l more-names (cddr l))) + ((endp l) + ) + (declare-relation1 + (first l) :any + :macro t + :input-code (let ((i (second l))) + (lambda (head args polarity) + (jepd-relation-input-function head args polarity relname reverse n i)))))) + +(defun declare-equality-jepd-relation (relname sort n equality) + (when equality + (cl:assert (same-sort? (first sort) (second sort))) + (assert `(forall ((?x :sort ,(first sort))) + (,relname ?x ?x ($$list ,@(1-or-?s n equality)))) + :name (intern (to-string relname :-equality) :keyword) + :supported nil))) + +(defun declare-jepd-relation-intersection (relname rel sort invert) + (let ((intersection (intern (to-string relname :-intersection) :snark))) + (declare-relation1 + intersection 4 + :rewrite-code (list + (lambda (atom subst) + (jepd-relation-intersection-rewriter1 rel atom subst invert)))) + (assert `(forall ((?x :sort ,(first sort)) + (?y :sort ,(second sort)) + ?l1 + ?l2) + (implies (and (,relname ?x ?y ?l1) (,relname ?x ?y ?l2)) + (,intersection ?l1 ?l2 ?x ?y))) + :name (intern (symbol-name intersection) :keyword) + :supported nil))) + +(defun declare-jepd-relations (relname sort composition invert equality names more-names) + ;; three operations may be necessary: + ;; intersection: (r1 a b) & (r2 a b) -> (r1&r2 a b) + ;; inverse: (r1 a b) -> (r1' b a) + ;; composition: (r1 a b) & (r2 b c) -> (r3 a c) + ;; + ;; if inverse is necessary, it is incorporated into the intersection operation: + ;; intersection: (r1 a b) & (r2 a b) -> (r1&r2 b a) + ;; so that only composition and (possibly inverting) intersection are used + (let ((n (length names)) + (rel (declare-jepd-relation relname sort names more-names invert))) + (declare-jepd-relation-input relname names more-names n nil) + (declare-equality-jepd-relation relname sort n equality) + (declare-jepd-relation-intersection relname rel sort invert) + (let ((table composition) + (composition (intern (to-string relname :-composition) :snark))) + (declare-relation1 + composition 5 + :rewrite-code (list + (lambda (atom subst) + (jepd-relation-composition-rewriter1 atom subst rel table)))) + (assert `(forall ((?x :sort ,(first sort)) + (?y :sort ,(second sort)) ;sorts should be the same + (?z :sort ,(second sort)) + ?l1 + ?l2) + (implies (and (,relname ?x ?y ?l1) (,relname ?y ?z ?l2)) + (,composition ?l1 ?l2 ?x ?y ?z))) + :name (intern (symbol-name composition) :keyword) + :supported nil)))) + +(defun jepd-relation-code (x alist) + (let ((v (assoc x alist))) + (cl:assert v) + (cdr v))) + +(defun make-composition-table (tab ocode &optional (icode1 ocode) (icode2 ocode)) + (let* ((nrows (length icode1)) + (ncols (length icode2)) + (table (make-array (list nrows ncols) :initial-element nil))) + (dolist (x tab) + (let ((i (jepd-relation-code (first x) icode1)) + (j (jepd-relation-code (second x) icode2))) + (cl:assert (null (aref table i j))) + (setf (aref table i j) (mapcar (lambda (x) (jepd-relation-code x ocode)) (cddr x))))) + (dotimes (i nrows) + (dotimes (j ncols) + (cl:assert (not (null (aref table i j)))))) + table)) + +(defvar *rcc8-composition-table* nil) +(defvar *time-iii-composition-table* nil) +(defvar *time-ipi-composition-table* nil) +(defvar *time-pii-composition-table* nil) +(defvar *time-pip-composition-table* nil) +(defvar *time-ppi-composition-table* nil) +(defvar *time-ppp-composition-table* nil) + +(defun firsta (x) + (if (consp x) (first x) x)) + +(defun resta (x) + (if (consp x) (rest x) nil)) + +(defun declare-rcc8-relations () + ;; this function should not be done more than once after (initialize) + (let ((region-sort (rcc8-region-sort-name?))) + (unless (sort-name? region-sort) + (let ((l (resta region-sort))) + (apply 'declare-sort (setf region-sort (firsta region-sort)) l))) + (declare-jepd-relations + '$$rcc8 + (list region-sort region-sort) + (or *rcc8-composition-table* + (setf *rcc8-composition-table* (make-composition-table + $rcc8-composition-table + $rcc8-relation-code))) + 2 + (jepd-relation-code 'eq $rcc8-relation-code) + rcc8-jepd-relation-names + rcc8-more-relation-names))) + +(defun declare-time-relations (&key intervals points dates) + ;; this function should not be done more than once after (initialize) + (unless (or intervals points) + (setf intervals t points t)) + (when dates + (setf points t)) + (let ((interval-sort (time-interval-sort-name?)) + (point-sort (time-point-sort-name?))) + (when intervals + (unless (sort-name? interval-sort) + (let ((l (resta interval-sort))) + (apply 'declare-sort (setf interval-sort (firsta interval-sort)) l))) + (declare-jepd-relations + '$$time-ii + (list interval-sort interval-sort) + (or *time-iii-composition-table* + (setf *time-iii-composition-table* (make-composition-table + $time-iii-composition-table + $time-ii-relation-code))) + 6 + (jepd-relation-code '= $time-ii-relation-code) + time-ii-jepd-relation-names + time-ii-more-relation-names)) + (when points + (unless (sort-name? point-sort) + (let ((l (resta point-sort))) + (apply 'declare-sort (setf point-sort (firsta point-sort)) l))) + (declare-jepd-relations + '$$time-pp + (list point-sort point-sort) + (or *time-ppp-composition-table* + (setf *time-ppp-composition-table* (make-composition-table + $time-ppp-composition-table + $time-pp-relation-code))) + 1 + (jepd-relation-code 'p=p $time-pp-relation-code) + time-pp-jepd-relation-names + time-pp-more-relation-names)) + (when (and intervals points) + (unless (or (top-sort-name? interval-sort) (top-sort-name? point-sort)) + (declare-sorts-incompatible interval-sort point-sort)) + (let* ((relname '$$time-pi) + (sort (list point-sort interval-sort)) + (names time-pi-jepd-relation-names) + (more-names time-pi-more-relation-names) + (n (length names)) + (rel (declare-jepd-relation relname sort names more-names nil))) + (declare-jepd-relation-input relname names more-names n nil) + ;; convert interval-point relations to point-interval relations + (setf names time-ip-jepd-relation-names) + (cl:assert (eql n (length names))) + (declare-jepd-relation-input relname names time-ip-more-relation-names n t) + (declare-jepd-relation-intersection relname rel sort nil) + ;;; PI * II -> PI composition + (let ((composition (intern (to-string relname :-ii-composition) :snark))) + (declare-relation1 + composition 5 + :rewrite-code (let ((table (or *time-pii-composition-table* + (setf *time-pii-composition-table* (make-composition-table + $time-pii-composition-table + $time-pi-relation-code + $time-pi-relation-code + $time-ii-relation-code)))) + (n (length $time-pi-relation-code))) + (list + (lambda (atom subst) + (jepd-relation-composition-rewriter1 atom subst rel table n))))) + (assert `(forall ((?x :sort ,point-sort) + (?y :sort ,interval-sort) + (?z :sort ,interval-sort) + ?l1 + ?l2) + (implies (and (,relname ?x ?y ?l1) ($$time-ii ?y ?z ?l2)) + (,composition ?l1 ?l2 ?x ?y ?z))) + :name (intern (symbol-name composition) :keyword) + :supported nil)) + ;;; PP * PI -> PI composition + (let ((composition (intern (to-string relname :-pp-composition) :snark))) + (declare-relation1 + composition 5 + :rewrite-code (let ((table (or *time-ppi-composition-table* + (setf *time-ppi-composition-table* (make-composition-table + $time-ppi-composition-table + $time-pi-relation-code + $time-pp-relation-code + $time-pi-relation-code)))) + (n (length $time-pi-relation-code))) + (list + (lambda (atom subst) + (jepd-relation-composition-rewriter1 atom subst rel table n))))) + (assert `(forall ((?x :sort ,point-sort) + (?y :sort ,point-sort) + (?z :sort ,interval-sort) + ?l1 + ?l2) + (implies (and ($$time-pp ?x ?y ?l1) (,relname ?y ?z ?l2)) + (,composition ?l1 ?l2 ?x ?y ?z))) + :name (intern (symbol-name composition) :keyword) + :supported nil)) + ;;; PI * IP -> PP composition + (let ((composition (intern (to-string relname :-pi-composition) :snark))) + (declare-relation1 + composition 5 + :rewrite-code (let ((rel (input-relation-symbol '$$time-pp 3)) + (table (or *time-pip-composition-table* + (setf *time-pip-composition-table* (make-composition-table + $time-pip-composition-table + $time-pp-relation-code + $time-pi-relation-code + $time-ip-relation-code)))) + (n (length $time-pp-relation-code))) + (list + (lambda (atom subst) + (jepd-relation-composition-rewriter1 atom subst rel table n))))) + (assert `(forall ((?x :sort ,point-sort) + (?y :sort ,interval-sort) + (?z :sort ,point-sort) + ?l1 + ?l2) + (implies (and (,relname ?x ?y ?l1) (,relname ?z ?y ?l2)) + (,composition ?l1 ?l2 ?x ?y ?z))) + :name (intern (symbol-name composition) :keyword) + :supported nil)) + ;;; IP * PI -> II composition + (let ((composition (intern (to-string relname :-pi-composition2) :snark))) + (declare-relation1 + composition 5 + :rewrite-code (let ((rel (input-relation-symbol '$$time-ii 3)) + (table (or *time-ipi-composition-table* + (setf *time-ipi-composition-table* (make-composition-table + $time-ipi-composition-table + $time-ii-relation-code + $time-ip-relation-code + $time-pi-relation-code)))) + (n (length $time-ii-relation-code))) + (list + (lambda (atom subst) + (jepd-relation-composition-rewriter1 atom subst rel table n))))) + (assert `(forall ((?x :sort ,interval-sort) + (?y :sort ,point-sort) + (?z :sort ,interval-sort) + ?l1 + ?l2) + (implies (and (,relname ?y ?x ?l1) (,relname ?y ?z ?l2)) + (,composition ?l1 ?l2 ?x ?y ?z))) + :name (intern (symbol-name composition) :keyword) + :supported nil)))) + (when dates + (declare-date-functions :intervals intervals :points points)) + nil)) + +(defun jepd-atom-to-lisp (head args subst &optional names more-names) + (let* ((arg1 (term-to-lisp (pop args) subst)) + (arg2 (term-to-lisp (pop args) subst)) + (arg3 (first args)) + (rels (and names (1-indexes arg3 subst)))) + (cond + ((null rels) + (list (function-name head) arg1 arg2 (term-to-lisp arg3 subst))) + ((null (rest rels)) + (list (function-name (input-relation-symbol (nth (first rels) names) 2)) arg1 arg2)) + ((do ((l more-names (cddr l))) + ((null l) + nil) + (when (equal rels (second l)) + (return (list (function-name (input-relation-symbol (first l) 2)) arg1 arg2))))) + (t + (let ((l nil) l-last) + (dolist (rel rels) + (collect (list (function-name (input-relation-symbol (nth rel names) 2)) arg1 arg2) l)) + (cons 'or-jepd l)))))) + +(defun equal-jepd-relation-atom-args-p (args1 args2 subst invert) + ;; lists of possible relations in third argument are compared by variant-p instead of equal-p + ;; after inversion; all the variables in a list of possible relations are required to be unique, + ;; so their exact identity is unimportant + (let ((x1 (pop args1)) (y1 (pop args1)) (rels1 (first args1)) + (x2 (pop args2)) (y2 (pop args2)) (rels2 (first args2))) + (or (and (equal-p x1 x2 subst) + (equal-p y1 y2 subst) + (equal-p rels1 rels2 subst)) + (and (dereference rels1 subst :if-compound-cons t) + (dereference rels2 subst :if-compound-cons t) + (and (equal-p x1 y2 subst) + (equal-p y1 x2 subst) + (variant-p rels1 (reversem rels2 invert) subst)))))) + +(defun variant-jepd-relation-atom-args (cc args1 args2 subst matches invert) + (let ((x1 (pop args1)) (y1 (pop args1)) (rels1 (first args1)) + (x2 (pop args2)) (y2 (pop args2)) (rels2 (first args2))) + (prog-> + (variant x1 x2 subst matches ->* matches) + (variant y1 y2 subst matches ->* matches) + (variant rels1 rels2 subst matches ->* matches) + (funcall cc matches)) + (when (and (dereference rels1 subst :if-compound-cons t) + (dereference rels2 subst :if-compound-cons t)) + (prog-> + (quote nil -> rels2*) + (variant x1 y2 subst matches ->* matches) + (variant y1 x2 subst matches ->* matches) + (variant rels1 (or rels2* (setf rels2* (reversem rels2 invert))) subst matches ->* matches) + (funcall cc matches))))) + +(defun unify-jepd-relation-atom-args (cc args1 args2 subst invert) + (let ((x1 (pop args1)) (y1 (pop args1)) (rels1 (first args1)) + (x2 (pop args2)) (y2 (pop args2)) (rels2 (first args2))) + (prog-> + (unify x1 x2 subst ->* subst) + (unify y1 y2 subst ->* subst) + (unify rels1 rels2 subst ->* subst) + (funcall cc subst)) + (cond + ((dereference rels2 subst :if-compound-cons t) + (prog-> + (quote nil -> rels2*) + (unify x1 y2 subst ->* subst) + (unify y1 x2 subst ->* subst) + (unify rels1 (or rels2* (setf rels2* (reversem rels2 invert))) subst ->* subst) + (funcall cc subst))) + ((dereference rels1 subst :if-compound-cons t) + (prog-> + (quote nil -> rels1*) + (unify y1 x2 subst ->* subst) + (unify x1 y2 subst ->* subst) + (unify (or rels1* (setf rels1* (reversem rels1 invert))) rels2 subst ->* subst) + (funcall cc subst)))))) + +(defun jepd-relation-atom-rewriter (atom subst) + ;; replace by true + ;; atoms like (time-pp-relation a b (list 1 1 1)) + ;; that can be produced by factoring + (let ((v (third (args atom)))) + (if (dereference + v subst + :if-compound-cons (dolist (x v t) + (dereference x subst :if-variable (return nil)))) + true + none))) + +;;; jepd-relations.lisp diff --git a/src/knuth-bendix-ordering2.lisp b/src/knuth-bendix-ordering2.lisp new file mode 100644 index 0000000..464b110 --- /dev/null +++ b/src/knuth-bendix-ordering2.lisp @@ -0,0 +1,205 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: knuth-bendix-ordering2.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; this implementation is inspired by +;;; Bernd L\"{o}chner's "Things to Know When Implementing KBO" in JAR (2006) +;;; +;;; extensions: +;;; status to allow not just left-to-right lexical ordering +;;; weight multipliers (must be >= 1) for arguments of ordinary fixed arity functions for linear polynomial ordering +;;; (declare-function 'commutator 2 :kbo-weight '(5 3 3)) etc. in overbeek1e example +;;; flattening of argument lists for associative functions +;;; argument lists are greater in ordering than their prefixes +;;; +;;; should use integer or rational weights (not floats) for exact arithmetic +;;; +;;; re :multiset status +;;; even if (f 2) exceeds (f 1 1), it cannot exceed (f 1 1 ... 1) for arbitrary number of 1s + +(definline variable-kbo-weight (var) + (let ((w (kbo-variable-weight?))) + (if (numberp w) w (funcall w var)))) + +(defun kbo-evaluate-term (term subst mult weight vars) + (dereference + term subst + :if-variable (values (+ weight (* mult (variable-kbo-weight term))) (acons+ term mult vars)) + :if-constant (values (+ weight (* mult (constant-kbo-weight term))) vars) + :if-compound (let* ((head (head term)) + (args (args term)) + (w (function-kbo-weight head)) + (ws (if (consp w) (rest w) nil)) + (w (if (consp w) (first w) w))) + (cond + ((function-associative head) + (setf weight (+ weight (* mult w (max 1 (- (length args) 1)))))) + (t + (setf weight (+ weight (* mult w))))) + (kbo-evaluate-terms args subst mult weight vars ws)))) + +(defun kbo-evaluate-terms (terms subst mult weight vars ws) + (dolist (term terms) + (setf (values weight vars) (kbo-evaluate-term term subst (if (null ws) mult (* mult (pop ws))) weight vars))) + (values weight vars)) + +(defun kbo-compare-terms (x y &optional subst testval (mult 1)) + (dereference2 + x y subst + :if-variable*variable (if (eq x y) + (values '= 0 nil) + (values '? (* mult (- (variable-kbo-weight x) (variable-kbo-weight y))) (acons+ x mult (acons+ y (- mult) nil)))) + :if-constant*constant (if (eql x y) + (values '= 0 nil) + (let ((weight (* mult (- (constant-kbo-weight x) (constant-kbo-weight y))))) + (values + (cond + ((> weight 0) '>) + ((< weight 0) '<) + (t (symbol-ordering-compare x y))) + weight + nil))) + :if-variable*constant (values '? (* mult (- (variable-kbo-weight x) (constant-kbo-weight y))) (acons+ x mult nil)) + :if-constant*variable (values '? (* mult (- (constant-kbo-weight x) (variable-kbo-weight y))) (acons+ y (- mult) nil)) + :if-variable*compound (mvlet (((values weight vars) (kbo-evaluate-term y subst (- mult) (* mult (variable-kbo-weight x)) (acons+ x mult nil)))) + (values (if (alist-notany-plusp vars) '< '?) weight vars)) + :if-compound*variable (mvlet (((values weight vars) (kbo-evaluate-term x subst mult (* mult (- (variable-kbo-weight y))) (acons+ y (- mult) nil)))) + (values (if (alist-notany-minusp vars) '> '?) weight vars)) + :if-constant*compound (mvlet (((values weight vars) (kbo-evaluate-term y subst (- mult) (* mult (constant-kbo-weight x)) nil))) + (values + (cond + ((> weight 0) (if (alist-notany-minusp vars) '> '?)) + ((< weight 0) '<) + (t (ecase (symbol-ordering-compare x (head y)) + (> (if (alist-notany-minusp vars) '> '?)) + (< '<) + (? '?)))) + weight + vars)) + :if-compound*constant (mvlet (((values weight vars) (kbo-evaluate-term x subst mult (* mult (- (constant-kbo-weight y))) nil))) + (values + (cond + ((> weight 0) '>) + ((< weight 0) (if (alist-notany-plusp vars) '< '?)) + (t (ecase (symbol-ordering-compare (head x) y) + (> '>) + (< (if (alist-notany-plusp vars) '< '?)) + (? '?)))) + weight + vars)) + :if-compound*compound (cond + ((eq x y) + (values '= 0 nil)) + (t + (let ((head (head x))) + (cond + ((not (eq head (head y))) + (mvlet* (((values weight vars) (kbo-evaluate-term x subst mult 0 nil)) + ((values weight vars) (kbo-evaluate-term y subst (- mult) weight vars))) + (values + (cond + ((> weight 0) (if (alist-notany-minusp vars) '> '?)) + ((< weight 0) (if (alist-notany-plusp vars) '< '?)) + (t (ecase (symbol-ordering-compare head (head y)) + (> (if (alist-notany-minusp vars) '> '?)) + (< (if (alist-notany-plusp vars) '< '?)) + (? '?)))) + weight + vars))) + (t + (let* ((xargs (args x)) + (yargs (args y)) + (status (function-kbo-status head)) + (w (function-kbo-weight head)) + (ws (if (consp w) (rest w) nil)) + (w (if (consp w) (first w) w)) + (weight 0) + (vars nil) + com) + (cond + ((function-associative head) + (setf xargs (flatten-args head xargs subst)) + (setf yargs (flatten-args head yargs subst)))) + (ecase status + ((:left-to-right :right-to-left) + (let ((xargs (if (eq :right-to-left status) (reverse xargs) xargs)) + (yargs (if (eq :right-to-left status) (reverse yargs) yargs)) + (ws (if (null ws) nil (if (eq :right-to-left status) (reverse ws) ws)))) + (loop + (cond + ((or (null xargs) (null yargs)) + (cond + (xargs + (setf com '>) + (setf (values weight vars) (kbo-evaluate-terms xargs subst mult weight vars ws))) + (yargs + (setf com '<) + (setf (values weight vars) (kbo-evaluate-terms yargs subst (- mult) weight vars ws))) + (t + (setf com '=))) + (return)) + ((not (eq '= (setf (values com weight vars) (kbo-compare-terms (first xargs) (first yargs) subst nil (if (null ws) mult (* mult (pop ws))))))) + (setf (values weight vars) (kbo-evaluate-terms (rest xargs) subst mult weight vars ws)) + (setf (values weight vars) (kbo-evaluate-terms (rest yargs) subst (- mult) weight vars ws)) + (return)) + (t + (setf xargs (rest xargs)) + (setf yargs (rest yargs))))))) + ((:commutative :multiset) + (cond + ((and (eq :commutative status) (or (rrest xargs) (rrest yargs))) + (setf (values com weight vars) + (kbo-compare-terms (make-compound* *a-function-with-left-to-right-ordering-status* + (make-compound *a-function-with-multiset-ordering-status* (first xargs) (second xargs)) + (rrest xargs)) + (make-compound* *a-function-with-left-to-right-ordering-status* + (make-compound *a-function-with-multiset-ordering-status* (first yargs) (second yargs)) + (rrest yargs)) + subst + testval + mult))) + (t + (unless (eq '= (setf com (compare-term-multisets #'kbo-compare-terms xargs yargs subst nil))) + (setf (values weight vars) (kbo-evaluate-terms xargs subst mult weight vars ws)) + (setf (values weight vars) (kbo-evaluate-terms yargs subst (- mult) weight vars ws)))))) + ((:ac :none) + ;; (unimplemented) + (cond + ((equal-p x y subst) + (setf com '=)) + (t + (setf com '?) + (setf (values weight vars) (kbo-evaluate-terms xargs subst mult weight vars ws)) + (setf (values weight vars) (kbo-evaluate-terms yargs subst (- mult) weight vars ws)))))) + (cond + ((function-associative head) + (setf weight (+ weight (* mult w (- (max 1 (- (length xargs) 1)) (max 1 (- (length yargs) 1)))))))) + (values + (cond + ((eq '= com) '=) + ((> weight 0) (if (alist-notany-minusp vars) '> '?)) + ((< weight 0) (if (alist-notany-plusp vars) '< '?)) + ((eq '> com) (if (alist-notany-minusp vars) '> '?)) + ((eq '< com) (if (alist-notany-plusp vars) '< '?)) + (t '?)) + weight + vars))))))))) + +;;; knuth-bendix-ordering2.lisp EOF diff --git a/src/lisp-system.lisp b/src/lisp-system.lisp new file mode 100644 index 0000000..d1dfdef --- /dev/null +++ b/src/lisp-system.lisp @@ -0,0 +1,102 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: lisp-system.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +(defpackage :snark-lisp + (:use :common-lisp) + (:export + + ;; defined in mvlet.lisp + #:mvlet #:mvlet* + + ;; defined in progc.lisp + #:prog-> + #:*prog->-function-second-forms* + #:*prog->-special-forms* + + ;; defined in lisp.lisp + #:none + #:true #:false + #:definline + #:neq #:neql #:nequal #:nequalp + #:if-let #:when-let + #:iff #:implies + #:kwote #:unquote + #:rrest #:rrrest #:rrrrest + #:mklist #:firstn #:consn #:leafp + #:naturalp #:ratiop + #:carc #:cdrc #:caarcc #:cadrcc #:cdarcc #:cddrcc + #:lcons + #:cons-unless-nil #:push-unless-nil #:pushnew-unless-nil + #:dotails #:dopairs + #:choose + #:integers-between #:ints + #:length= #:length< #:length<= #:length> #:length>= + #:acons+ #:alist-notany-plusp #:alist-notany-minusp + #:cons-count + #:char-invert-case + #:to-string + #:find-or-make-package + #:percentage + #:print-current-time + #:leap-year-p #:days-per-month #:month-number + #:print-args + #:define-plist-slot-accessor + #:*print-pretty2* + #:with-standard-io-syntax2 + #:quit + + ;; defined in collectors.lisp + #:make-collector #:collector-value #:collect-item #:collect-list + #:make-queue #:queue-empty-p #:enqueue #:dequeue + #:collect #:ncollect + + ;; defined in map-file.lisp + #:mapnconc-stream-forms #:mapnconc-stream-lines + #:mapnconc-file-forms #:mapnconc-file-lines + #:read-file #:read-file-lines #:read-file-to-string + + ;; defined in clocks.lisp + #:initialize-clocks #:print-clocks + #:with-clock-on #:with-clock-off + #:total-run-time + #:print-incremental-time-used + + ;; defined in counters.lisp + #:make-counter + #:increment-counter #:decrement-counter + #:counter-value #:counter-values + #:princf + + ;; defined in pattern-match.lisp + #:pattern-match + + ;; defined in topological-sort.lisp + #:topological-sort* #:topological-sort + + ;; undefined symbols used by snark + #:implied-by #:xor #:nand #:nor + #:forall #:exists + #:$$cons #:$$list #:$$list* + )) + +(loads "mvlet" "progc" "lisp" "collectors" "map-file" "clocks" "counters" "pattern-match" "topological-sort") + +;;; lisp-system.lisp EOF diff --git a/src/lisp.lisp b/src/lisp.lisp new file mode 100644 index 0000000..6957ed6 --- /dev/null +++ b/src/lisp.lisp @@ -0,0 +1,566 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*- +;;; File: lisp.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-lisp) + +(defconstant none '$$none) ;special null value to use when NIL won't do +(defconstant true '$$true) +(defconstant false '$$false) + +(defmacro definline (name lambda-list &body body) + #-clisp + `(progn + (defun ,name ,lambda-list ,@body) + (define-compiler-macro ,name (&rest arg-list) + (cons '(lambda ,lambda-list ,@body) arg-list))) + #+clisp + `(defun ,name ,lambda-list ,@body)) + +(definline neq (x y) + (not (eq x y))) + +(definline neql (x y) + (not (eql x y))) + +(definline nequal (x y) + (not (equal x y))) + +(definline nequalp (x y) + (not (equalp x y))) + +(definline iff (x y) + (eq (not x) (not y))) + +(defmacro implies (x y) + ;; implies is a macro so that y is not evaluated if x is false + `(if ,x ,y t)) + +(defmacro if-let (binding thenform elseform) + (let ((block (gensym)) (temp (gensym))) + `(block ,block + (let ((,temp ,(second binding))) + (when ,temp + (return-from ,block + (let ((,(first binding) ,temp)) + ,thenform)))) + ,elseform))) + +(defmacro when-let (binding &rest forms) + `(if-let ,binding (progn ,@forms) nil)) + +(defun kwote (x &optional selectively) + (if (implies selectively (not (constantp x))) + (list 'quote x) + x)) + +(defun unquote (x) + (if (and (consp x) (eq 'quote (first x))) + (second x) + x)) + +(definline rrest (list) + (cddr list)) + +(definline rrrest (list) + (cdddr list)) + +(definline rrrrest (list) + (cddddr list)) + +(definline mklist (x) + (if (listp x) x (list x))) + +(defun firstn (list num) + ;; return a new list that contains the first num elements of list + (declare (type integer num)) + (cond + ((or (eql 0 num) (atom list)) + nil) + (t + (cons (first list) (firstn (rest list) (- num 1)))))) + +(defun consn (x y num) + ;; cons x and y n times + ;; (cons 'a '(b) 3) = (a a a b) + (declare (type integer num)) + (dotimes (dummy num) + (declare (type integer dummy) (ignorable dummy)) + (push x y)) + y) + +(defun leafp (x y) + (if (atom y) + (eql x y) + (or (leafp x (car y)) (leafp x (cdr y))))) + +(defun naturalp (x) + (and (integerp x) (not (minusp x)))) + +(defun ratiop (x) + (and (rationalp x) (not (integerp x)))) + +(defmacro carc (x) + `(car (the cons ,x))) + +(defmacro cdrc (x) + `(cdr (the cons ,x))) + +(defmacro caarcc (x) + `(carc (carc ,x))) + +(defmacro cadrcc (x) + `(carc (cdrc ,x))) + +(defmacro cdarcc (x) + `(cdrc (carc ,x))) + +(defmacro cddrcc (x) + `(cdrc (cdrc ,x))) + +(defmacro lcons (a* b* ab) + ;; (lcons a* b* ab) does lazy cons of a* and b* + ;; lcons does not evaluate a* or b* and returns nil if ab is nil + ;; lcons does not evaluate b* and treats it as nil if (cdr ab) is nil + ;; lcons returns ab if a* = (car ab) and b* = (cdr ab) + ;; otherwise, lcons conses a* and b* + ;; + ;; lcons is useful for writing functions that map over lists + ;; and return a modified list without unnecessary consing + ;; for example, the following applies a substitution to a list of terms + ;; (defun instantiate-list (terms subst) + ;; (lcons (instantiate-term (first terms) subst) + ;; (instantiate-list (rest terms) subst) + ;; terms)) + (assert (symbolp ab)) + (let ((tempa (gensym)) (tempb (gensym)) (tempa* (gensym)) (tempb* (gensym))) + (setf a* (sublis (list (cons `(car ,ab) tempa) + (cons `(carc ,ab) tempa) + (cons `(first ,ab) tempa) + (cons `(nth 0 ,ab) tempa)) + a* + :test #'equal)) + (setf b* (sublis (list (cons `(cdr ,ab) tempb) + (cons `(cdrc ,ab) tempb) + (cons `(rest ,ab) tempb) + (cons `(nthcdr 1 ,ab) tempb)) + b* + :test #'equal)) + `(if (null ,ab) + nil + (let* ((,tempa (car ,ab)) + (,tempa* ,a*) + (,tempb (cdrc ,ab))) + (if (null ,tempb) + (if (eql ,tempa ,tempa*) + ,ab + (cons ,tempa* nil)) + (let ((,tempb* ,b*)) + (if (and (eql ,tempb ,tempb*) + (eql ,tempa ,tempa*)) + ,ab + (cons ,tempa* ,tempb*)))))))) + +(definline cons-unless-nil (x &optional y) + ;; returns y if x is nil, otherwise returns (cons x y) + ;; if y is omitted: returns nil if x is nil, otherwise (list x) + (if (null x) y (cons x y))) + +(defmacro push-unless-nil (item place) + ;; doesn't evaluate place if item is nil + ;; always returns nil + (let ((v (gensym))) + `(let ((,v ,item)) + (unless (null ,v) + (push ,v ,place) + nil)))) + +(defmacro pushnew-unless-nil (item place &rest options) + ;; doesn't evaluate place or options if item is nil + ;; always returns nil + (let ((v (gensym))) + `(let ((,v ,item)) + (unless (null ,v) + (pushnew ,v ,place ,@options) + nil)))) + +(defmacro dotails ((var listform &optional resultform) &body body) + ;; dotails is just like dolist except the variable is bound + ;; to successive tails instead of successive elements of the list + `(do ((,var ,listform (rest ,var))) + ((endp ,var) + ,resultform) + ,@body)) + +(defmacro dopairs ((var1 var2 listform &optional resultform) &body body) + ;; (dopairs (x y '(a b c)) (print (list x y))) prints (a b), (a c), and (b c) + ;; doesn't handle declarations in body correctly + (let ((l1 (gensym)) (l2 (gensym)) (loop (gensym))) + `(do ((,l1 ,listform) ,var1 ,var2 ,l2) + ((endp ,l1) + ,resultform) + (setf ,var1 (pop ,l1)) + (setf ,l2 ,l1) + ,loop + (unless (endp ,l2) + (setf ,var2 (pop ,l2)) + ,@body + (go ,loop))))) + +(defun choose (function list k) + ;; apply function to lists of k items taken from list + (labels + ((choose* (cc l k n) + (cond + ((eql 0 k) + (funcall cc nil)) + ((eql n k) + (funcall cc l)) + (t + (prog-> + (decf n) + (pop l -> x) + (choose* l (- k 1) n ->* res) + (funcall cc (cons x res))) + (prog-> + (choose* l k n ->* res) + (funcall cc res)))))) + (let ((len (length list))) + (when (minusp k) + (incf k len)) + (cl:assert (<= 0 k len)) + (choose* function list k len) + nil))) + +(defun integers-between (low high) + ;; list of integers in [low,high] + (let ((i high) + (result nil)) + (loop + (when (< i low) + (return result)) + (push i result) + (decf i)))) + +(defun ints (low high) + ;; list of integers in [low,high] + (integers-between low high)) + +(defun length= (x y) + ;; if y is an integer then (= (length x) y) + ;; if x is an integer then (= x (length y)) + ;; otherwise (= (length x) (length y)) + (cond + ((or (not (listp y)) (when (not (listp x)) (psetq x y y x) t)) + (and (<= 0 y) + (loop + (cond + ((endp x) + (return (eql 0 y))) + ((eql 0 y) + (return nil)) + (t + (setf x (rest x) y (- y 1))))))) + (t + (loop + (cond + ((endp x) + (return (endp y))) + ((endp y) + (return nil)) + (t + (setf x (rest x) y (rest y)))))))) + +(defun length< (x y) + ;; if y is an integer then (< (length x) y) + ;; if x is an integer then (< x (length y)) + ;; otherwise (< (length x) (length y)) + (cond + ((not (listp y)) + (and (<= 1 y) + (loop + (cond + ((endp x) + (return t)) + ((eql 1 y) + (return nil)) + (t + (setf x (rest x) y (- y 1))))))) + ((not (listp x)) + (or (> 0 x) + (loop + (cond + ((endp y) + (return nil)) + ((eql 0 x) + (return t)) + (t + (setf x (- x 1) y (rest y))))))) + (t + (loop + (cond + ((endp x) + (return (not (endp y)))) + ((endp y) + (return nil)) + (t + (setf x (rest x) y (rest y)))))))) + +(defun length<= (x y) + ;; if y is an integer then (<= (length x) y) + ;; if x is an integer then (<= x (length y)) + ;; otherwise (<= (length x) (length y)) + (cond + ((not (listp y)) + (and (<= 0 y) + (loop + (cond + ((endp x) + (return t)) + ((eql 0 y) + (return nil)) + (t + (setf x (rest x) y (- y 1))))))) + ((not (listp x)) + (or (> 1 x) + (loop + (cond + ((endp y) + (return nil)) + ((eql 1 x) + (return t)) + (t + (setf x (- x 1) y (rest y))))))) + (t + (loop + (cond + ((endp x) + (return t)) + ((endp y) + (return nil)) + (t + (setf x (rest x) y (rest y)))))))) + +(definline length> (x y) + (length< y x)) + +(definline length>= (x y) + (length<= y x)) + +(defun acons+ (key delta alist &key test) + ;; creates a new association list with datum associated with key adjusted up or down by delta + ;; omits pairs with datum 0 + (labels + ((ac+ (alist) + (declare (type cons alist)) + (let ((pair (first alist)) + (alist1 (rest alist))) + (declare (type cons pair)) + (cond + ((if test (funcall test key (car pair)) (eql key (car pair))) + (let ((datum (+ (cdr pair) delta))) + (if (= 0 datum) alist1 (cons (cons key datum) alist1)))) + ((null alist1) + alist) + (t + (let ((alist1* (ac+ alist1))) + (if (eq alist1 alist1*) alist (cons pair alist1*)))))))) + (cond + ((= 0 delta) + alist) + ((null alist) + (cons (cons key delta) nil)) + (t + (let ((alist* (ac+ alist))) + (if (eq alist alist*) (cons (cons key delta) alist) alist*)))))) + +(defun alist-notany-plusp (alist) + (dolist (pair alist t) + (declare (type cons pair)) + (when (plusp (cdr pair)) + (return nil)))) + +(defun alist-notany-minusp (alist) + (dolist (pair alist t) + (declare (type cons pair)) + (when (minusp (cdr pair)) + (return nil)))) + +(defun cons-count (x) + (do ((n 0 (+ 1 (cons-count (carc x)) n)) + (x x (cdrc x))) + ((atom x) + n))) + +(defun char-invert-case (ch) + (cond + ((lower-case-p ch) + (char-upcase ch)) + ((upper-case-p ch) + (char-downcase ch)) + (t + ch))) + +(let ((case-preserved-readtable-cache nil)) + (defun case-preserved-readtable (&optional (readtable *readtable*)) + (cond + ((eq :preserve (readtable-case readtable)) + readtable) + ((cdr (assoc readtable case-preserved-readtable-cache)) + ) + (t + (let ((new-readtable (copy-readtable readtable))) + (setf (readtable-case new-readtable) :preserve) + (setf case-preserved-readtable-cache (acons readtable new-readtable case-preserved-readtable-cache)) + new-readtable))))) + +(defun to-string (arg &rest more-args) + (declare (dynamic-extent more-args)) + (flet ((string1 (x) + (cond + ((stringp x) + x) + ((symbolp x) + (symbol-name x)) + ((characterp x) + (string x)) + (t + (let ((*print-radix* nil)) + (cond + ((numberp x) + (princ-to-string x)) + (t + (let ((*readtable* (case-preserved-readtable))) + (princ-to-string x))))))))) + (if (null more-args) + (string1 arg) + (apply #'concatenate 'string (string1 arg) (mapcar #'string1 more-args))))) + +(defun find-or-make-package (pkg) + (cond + ((packagep pkg) + pkg) + ((find-package pkg) + ) + (t + (cerror "Make a package named ~A." "There is no package named ~A." (string pkg)) + (make-package pkg :use '(:common-lisp))))) + +(defun percentage (m n) + (values (round (* 100 m) n))) + +(defun print-time (year month date hour minute second &optional (destination *standard-output*) (basic nil)) + ;; per the ISO 8601 standard + (format destination + (if basic + "~4D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D" ;20020405T011216 + "~4D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D") ;2002-04-05T01:12:16 + year month date hour minute second)) + +(defun print-universal-time (utime &optional (destination *standard-output*) (basic nil)) + (mvlet (((values second minute hour date month year) (decode-universal-time utime))) + (print-time year month date hour minute second destination basic))) + +(defun print-current-time (&optional (destination *standard-output*) (basic nil)) + (print-universal-time (get-universal-time) destination basic)) + +(defun leap-year-p (year) + (and (eql 0 (mod year 4)) + (implies (eql 0 (mod year 100)) + (eql 0 (mod year 400))))) + +(defun days-per-month (month year) + (let ((month (month-number month))) + (cl:assert month) + (case month + (2 + (if (leap-year-p year) 29 28)) + ((4 6 9 11) + 30) + (otherwise + 31)))) + +(defun month-number (month) + (cond + ((or (symbolp month) (stringp month)) + (cdr (assoc (string month) + '(("JAN" . 1) ("JANUARY" . 1) + ("FEB" . 2) ("FEBRUARY" . 2) + ("MAR" . 3) ("MARCH" . 3) + ("APR" . 4) ("APRIL" . 4) + ("MAY" . 5) + ("JUN" . 6) ("JUNE" . 6) + ("JUL" . 7) ("JULY" . 7) + ("AUG" . 8) ("AUGUST" . 8) + ("SEP" . 9) ("SEPTEMBER" . 9) + ("OCT" . 10) ("OCTOBER" . 10) + ("NOV" . 11) ("NOVEMBER" . 11) + ("DEC" . 12) ("DECEMBER" . 12)) + :test #'string-equal))) + ((and (integerp month) (<= 1 month 12)) + month) + (t + nil))) + +(defun print-args (&rest args) + (declare (dynamic-extent args)) + (print args) + nil) + +(defmacro define-plist-slot-accessor (type name) + (let ((fun (intern (to-string type "-" name) :snark)) + (plist (intern (to-string type :-plist) :snark))) + `(progn + (#-(or allegro lispworks) definline #+(or allegro lispworks) defun ,fun (x) + (getf (,plist x) ',name)) + (defun (setf ,fun) (value x) + (if (null value) + (progn (remf (,plist x) ',name) nil) + (setf (getf (,plist x) ',name) value)))))) + +(defvar *print-pretty2* nil) + +#+ignore +(defmacro with-standard-io-syntax2 (&body forms) + (let ((pkg (gensym))) + `(let ((,pkg *package*)) + (with-standard-io-syntax + (let ((*package* ,pkg) + (*print-case* :downcase) + (*print-pretty* *print-pretty2*) +;; #+ccl (ccl:*print-abbreviate-quote* nil) +;; #+cmu (pretty-print::*print-pprint-dispatch* (pretty-print::make-pprint-dispatch-table)) +;; #+sbcl (sb-pretty::*print-pprint-dispatch* (sb-pretty::make-pprint-dispatch-table)) + #+clisp (*print-readably* nil) ;stop clisp from printing decimal points, #1=, etc + ) + ,@forms))))) + +(defmacro with-standard-io-syntax2 (&body forms) + `(let ((*print-pretty* *print-pretty2*) +;; #+ccl (ccl:*print-abbreviate-quote* nil) +;; #+cmu (pretty-print::*print-pprint-dispatch* (pretty-print::make-pprint-dispatch-table)) +;; #+sbcl (sb-pretty::*print-pprint-dispatch* (sb-pretty::make-pprint-dispatch-table)) + #+clisp (*print-readably* nil) ;stop clisp from printing decimal points, #1=, etc + ) + ,@forms)) + +(defun quit () + #+(or ccl cmu sbcl clisp lispworks) (common-lisp-user::quit) + #+allegro (excl::exit)) + +;;; lisp.lisp EOF diff --git a/src/loads.lisp b/src/loads.lisp new file mode 100644 index 0000000..15f7950 --- /dev/null +++ b/src/loads.lisp @@ -0,0 +1,30 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: loads.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2004. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +(defun loads (&rest names) + (dolist (name names) + (let ((file (make-pathname :name name :defaults *load-truename*))) + (declare (special *compile-me*)) + (load (if (and (boundp '*compile-me*) *compile-me*) + (compile-file file) + (or (probe-file (compile-file-pathname file)) file)))))) + +;;; loads.lisp EOF diff --git a/src/main.lisp b/src/main.lisp new file mode 100644 index 0000000..f3523ac --- /dev/null +++ b/src/main.lisp @@ -0,0 +1,2528 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: main.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim + (special + ordering-is-total + *printing-deleted-messages* + *agenda* + )) + +(defvar options-print-mode t) + +(defvar *snark-is-running* nil) +(defvar *agenda-of-false-rows-to-process*) +(defvar *agenda-of-new-embeddings-to-process*) +(defvar *agenda-of-input-rows-to-give*) +(defvar *agenda-of-input-rows-to-process*) +(defvar *agenda-of-backward-simplifiable-rows-to-process*) +(defvar *agenda-of-rows-to-process*) +(defvar *agenda-of-rows-to-give*) + +(defvar *proof*) + +(defvar *false-rows*) +(defvar *constraint-rows*) +(defvar *hint-rows*) + +(defvar *manual-ordering-results*) + +(defvar critique-options t) + +(defvar *propositional-abstraction-of-input-wffs*) + +(defvar *negative-hyperresolution*) + +(defvar *find-else-substitution* nil) + +(defvar *processing-row* nil) + +(defvar *hints-subsumed*) + +(declaim + (special + rewrite-strategy + clause-subsumption + subsumption-mark + *rewrites-used* + )) + +(defvar recursive-unstore nil) + +(defun critique-options () + (unless options-have-been-critiqued + (when (print-options-when-starting?) + (print-options)) + (unless (or (use-resolution?) + (use-hyperresolution?) + (use-negative-hyperresolution?) + (use-ur-resolution?) + (use-paramodulation?) + (use-ur-pttp?) + (use-resolve-code?)) + (warn "Neither resolution nor paramodulation are specified.")) + (setf options-have-been-critiqued t)) + nil) + +(defvar *number-of-given-rows* 0) +(defvar *number-of-backward-eliminated-rows* 0) +(defvar *number-of-agenda-full-deleted-rows* 0) +(declaim (type integer *number-of-given-rows* *number-of-backward-eliminated-rows*) + (type integer *number-of-agenda-full-deleted-rows*)) + +(defun clear-statistics () + (setf *row-count* 0) + (setf *number-of-rows* 0) + (setf *number-of-given-rows* 0) + (setf *number-of-backward-eliminated-rows* 0) + (setf *number-of-agenda-full-deleted-rows* 0) + nil) + +(defun print-summary (&key (clocks t) (term-memory t) (agenda t)) + (format t "~%; Summary of computation:") + (let ((total-number-of-rows *row-count*)) + (format t "~%; ~9D formulas have been input or derived (from ~D formulas)." total-number-of-rows *number-of-given-rows*) + (when (< 0 total-number-of-rows) + (format t "~%; ~9D (~2D%) were retained." *number-of-rows* (percentage *number-of-rows* total-number-of-rows)) + (when (< 0 *number-of-rows*) + (let ((number-of-still-kept-wffs (rowset-size *rows*)) + (number-of-reduced-wffs (- *number-of-backward-eliminated-rows* *number-of-agenda-full-deleted-rows*))) + (format t " Of these,") + (unless (eql 0 number-of-reduced-wffs) + (format t "~%; ~12D (~2D%) were simplified or subsumed later," number-of-reduced-wffs (percentage number-of-reduced-wffs *number-of-rows*))) + (unless (eql 0 *number-of-agenda-full-deleted-rows*) + (format t "~%; ~12D (~2D%) were deleted later because the agenda was full," *number-of-agenda-full-deleted-rows* (percentage *number-of-agenda-full-deleted-rows* *number-of-rows*))) + (format t "~%; ~12D (~2D%) are still being kept." number-of-still-kept-wffs (percentage number-of-still-kept-wffs *number-of-rows*)))))) + (when clocks + (format t "~%; ") + (print-clocks)) + (when term-memory + (format t "~%; ") + (print-term-memory)) + (when agenda + (format t "~%; ") + (print-agenda)) + nil) + +(defun print-rewrites (&key ancestry (test (print-rows-test?))) + (let ((rowset (make-rowset nil))) + (prog-> + (retrieve-all-entries #'tme-rewrites ->* e rewrites) + (declare (ignore e)) + (dolist rewrites ->* rewrite) + (unless (or (null (rewrite-row rewrite)) + (null (rewrite-condition rewrite))) + (rowset-insert (rewrite-row rewrite) rowset))) + (let ((*rows* rowset)) + (print-rows :ancestry ancestry :test test)))) + +(defvar rewrites-initialized) + +(defparameter initialization-functions + (list 'clear-statistics + 'initialize-features + 'initialize-row-contexts + 'initialize-term-hash + 'initialize-simplification-ordering-compare-equality-arguments-hash-table + 'initialize-sort-theory + 'initialize-symbol-ordering + 'initialize-symbol-table + 'initialize-sort-theory2 + 'initialize-symbol-table2 + 'initialize-propositional-abstraction-of-input-wffs + 'initialize-assertion-analysis + 'finalize-options + )) + +(defun initialize (&key (verbose t)) + (cond + (*snark-is-running* + (error "SNARK is already running.")) + (t + (initialize-clocks) + (when verbose + (format t "~&; Running SNARK from ~A in ~A ~A~:[~; (64-bit)~] on ~A at " + cl-user::*snark-system-pathname* + (lisp-implementation-type) + (lisp-implementation-version) + (member :x86-64 *features*) + (machine-instance)) + (print-current-time) + (format t "~%") + (force-output)) +;; (setf *random-state* (make-random-state t)) + (setf *szs-conjecture* nil) + (initialize-numberings) + (initialize-options) + (initialize-operator-syntax) + (nocomment) + (initialize-rows2) + (initialize-constants) + (initialize-variables) + (setf *number-of-new-symbols* 0) + (setf *new-symbol-prefix* (newsym-prefix)) + (setf *new-symbol-table* (make-hash-table)) + + (setf clause-subsumption t) + (setf subsumption-mark 0) + + (setf *manual-ordering-results* nil) +;; (dolist (modality modalatomsigns) (intensional (car modality))) +;; (intensional 'answer) ; ??? + + (make-term-memory :indexing-method :path) + (make-feature-vector-row-index) + (make-feature-vector-term-index) + (initialize-agenda) + (setf rewrites-initialized nil) +;; (store-boolean-ring-rewrites) + (setf ordering-is-total nil) + (setf *proof* nil) + (dolist (fn initialization-functions) + (funcall fn)) + nil))) + +(defun initialize-rows2 () + (initialize-rows) + (setf *false-rows* (make-rowset)) + (setf *constraint-rows* (make-rowset)) + (setf *hint-rows* (make-rowset)) + nil) + +(defmacro with-input-functions-disabled (symbols &body body) + (let ((symbol-temps (mapcar (lambda (x) (declare (ignore x)) (gensym)) symbols)) + (value-temps1 (mapcar (lambda (x) (declare (ignore x)) (gensym)) symbols)) + (value-temps2 (mapcar (lambda (x) (declare (ignore x)) (gensym)) symbols))) + `(let ,(mapcar (lambda (symbol symbol-temp) `(,symbol-temp ,symbol)) symbols symbol-temps) + (let (,@(mapcan (lambda (symbol-temp value-temp1 value-temp2) + (declare (ignorable value-temp2)) + (list `(,value-temp1 (function-input-code ,symbol-temp)) +;; `(,value-temp2 (function-logical-symbol-p ,symbol-temp)) + )) + symbol-temps value-temps1 value-temps2)) + (unwind-protect + (progn + ,@(mapcan (lambda (symbol-temp) + (list `(setf (function-input-code ,symbol-temp) nil) +;; `(setf (function-logical-symbol-p ,symbol-temp) nil) + )) + symbol-temps) + ,@body) + ,@(mapcan (lambda (symbol-temp value-temp1 value-temp2) + (declare (ignorable value-temp2)) + (list `(setf (function-input-code ,symbol-temp) ,value-temp1) +;; `(setf (function-logical-symbol-p ,symbol-temp) ,value-temp2) + )) + symbol-temps value-temps1 value-temps2)))))) + +(defun initialize-agenda () + (setf *agenda* + (list + (setf *agenda-of-false-rows-to-process* + (make-agenda :name "false rows to process" + :same-item-p #'same-agenda-item-p)) + (setf *agenda-of-new-embeddings-to-process* + (make-agenda :name "new embeddings to process" + :same-item-p #'same-agenda-item-p)) + (setf *agenda-of-input-rows-to-process* + (make-agenda :name "input rows to process" + :same-item-p #'same-agenda-item-p)) + (setf *agenda-of-backward-simplifiable-rows-to-process* + (make-agenda :name "backward simplifiable rows to process" + :same-item-p #'same-agenda-item-p)) + (setf *agenda-of-rows-to-process* + (make-agenda :name "rows to process" + :length-limit (agenda-length-before-simplification-limit?) + :same-item-p #'same-agenda-item-p)) + (setf *agenda-of-input-rows-to-give* + (make-agenda :name "input rows to give" + :same-item-p #'same-agenda-item-p)) + (setf *agenda-of-rows-to-give* + (make-agenda :name "rows to give" + :length-limit (agenda-length-limit?) + :length-limit-deletion-action #'unstore-agenda-item + :same-item-p #'same-agenda-item-p))))) + +(defun initialize-rewrites () + (prog-> + (map-symbol-table ->* name kind symbol) + (declare (ignore name kind)) + (when (function-symbol-p symbol) + (dolist (rewrite (function-rewrites symbol)) + (assert-rewrite rewrite))))) + +(defun store-boolean-ring-rewrites () + (declare-logical-symbol '%rewrite) + (dolist (rewrite '((%rewrite (or ?x ?y) (xor (and ?x ?y) ?x ?y)) ;translate OR + (%rewrite (implies ?x ?y) (xor (and ?x ?y) ?x true)) ;translate IMPLIES + (%rewrite (implied-by ?y ?x) (xor (and ?x ?y) ?x true)) + (%rewrite (iff ?x ?y) (xor ?x ?y true)) ;translate IFF + (%rewrite (not ?x) (xor ?x true)) +;; (%rewrite (xor ?x false) ?x) +;; (%rewrite (xor ?x ?x) false) +;; (%rewrite (xor ?y ?x ?x) ?y) ;embedding of above +;; (%rewrite (and ?x true) ?x) +;; (%rewrite (and ?x false) false) +;; (%rewrite (and ?x ?x) ?x) +;; (%rewrite (and ?y ?x ?x) (and ?x ?y)) ;embedding of above + (%rewrite (and ?x (xor ?y ?z)) (xor (and ?x ?y) (and ?x ?z))) + )) + (store-rewrite + (renumber + (with-input-functions-disabled + (*and* *or* *not* *implies* *implied-by* *iff* *xor* *if*) + (let ((*input-proposition-variables* t)) + (input-wff rewrite)))) + '>))) + +(defun renumber-row (row) + (let ((rsubst nil)) + (let ((wff (row-wff row))) + (setf (values wff rsubst) (renumber wff nil rsubst)) + (setf (row-wff row) wff)) + (let ((constraint-alist (row-constraints row))) + (when constraint-alist + (setf (values constraint-alist rsubst) (renumber constraint-alist nil rsubst)) + (setf (row-constraints row) constraint-alist))) + (let ((answer (row-answer row))) + (unless (eq false answer) + (setf (values answer rsubst) (renumber answer nil rsubst)) + (setf (row-answer row) answer))) + rsubst)) + +(defvar *embedding-variables* nil) ;list of embedding variables + +(defun embedding-variable-p (x) + (let ((l *embedding-variables*)) + (and l (member x l :test #'eq)))) + +(defvar *assert-rewrite-polarity* nil) + +(defun assert-rewrite-check (wff) + (declare (ignore wff)) +;;(cl:assert (member (instantiating-direction (arg1 wff) (arg2 wff) nil) '(> <>))) + ) + +(defun assert-rewrite (wff &key name (reason 'assertion) (input t) (partitions (use-partitions?)) (conditional nil)) + (cl:assert (symbolp name)) + (macrolet + ((make-row1 (wff) + `(make-row :wff ,wff + :number (incf *number-of-rows*) + :name name + :context context + :reason reason + :input-wff input-wff))) + (prog-> + (the-row-context2 (ecase reason (assertion (assert-context?)) (assumption :current)) partitions -> context) + (if conditional '>? '> -> dir) + (if input (input-wff wff) (values wff nil (term-to-lisp wff)) -> wff dp-alist input-wff) + (declare (ignore dp-alist)) + (cond + ((or (equality-p wff) (and (equivalence-p wff) (atom-p (arg1 wff)))) + (renumber wff -> wff rsubst) + (declare (ignore rsubst)) + (assert-rewrite-check wff) + (store-rewrite wff dir (make-row1 wff))) + ((literal-p wff) + (literal-p wff -> atom polarity) + (renumber atom -> atom rsubst) + (declare (ignore rsubst)) + (store-rewrite2 atom (if (eq :pos polarity) true false) (make-row1 wff) nil)) + ((and (implication-p wff) + (atom-p (arg1 wff))) + (prog-> + (make-compound *iff* (arg1 wff) (arg2 wff) -> wff1) + (renumber wff1 -> wff1 rsubst) + (declare (ignore rsubst)) + (quote :pos -> *assert-rewrite-polarity*) + (assert-rewrite-check wff1) + (store-rewrite wff1 dir (make-row1 wff)))) + ((and (implication-p wff) + (negation-p (arg1 wff)) + (atom-p (arg1 (arg1 wff)))) + (prog-> + (make-compound *iff* (arg1 (arg1 wff)) (negate (arg2 wff)) -> wff1) + (renumber wff1 -> wff1 rsubst) + (declare (ignore rsubst)) + (quote :neg -> *assert-rewrite-polarity*) + (assert-rewrite-check wff1) + (store-rewrite wff1 dir (make-row1 wff)))) + ((and (reverse-implication-p wff) + (atom-p (arg1 wff))) + (prog-> + (make-compound *iff* (arg1 wff) (arg2 wff) -> wff1) + (renumber wff1 -> wff1 rsubst) + (declare (ignore rsubst)) + (quote :neg -> *assert-rewrite-polarity*) + (assert-rewrite-check wff1) + (store-rewrite wff1 dir (make-row1 wff)))) + ((and (reverse-implication-p wff) + (negation-p (arg1 wff)) + (atom-p (arg1 (arg1 wff)))) + (prog-> + (make-compound *iff* (arg1 (arg1 wff)) (negate (arg2 wff)) -> wff1) + (renumber wff1 -> wff1 rsubst) + (declare (ignore rsubst)) + (quote :pos -> *assert-rewrite-polarity*) + (assert-rewrite-check wff1) + (store-rewrite wff1 dir (make-row1 wff)))) + ((and (conjunction-p wff) + (implication-p (arg1 wff)) + (implication-p (arg2 wff)) + (equal-p (arg1 (arg1 wff)) (arg2 (arg2 wff))) + (atom-p (arg1 (arg1 wff)))) + (prog-> + (make-compound *iff* (arg1 (arg1 wff)) (arg2 (arg1 wff)) -> wff1) + (renumber wff1 -> wff1 rsubst) + (declare (ignore rsubst)) + (quote :pos -> *assert-rewrite-polarity*) + (assert-rewrite-check wff1) + (store-rewrite wff1 dir (make-row1 (arg1 wff)))) + (prog-> + (make-compound *iff* (arg2 (arg2 wff)) (arg1 (arg2 wff)) -> wff2) + (renumber wff2 -> wff2 rsubst) + (declare (ignore rsubst)) + (quote :neg -> *assert-rewrite-polarity*) + (assert-rewrite-check wff2) + (store-rewrite wff2 dir (make-row1 (arg2 wff))))) ;same name? + ((and (conjunction-p wff) + (implication-p (arg1 wff)) + (reverse-implication-p (arg2 wff)) + (equal-p (arg1 (arg1 wff)) (arg1 (arg2 wff))) + (atom-p (arg1 (arg1 wff)))) + (prog-> + (make-compound *iff* (arg1 (arg1 wff)) (arg2 (arg1 wff)) -> wff1) + (renumber wff1 -> wff1 rsubst) + (declare (ignore rsubst)) + (quote :pos -> *assert-rewrite-polarity*) + (assert-rewrite-check wff1) + (store-rewrite wff1 dir (make-row1 (arg1 wff)))) + (prog-> + (make-compound *iff* (arg1 (arg2 wff)) (arg2 (arg2 wff)) -> wff2) + (renumber wff2 -> wff2 rsubst) + (declare (ignore rsubst)) + (quote :neg -> *assert-rewrite-polarity*) + (assert-rewrite-check wff2) + (store-rewrite wff2 dir (make-row1 (arg2 wff))))) ;same name? + (t + (error "Improper form for assert-rewrite.")))) + nil)) + +(defmacro assertion (wff &rest keys-and-values) + (cond + ((getf keys-and-values :ignore) + nil) + (t + `(assertionfun ',wff ',keys-and-values)))) ;don't evaluate wff or options + +(defun assertionfun (wff keys-and-values) + (apply 'assert wff keys-and-values)) + +(defun assert (wff + &key + name + conc-name + (answer false) + constraints ;2-lists of theory name and wff + (reason 'assertion) + context + (partitions (use-partitions?)) + (supported nil supported-supplied) + (sequential nil sequential-supplied) + documentation + author ;for KIF + source ;for KIF + (input-wff none) + (magic (use-magic-transformation?)) + closure) + (with-clock-on assert + (when name + (unless (can-be-row-name name 'warn) + (setf name nil))) + (when (eq 'conjecture reason) + (setf wff `(not ,wff)) + (setf reason 'negated_conjecture) + (setf *szs-conjecture* t)) + (cl:assert (member reason '(assertion assumption negated_conjecture hint))) + (unless supported-supplied + (setf supported (ecase reason + (assertion (assert-supported?)) + (assumption (assume-supported?)) + (negated_conjecture (prove-supported?)) + (hint nil)))) + (cl:assert (member supported '(nil t :uninherited))) + (unless sequential-supplied + (setf sequential (ecase reason + (assertion (assert-sequential?)) + (assumption (assume-sequential?)) + (negated_conjecture (prove-sequential?)) + (hint nil)))) + (cl:assert (member sequential '(nil t :uninherited))) + (unless context + (setf context (ecase reason + (assertion (assert-context?)) + ((assumption negated_conjecture hint) :current)))) + (when (eq :current context) + (setf context (current-row-context))) + (let ((n 0)) + (prog-> + (not (use-well-sorting?) -> *%check-for-well-sorted-atom%*) + (input-wff wff :clausify (use-clausification?) -> wff dp-alist input-wff1 input-wff-subst) + (declare (ignore dp-alist)) + (when *find-else-substitution* + (setf wff (instantiate wff *find-else-substitution*))) + (mapcar (lambda (x) (cons (first x) (input-wff `(not ,(second x)) :*input-wff-substitution* input-wff-subst))) constraints -> constraint-alist) + (when (eq 'from-wff answer) + (cond + ((and (consp input-wff1) (eq 'forall (first input-wff1))) + (setf answer (cons 'values (mapcar (lambda (x) (if (consp x) (first x) x)) (second input-wff1))))) + ((and (consp input-wff1) (eq 'not (first input-wff1)) (consp (second input-wff1)) (eq 'exists (first (second input-wff1)))) + (setf answer (cons 'values (mapcar (lambda (x) (if (consp x) (first x) x)) (second (second input-wff1)))))) + (t + (setf answer false)))) + (input-wff answer :*input-wff-substitution* input-wff-subst -> answer) + ;; (if (use-equality-elimination?) (equality-eliminate-wff wff) wff -> wff) + (if (and magic (not (eq 'hint reason))) (magic-transform-wff wff :transform-negative-clauses supported :transform-positive-units (test-option29?)) wff -> wff) + (well-sort-wffs (list* wff answer (mapcar #'cdr constraint-alist)) ->* subst) + (incf n) + (map-conjuncts wff ->* wff) + (catch 'fail + (let* ((wff (fail-when-true (instantiate wff subst))) + (row (make-row :wff wff + :constraints (fail-when-constraint-true (instantiate constraint-alist subst)) + :answer (if (and magic (magic-goal-occurs-p wff)) + false + (fail-when-disallowed (instantiate answer subst))) + :context (the-row-context2 context partitions) + :reason reason + :supported supported + :sequential sequential + :conc-name (and conc-name (if (stringp conc-name) conc-name (funcall conc-name wff))) + :documentation documentation + :author author + :source source + :input-wff (if (neq none input-wff) input-wff input-wff1) + :name name))) + #+ignore + (when (use-constraint-purification?) + (setf row (constraint-purify-row row))) + (when (use-assertion-analysis?) + (assertion-analysis row)) + (record-new-input-wff row)))) + (unless (eql 1 n) + (with-standard-io-syntax2 + (warn "Input wff ~A has ~D well-sorted instances." wff n))))) + (when closure + (closure))) + +(defun assume (wff &rest keys-and-values) + (apply #'assert wff (append keys-and-values (list :reason 'assumption)))) + +(defun prove (wff &rest keys-and-values) + (apply #'assert wff (append keys-and-values (list :reason 'conjecture :closure (prove-closure?))))) + +(defun new-prove (wff &rest keys-and-values) + (new-row-context) + (apply #'prove wff keys-and-values)) + +(defun hint (wff &rest keys-and-values) + (apply #'assert wff (append keys-and-values (list :reason 'hint)))) + +(defun fail () + (throw 'fail nil)) + +(defun fail-when-nil (x) + (if (null x) + (throw 'fail nil) + x)) + +(defun fail-when-true (x) + (if (eq true x) + (throw 'fail nil) + x)) + +(defun fail-when-false (x) + (if (eq false x) + (throw 'fail nil) + x)) + +(defun fail-when-constraint-true (constraint-alist) + (dolist (x constraint-alist constraint-alist) + (when (eq true (cdr x)) + (throw 'fail nil)))) + +(defun fail-when-disallowed (answer) + (if (answer-disallowed-p answer) + (throw 'fail nil) + answer)) + +(defvar *check-for-disallowed-answer* nil) + +(defun answer-disallowed-p (answer) + (if (and (rewrite-answers?) (not *check-for-disallowed-answer*)) + nil + (disallowed-symbol-occurs-in-answer-p answer nil))) + +(defun make-demodulant (row1 row2 wff2* context1 context2) + (cond + ((eq true wff2*) + :tautology) + (t + (prog-> + (context-intersection-p context1 context2 ->nonnil context) + (make-row :wff (instantiate wff2* 1) + :constraints (instantiate (row-constraints row2) 1) + :answer (instantiate (row-answer row2) 1) + :supported (row-supported row2) + :sequential (row-sequential row2) + :context context + :reason `(rewrite ,row2 ,row1)))))) + +(defun make-answer2 (row1 row2 subst cond swap) + (let ((answer1 (instantiate (row-answer row1) 1 subst)) + (answer2 (instantiate (row-answer row2) 2 subst))) + (fail-when-disallowed + (cond + ((eq false answer1) + answer2) + ((eq false answer2) + answer1) + ((equal-p answer1 answer2) + answer1) + ((use-conditional-answer-creation?) + (if swap + (make-conditional-answer (instantiate cond subst) answer2 answer1 nil) + (make-conditional-answer (instantiate cond subst) answer1 answer2 nil))) + (t + (disjoin answer1 answer2)))))) + +(defmacro make-resolvent-part (rown atomn atomn* truthvaluen n subst) + (let ((wffn (gensym)) + (atom (gensym)) + (polarity (gensym)) + (atom* (gensym))) + `(prog-> + (row-wff ,rown -> ,wffn) + (cond + ((eq ,wffn ,atomn) + ,truthvaluen) + (t + (map-atoms-in-wff-and-compose-result ,wffn ->* ,atom ,polarity) + (declare (ignore ,polarity)) + (cond + ((eq ,atom ,atomn) + ,truthvaluen) + (t + (instantiate ,atom ,n ,subst -> ,atom*) + (cond + ((equal-p ,atom* ,atomn* subst) + ,truthvaluen) + (t + ,atom*))))))))) + +(defun make-resolvent1 (row1 atom1 truthvalue1 row2 atom2 truthvalue2 subst context1 context2) + (prog-> + (context-intersection-p context1 context2 ->nonnil context) + (instantiate atom1 1 -> atom1*) + (instantiate atom2 2 -> atom2*) + (disjoin + (make-resolvent-part row1 atom1 atom1* truthvalue1 1 subst) + (make-resolvent-part row2 atom2 atom2* truthvalue2 2 subst) + -> wff) + (cond + ((eq true wff) + :tautology) + (t + (make-row :wff wff + :constraints (disjoin-alists + (instantiate (row-constraints row1) 1 subst) + (instantiate (row-constraints row2) 2 subst)) + :answer (make-answer2 row1 row2 subst atom1* (eq false truthvalue1)) + :supported (or (row-supported-inheritably row1) (row-supported-inheritably row2)) + :sequential (or (row-sequential-inheritably row1) (row-sequential-inheritably row2)) + :context context + :reason (if (eq true truthvalue1) `(resolve ,row1 ,row2) `(resolve ,row2 ,row1))))))) + +(defun make-resolvent (row1 atom1 atom1* truthvalue1 row2 atom2 atom2* truthvalue2 subst + context1 context2) + (let ((made nil)) + (prog-> + (context-intersection-p context1 context2 ->nonnil context) + (catch 'fail + (record-new-derived-row + (make-row :wff (fail-when-true + (if (eq true truthvalue1) + (disjoin + (make-resolvent-part row2 atom2 atom2* truthvalue2 2 subst) + (make-resolvent-part row1 atom1 atom1* truthvalue1 1 subst)) + (disjoin + (make-resolvent-part row1 atom1 atom1* truthvalue1 1 subst) + (make-resolvent-part row2 atom2 atom2* truthvalue2 2 subst)))) + :constraints (fail-when-constraint-true + (disjoin-alists + (instantiate (row-constraints row1) 1 subst) + (instantiate (row-constraints row2) 2 subst))) + :answer (make-answer2 row1 row2 subst atom1* (eq false truthvalue1)) + :supported (or (row-supported-inheritably row1) (row-supported-inheritably row2)) + :sequential (or (row-sequential-inheritably row1) (row-sequential-inheritably row2)) + :context context + :reason (if (eq true truthvalue1) `(resolve ,row1 ,row2) `(resolve ,row2 ,row1)))) + (setf made t))) + made)) + +(defun make-resolventa (row1 atom1 atom1* truthvalue1 subst context1 &optional residue) + (prog-> + (catch 'fail + (record-new-derived-row + (make-row :wff (fail-when-true + (let ((wff (make-resolvent-part row1 atom1 atom1* truthvalue1 1 subst))) + (if residue (disjoin (instantiate residue subst) wff) wff))) + :constraints (fail-when-constraint-true (instantiate (row-constraints row1) 1 subst)) + :answer (fail-when-disallowed (instantiate (row-answer row1) 1 subst)) + :supported (row-supported row1) + :sequential (row-sequential row1) + :context context1 + :reason `(resolve ,row1 ,(function-code-name (head atom1*)))))))) + +(defun make-resolventb (row1 residue subst context1) + (prog-> + (catch 'fail + (record-new-derived-row + (make-row :wff (fail-when-true (instantiate residue subst)) + :constraints (fail-when-constraint-true (instantiate (row-constraints row1) 1 subst)) + :answer (fail-when-disallowed (instantiate (row-answer row1) 1 subst)) + :supported (row-supported row1) + :sequential (row-sequential row1) + :context context1 + :reason `(resolve ,row1 :resolve-code)))))) + +(defun make-resolventc (row subst context constraint-alist*) + (prog-> + (catch 'fail + (record-new-derived-row + (make-row :wff (fail-when-true (instantiate (row-wff row) 1 subst)) + :constraints (fail-when-constraint-true (instantiate constraint-alist* 1 subst)) + :answer (fail-when-disallowed (instantiate (row-answer row) 1 subst)) + :supported (row-supported row) + :sequential (row-sequential row) + :context context + :reason `(resolve ,row :code-for-$$eq)))))) + +(defun make-hyperresolvent-nucleus-part (nucleus subst) + (prog-> + (hyperresolution-nucleus-polarity -> nucleus-polarity) + (if (eq :pos nucleus-polarity) false true -> truthvalue) + (map-atoms-in-wff-and-compose-result (row-wff nucleus) ->* atom polarity) + (cond + ((and (eq nucleus-polarity polarity) (not (do-not-resolve atom))) + truthvalue) + (t + (instantiate atom 1 subst))))) + +(defvar *resolve-functions-used* nil) + +(defun make-hyperresolvent (nucleus electrons residues subst) + (prog-> + (row-context-live? nucleus ->nonnil context) + (catch 'fail + (let ((k (+ (length electrons) 1)) + (wff (fail-when-true (make-hyperresolvent-nucleus-part nucleus subst))) + (constraint-alist (fail-when-constraint-true (instantiate (row-constraints nucleus) 1 subst))) + (answer (fail-when-disallowed (instantiate (row-answer nucleus) 1 subst))) + (supported (row-supported-inheritably nucleus)) + (sequential (row-sequential-inheritably nucleus)) + parents) + (dolist (residue residues) + (setf wff (fail-when-true (disjoin (instantiate residue subst) wff)))) + (dolist (x electrons) + (mvlet (((list electron+ atom atom*) x)) + (setf wff (fail-when-true + (disjoin + (make-resolvent-part electron+ atom atom* (if *negative-hyperresolution* true false) k subst) + wff))) + (when (row-constraints electron+) + (setf constraint-alist (fail-when-constraint-true + (disjoin-alists + (instantiate (row-constraints electron+) k subst) + constraint-alist)))) + (unless (eq false (row-answer electron+)) + (setf answer (cond + ((eq false answer) + (fail-when-disallowed (instantiate (row-answer electron+) k subst))) + ((not (use-conditional-answer-creation?)) + (disjoin + (fail-when-disallowed (instantiate (row-answer electron+) k subst)) + answer)) + (*negative-hyperresolution* + (make-conditional-answer + (fail-when-disallowed (instantiate atom* k subst)) + (fail-when-disallowed (instantiate (row-answer electron+) k subst)) + answer + nil)) + (t + (make-conditional-answer + (fail-when-disallowed (instantiate atom* k subst)) + answer + (fail-when-disallowed (instantiate (row-answer electron+) k subst)) + nil))))) + (setf context (fail-when-nil (context-intersection-p + context (row-context-live? electron+)))) + (unless supported + (setf supported (row-supported-inheritably electron+))) + (unless sequential + (setf sequential (row-sequential-inheritably electron+))) + (push electron+ parents) + (decf k))) + (push nucleus parents) + (record-new-derived-row + (make-row :wff wff + :constraints constraint-alist + :answer answer + :supported supported + :sequential sequential + :context context + :reason (if *negative-hyperresolution* + `(negative-hyperresolve ,@parents ,@*resolve-functions-used*) + `(hyperresolve ,@parents ,@*resolve-functions-used*)))))))) + +(defun make-ur-resolvent (nucleus electrons target-atom target-polarity subst) + (prog-> + (row-context-live? nucleus ->nonnil context) + (catch 'fail + (let ((k (+ (length electrons) 1)) + (constraint-alist (fail-when-constraint-true (instantiate (row-constraints nucleus) 1 subst))) + (answer (fail-when-disallowed (instantiate (row-answer nucleus) 1 subst))) + (supported (row-supported-inheritably nucleus)) + (sequential (row-sequential-inheritably nucleus))) + (dolist (electron electrons) + (when (row-constraints electron) + (setf constraint-alist (fail-when-constraint-true + (disjoin-alists + (instantiate (row-constraints electron) k subst) + constraint-alist)))) + (unless (eq false (row-answer electron)) + (setf answer (cond + ((eq false answer) + (fail-when-disallowed (instantiate (row-answer electron) k subst))) + ((not (use-conditional-answer-creation?)) + (disjoin + (fail-when-disallowed (instantiate (row-answer electron) k subst)) + answer)) + (t + (make-conditional-answer + (fail-when-disallowed (instantiate (row-wff electron) k subst)) + answer + (fail-when-disallowed (instantiate (row-answer electron) k subst)) + nil))))) + (setf context (fail-when-nil (context-intersection-p + context (row-context-live? electron)))) + (unless supported + (setf supported (row-supported-inheritably electron))) + (unless sequential + (setf sequential (row-sequential-inheritably electron))) + (decf k)) + (record-new-derived-row + (make-row :wff (if target-atom + (if (eq :pos target-polarity) + (instantiate target-atom subst) + (make-compound *not* (instantiate target-atom subst))) + false) + :constraints constraint-alist + :answer answer + :supported supported + :sequential sequential + :context context + :reason `(ur-resolve ,nucleus ,@(reverse electrons) ,@*resolve-functions-used*))))))) + +(defun make-paramodulant-form (cc value1* term2* wff2* subst) + (cond + ((not (term-subsort-p value1* term2* subst)) + ) + ((use-single-replacement-paramodulation?) + (substitute-once cc value1* term2* wff2* subst)) + (t + (funcall cc (substitute value1* term2* wff2* subst))))) + +(defun make-paramodulant (row1 equality1 value1* row2 term2* subst context1 context2) + (prog-> + (context-intersection-p context1 context2 ->nonnil context) + (catch 'fail + (fail-when-constraint-true + (disjoin-alists + (instantiate (row-constraints row2) 2 subst) + (instantiate (row-constraints row1) 1 subst)) + -> constraint) + (instantiate equality1 1 subst -> equality1*) + (make-answer2 row1 row2 subst equality1* t -> answer) + (or (row-supported-inheritably row1) (row-supported-inheritably row2) -> supported) + (or (row-sequential-inheritably row1) (row-sequential-inheritably row2) -> sequential) + (list 'paramodulate row2 row1 -> reason) + (make-resolvent-part row1 equality1 equality1* false 1 subst -> w1) + (instantiate value1* subst -> value1*) + (instantiate (row-wff row2) 2 subst -> wff2*) + (make-paramodulant-form value1* term2* wff2* subst ->* w2) + (catch 'fail + (record-new-derived-row + (make-row :wff (fail-when-true (disjoin w1 w2)) + :constraints constraint + :answer answer + :supported supported + :sequential sequential + :context context + :reason reason)))))) + +(defun make-paramodulanta (value1* row2 term2* subst context2) + (prog-> + (catch 'fail + (fail-when-constraint-true (instantiate (row-constraints row2) 2 subst) -> constraint) + (fail-when-disallowed (instantiate (row-answer row2) 2 subst) -> answer) + (row-supported-inheritably row2 -> supported) + (row-sequential-inheritably row2 -> sequential) + (list 'paramodulate row2 (function-code-name (head term2*)) -> reason) + (make-paramodulant-form + (instantiate value1* subst) term2* (instantiate (row-wff row2) 2 subst) subst ->* w2) + (catch 'fail + (record-new-derived-row + (make-row :wff (fail-when-true w2) + :constraints constraint + :answer answer + :supported supported + :sequential sequential + :context context2 + :reason reason)))))) + +(defun canonicalize-wff (wff) + (prog-> + (map-atoms-in-wff-and-compose-result wff ->* atom polarity) + (unless (variable-p atom) ;shouldn't be variable atom + (setf atom (hash-term atom)) + (map-terms-in-atom atom nil polarity ->* term polarity) + (declare (ignore polarity)) + (unless (variable-p term) + (tm-store term))) + atom)) + +(defun index-terms-in-atom-of-derived-wff (atom polarity row) + (setf atom (hash-term atom)) + (prog-> + (map-terms-in-atom atom nil polarity ->* term polarity) + (declare (ignore polarity)) + (dereference + term nil + :if-constant (unless (constant-constructor term) ;suppress reduction, paramodulation + (tm-store term) + (insert-into-rows-containing-term row term)) + :if-compound (progn + (tm-store term) + (insert-into-rows-containing-term row term)))) + atom) + +(defun dont-make-embedding-p (a b) + (declare (ignore b)) + ;; don't make embedding if ac lhs has a single-occurrence top-level variable + (let ((head (head a))) + (and + (function-associative head) + (function-commutative head) + (let ((terms-and-counts (count-arguments head (args a) nil))) + (loop for tc1 in terms-and-counts + thereis (and + (eql 1 (tc-count tc1)) + (variable-p (tc-term tc1)) + (same-sort? (function-sort head) (variable-sort (tc-term tc1))) + (loop for tc2 in terms-and-counts + never (and (neq tc1 tc2) (variable-occurs-p (tc-term tc1) (tc-term tc2) nil))))))))) + +(defun embedding-types (pattern value) + (let ((head (head pattern))) + (when (function-associative head) + (unless (dont-make-embedding-p pattern value) + (cond + ((function-commutative head) + :l) + (t + :l&r)))))) + +(defun store-rewrite2 (pattern value row conditional) + (cond + ((variable-p pattern) + nil) + (t + (prog-> + (make-rewrite row + pattern + value + (if conditional 'simplification-ordering-greaterp t) + (symbol-count pattern) + (new-variables value nil (variables pattern)) + *assert-rewrite-polarity* + -> rewrite) + (setf pattern (hash-term pattern)) + (tm-store pattern) + (when (compound-p pattern) + (setf (function-rewritable-p (head pattern)) t) + (setf (rewrite-embeddings rewrite) (embedding-types pattern value))) + (push rewrite (rewrites pattern)) + (when row + (push rewrite (row-rewrites row)))) + t))) + +(defun store-rewrite (equality-or-equivalence &optional dir row) + (let ((args (args equality-or-equivalence)) stored) + (unless dir + (setf dir (simplification-ordering-compare-equality-arguments equality-or-equivalence nil t))) + (when (and (or (eq '> dir) (eq '>? dir) (eq '<>? dir)) + (store-rewrite2 (first args) (second args) row (neq '> dir))) + (setf stored t)) + (when (and (or (eq dir '<) (eq dir '?)) + (store-rewrite2 (second args) (first args) row (neq '< dir))) + (setf stored t)) + (cond + (stored + ) + ((member dir '(> >? < ?)) + (warn "Cannot use equality or equivalence ~A as rewrite." equality-or-equivalence)) + (t + (when (print-unorientable-rows?) + (print-unorientable-wff equality-or-equivalence)))))) + +(defun maybe-store-atom-rewrite (atom truth-value row) + (when (use-simplification-by-units?) + (unless (and (test-option43?) (do-not-resolve atom)) + (store-rewrite (make-compound *iff* atom truth-value) '> row)))) + +(defun store-given-row (row) + (unless (row-given-p row) + (prog-> + (map-atoms-in-wff (row-wff row) ->* atom polarity) + (when (and (eq :pos polarity) (equality-p atom)) + (args atom -> args) + (first args -> arg1) + (second args -> arg2) + (unless (equal-p arg1 arg2) + (simplification-ordering-compare-equality-arguments atom nil -> dir) + (unless (eq '< dir) + (store-given-row-equality row arg1 arg2)) + (unless (eq '> dir) + (store-given-row-equality row arg2 arg1))))) + (setf (row-status row) :given)) + row) + +(defun store-given-row-equality (row pattern value) + (unless (variable-p pattern) + (prog-> + (setf pattern (hash-term pattern)) + (tm-store pattern) + (pushnew (cons row value) + (rows-containing-paramodulatable-equality pattern) + :test (lambda (x y) (and (eq (car x) (car y)) (eq (cdr x) (cdr y))))) + ))) + +(defun store-derived-wff (row) + ;; indexes atomic formulas of row so they can be retrieved for subsumption + ;; indexes terms of row so they can be retrieved for demodulation + ;; make rewrite from row if possible + (let* ((wff (row-wff row)) + (answer (row-answer row)) + (hint (row-hint-p row)) + (potential-rewrite (and (not hint) (row-bare-unit-p row) (not (row-embedding-p row))))) + (setf wff (map-atoms-in-wff-and-compose-result + (lambda (atom polarity) + (unless hint + (setf atom (index-terms-in-atom-of-derived-wff atom polarity row))) + (prog-> + (setf atom (hash-term atom)) + (tm-store atom) + (unless (eq :neg polarity) + (insert-into-rows-containing-atom-positively row atom)) + (unless (eq :pos polarity) + (insert-into-rows-containing-atom-negatively row atom)) + (insert-into-rows-containing-term row atom) + (when potential-rewrite + (cond + ((and (use-simplification-by-equalities?) (eq :pos polarity) (equality-p atom)) + (let ((args (args atom))) + (ecase (simplification-ordering-compare-equality-arguments atom nil t row) + (< + (store-rewrite atom '< row)) + (> + (store-rewrite atom '> row)) + (= + (unless (and (not (variable-p (first args))) + (equal-p (first args) (second args))) + (maybe-store-atom-rewrite atom true row))) + (? + (case (instantiating-direction (first args) (second args) nil) + (> + (store-rewrite atom '>? row)) + (< + (store-rewrite atom ' + (if (variant-p (first args) (instantiate (second args) 1)) + (store-rewrite atom '>? row) + (store-rewrite atom '<>? row)))) + (maybe-store-atom-rewrite atom true row))))) + (t + (maybe-store-atom-rewrite atom (if (eq :pos polarity) true false) row)))) + atom)) + wff)) + (unless (or (eq false answer) (variable-p answer)) + (setf answer (canonicalize-wff answer))) + (setf (row-wff row) wff) + (setf (row-answer row) answer) + (unless (row-bare-unit-p row) + (feature-vector-index-insert row *feature-vector-row-index*)) + (dolist (parent (row-parents row)) + (rowset-insert row (or (row-children parent) + (setf (row-children parent) (make-rowset))))))) + +(defun recursively-unstore-wff (row msg stop-predicate) + (unless (funcall stop-predicate row) + (prog-> + (map-rows :rowset (row-children row) :reverse t ->* child) + (recursively-unstore-wff child "Deleted descendant" stop-predicate)) + (unstore-wff row msg))) + +(defun unstore-wff (row msg) + (unless (row-deleted-p row) + (delete-row-from-agenda row) + (when (row-number row) + (feature-vector-index-delete row *feature-vector-row-index*) + (rowsets-delete row)) + (let ((rewrites (row-rewrites row))) + (when rewrites + (dolist (rewrite rewrites) + (setf (rewrite-condition rewrite) nil) + (let ((e (the-term-memory-entry (rewrite-pattern rewrite)))) + (setf (tme-rewrites e) (delete rewrite (tme-rewrites e) :count 1)))) + (setf (row-rewrites row) nil))) + (prog-> + (map-terms-in-term (row-wff row) ->* term polarity) + (declare (ignore polarity)) + (unless (variable-p term) + (some-term-memory-entry term -> e) + (when e + (let ((l (tme-rows-containing-paramodulatable-equality e))) + (when l + (setf (tme-rows-containing-paramodulatable-equality e) (delete row l :key #'car)))) + (when (use-term-memory-deletion?) + (when (tme-useless-p e) + (tm-remove-entry e)))))) ;reinstated deletion 1997-08-16 + (setf (row-status row) :deleted) + (setf (row-wff-symbol-counts0 row) nil) ;not needed for deleted row, reclaim memory + (setf (row-selections-alist row) nil) ;not needed for deleted row, reclaim memory + (when (row-number row) + (incf *number-of-backward-eliminated-rows*) + (when (print-rows-when-derived?) + (print-deleted-wff row msg)) + (prog-> + (map-rows :rowset (row-children row) :reverse t ->* child) + (when (row-embedding-p child) + (unstore-wff child "Deleted embedding"))) + (rowsets-delete-column (row-children row)) + (setf (row-children row) nil)))) + +(defun delete-row (name-or-number) + (prog-> + (quote 0 -> *number-of-backward-eliminated-rows*) + (quote nil -> *printing-deleted-messages*) + (row name-or-number 'warn ->nonnil row) + (unstore-wff row "Deleted"))) + +(defun delete-rows (&rest map-rows-options) + (prog-> + (quote 0 -> *number-of-backward-eliminated-rows*) + (quote nil -> *printing-deleted-messages*) + (apply 'map-rows map-rows-options ->* row) + (unstore-wff row "Deleted"))) + +#+ignore +(defun constraint-purify-row (row) + (prog-> + (cl:assert (row-clause-p row)) + (row-wff row -> wff) + (constraint-purify-wff wff -> wff* constraint-alist-additions) + (unless (and (null constraint-alist-additions) (equal-p wff wff*)) + (disjoin-alists (row-constraints row) constraint-alist-additions -> constraints*) + (fail-when-constraint-true constraints*) + (setf row (maybe-new-row row)) + (setf (row-wff row) wff*) + (setf (row-constraints row) constraints*) + (setf (row-reason row) `(purify ,(row-reason row))))) + row) + +(defun make-split (row wff answer polarity) + (let* ((constraint-alist (row-constraints row)) + (suppress-answer (let ((vars (variables answer))) + (and vars + (dolist (var vars t) + (when (or (variable-occurs-p var wff nil) + (variable-occurs-p var constraint-alist nil)) + (return nil))))))) + (make-row :wff (if (eq :pos polarity) wff (make-compound *not* wff)) + :constraints constraint-alist + :answer (if suppress-answer false answer) + :supported (row-supported row) + :sequential (row-sequential row) + :context (row-context row) + :reason (row-reason row) + :conc-name (or (row-conc-name row) + (let ((name (row-name row))) + (and name (to-string name "-")))) + :documentation (row-documentation row) + :author (row-author row) + :source (row-source row) + :input-wff (row-input-wff row)))) + +(defun factorer (row) + (when (row-hint-p row) + (return-from factorer nil)) + (prog-> + (row-context-live? row ->nonnil context) + (dopairs (atoms-in-wff2 (row-wff row) nil :pos 1) ->* x y) + (when (and (or (eq (second x) (second y)) (eq :both (second x)) (eq :both (second y))) + (not (do-not-factor (first x))) + (not (do-not-factor (first y))) + (implies (row-sequential row) + (or (atom-satisfies-sequential-restriction-p (first x) (row-wff row)) + (atom-satisfies-sequential-restriction-p (first y) (row-wff row))))) + (unify (first x) (first y) ->* subst) + (catch 'fail + (record-new-derived-row + (make-row :wff (fail-when-true (instantiate (row-wff row) 1 subst)) + :constraints (fail-when-constraint-true (instantiate (row-constraints row) 1 subst)) + :answer (fail-when-disallowed (instantiate (row-answer row) 1 subst)) + :supported (row-supported row) + :sequential (row-sequential row) + :context context + :reason `(factor ,row))))))) + +(defun resolve-with-x=x (row) + (when (row-hint-p row) + (return-from resolve-with-x=x nil)) + (prog-> + (row-context-live? row ->nonnil context) + (when (row-supported row) + (map-atoms-in-wff (row-wff row) ->* atom polarity) + (when (and (eq :neg polarity) (equality-p atom)) + (args atom -> args) + (when (or (variable-p (first args)) (variable-p (second args))) + (instantiate atom 1 -> atom*) + (args atom* -> args*) + (unify (first args*) (second args*) ->* subst) + (when (make-resolventa row atom atom* true subst context) + (return-from resolve-with-x=x t)))))) + nil) + +(defun resolve-with-x-eq-x (row) + (when (row-hint-p row) + (return-from resolve-with-x-eq-x nil)) + (prog-> + (row-context-live? row ->nonnil context) + (row-wff row -> wff) + (when (clause-p wff) + (map-atoms-in-wff wff ->* atom polarity) + (when (compound-p atom) + (head atom -> rel) + (when (and (do-not-resolve atom) + (member (function-constraint-theory rel) '(arithmetic equality))) + (identity nil -> resolved) + (prog-> + (instantiate atom 1 -> atom*) + (dolist (function-resolve-code rel polarity) ->* fun) + (funcall fun atom* nil ->* subst &optional residue) + (unless residue + (when (make-resolventa row atom atom* (if (eq :neg polarity) true false) subst context) + (setf resolved t)))) + #+ignore + (when resolved + (return-from resolve-with-x-eq-x t)))))) + nil) + +(defun resolve-with-x-eq-x2 (row) + (when (row-hint-p row) + (return-from resolve-with-x-eq-x2 nil)) + (prog-> + (row-context-live? row ->nonnil context) + (row-constraints row -> constraint-alist) + (dolist constraint-alist ->* v) + (when (member (car v) '(arithmetic equality)) + (cdr v -> wff) + (when (clause-p wff) + (map-atoms-in-wff wff ->* atom polarity) + (when (compound-p atom) + (head atom -> rel) + (identity nil -> resolved) + (prog-> + (instantiate atom 1 -> atom*) + (dolist (function-resolve-code rel polarity) ->* fun) + (funcall fun atom* nil ->* subst &optional residue) + (unless residue + (when (make-resolventc row subst context (substitute (if (eq :neg polarity) true false) atom constraint-alist)) + (setf resolved t)))) + #+ignore + (when resolved + (return-from resolve-with-x-eq-x2 t)))))) + nil) + +(defun function-resolve-code2 (fn v) + (and (not (function-do-not-resolve fn)) (function-resolve-code fn v))) + +(defun resolver (row1) + (when (row-hint-p row1) + (return-from resolver nil)) + (prog-> + (row-context-live? row1 ->nonnil context1) + (use-literal-ordering-with-resolution? -> orderfun) + (selected-atoms-in-row row1 orderfun -> selected-atoms-in-row1) + (flet ((resolver1 (atom1 truthvalue1 truthvalue2 polarity1 polarity2) + (prog-> + (quote nil -> atom1*) + ;; apply resolve-code procedural attachments: + (when (row-supported row1) + (dolist (and (compound-p atom1) (function-resolve-code2 (head atom1) truthvalue1)) ->* fun) + (funcall fun (setq-once atom1* (instantiate atom1 1)) nil ->* subst &optional residue) + (when (selected-atom-p atom1 polarity1 selected-atoms-in-row1 orderfun subst 1 atom1*) + (make-resolventa row1 atom1 atom1* truthvalue1 subst context1 residue))) + ;; resolve row1 with other rows: + (retrieve-resolvable-entries + atom1 + nil + (if (eq false truthvalue2) + #'tme-rows-containing-atom-positively + #'tme-rows-containing-atom-negatively) + ->* atom2-entry row2s) + (tme-term atom2-entry -> atom2) + (quote nil -> atom2*) + (map-rows :rowset row2s :reverse t ->* row2) + (row-context-live? row2 ->nonnil context2) + (selected-atoms-in-row row2 orderfun -> selected-atoms-in-row2) + (when (and (row-given-p row2) + (not (row-hint-p row2)) + (or (and (row-unit-p row1) (row-unit-p row2)) + (meets-binary-restrictions-p row1 row2)) + (selected-atom-p atom2 polarity2 selected-atoms-in-row2 orderfun)) + (setq-once atom1* (instantiate atom1 1)) + (setq-once atom2* (instantiate atom2 2)) + (unify atom1* atom2* nil ->* subst) + (when (and (selected-atom-p atom1 polarity1 selected-atoms-in-row1 orderfun subst 1 atom1*) + (selected-atom-p atom2 polarity2 selected-atoms-in-row2 orderfun subst 2 atom2*)) + (make-resolvent row1 atom1 atom1* truthvalue1 + row2 atom2 atom2* truthvalue2 + subst context1 context2)))))) + (prog-> + (dolist selected-atoms-in-row1 ->* x) + (values-list x -> atom1 polarity1) + (unless (eq :neg polarity1) + (resolver1 atom1 false true :pos :neg)) + (unless (eq :pos polarity1) + (resolver1 atom1 true false :neg :pos)))))) + +(defun code-resolver (row1) + (when (row-hint-p row1) + (return-from code-resolver nil)) + (prog-> + (when (row-supported row1) + (row-context-live? row1 ->nonnil context1) + (instantiate (row-wff row1) 1 -> wff1) + (dolist (use-resolve-code?) ->* fun) + (funcall fun wff1 nil ->* subst &optional wff1*) + (make-resolventb row1 (or wff1* false) subst context1)))) + +(definline hyperresolution-electron-polarity () + ;; every atom in an electron has this polarity + (if *negative-hyperresolution* :neg :pos)) + +(definline hyperresolution-nucleus-polarity () + ;; some atom in a nucleus has this polarity + (if *negative-hyperresolution* :pos :neg)) + +(definline row-hyperresolution-electron-p (row) + (if *negative-hyperresolution* (row-negative-p row) (row-positive-p row))) + +(definline hyperresolution-orderfun () + (if *negative-hyperresolution* + (use-literal-ordering-with-negative-hyperresolution?) + (use-literal-ordering-with-hyperresolution?))) + +(defun hyperresolver (row) + (when (row-hint-p row) + (return-from hyperresolver nil)) + (prog-> + (cond + ((row-hyperresolution-electron-p row) + (hyperresolution-orderfun -> orderfun) + (dolist (selected-atoms-in-row row orderfun) ->* x) ;row is electron + (values-list x -> atom2 polarity2) + (if (eq :pos polarity2) false true -> truthvalue2) + (prog-> ;use procedural attachment as unit nucleus + (row-context-live? row ->nonnil context) + (when (row-supported row) + (quote nil -> atom2*) + (dolist (and (compound-p atom2) (function-resolve-code2 (head atom2) polarity2)) ->* fun) + (funcall fun (setq-once atom2* (instantiate atom2 1)) nil ->* subst &optional residue) + (selected-atoms-in-row row orderfun -> selected-atoms-in-row) + (when (selected-atom-p atom2 polarity2 selected-atoms-in-row orderfun subst 1 atom2*) + (make-resolventa row atom2 atom2* truthvalue2 subst context residue)))) + (prog-> + (quote nil -> atom2*) + (retrieve-resolvable-entries + atom2 + nil + (if *negative-hyperresolution* + #'tme-rows-containing-atom-positively + #'tme-rows-containing-atom-negatively) + ->* atom1-entry row1s) + (tme-term atom1-entry -> atom1) + (quote nil -> atom1*) + (map-rows :rowset row1s :reverse t ->* row1) + (when (and (row-given-p row1) + (not (row-hint-p row1))) + (setq-once atom1* (instantiate atom1 1)) + (setq-once atom2* (instantiate atom2 2)) + (unify atom1* atom2* nil ->* subst) + (hyperresolver1 row1 atom1 row atom2 atom2* subst)))) + (t ;row is nucleus + (let ((atoms nil) (atoms* nil)) + (prog-> + (map-atoms-in-wff (row-wff row) ->* atom polarity) + (when (and (eq (hyperresolution-nucleus-polarity) polarity) + (not (do-not-resolve atom)) + (not (member atom atoms))) ;equal-p => eq for canonical terms + (push atom atoms) + (push (instantiate atom 1) atoms*))) + (when atoms* + (hyperresolver2 row nil (nreverse atoms*) 2 nil nil))))))) + +(defun hyperresolver1 (nucleus atom1 electron atom2 atom2* subst) + (let ((atoms nil) (atoms* nil)) + (prog-> + (map-atoms-in-wff (row-wff nucleus) ->* atom polarity) + (when (and (neq atom atom1) ;equal-p => eq for canonical terms + (eq (hyperresolution-nucleus-polarity) polarity) + (not (do-not-resolve atom)) + (not (member atom atoms))) ;equal-p => eq for canonical terms + (push atom atoms) + (push (instantiate atom 1) atoms*))) ;no dereferencing needed + (hyperresolver2 nucleus (list (list electron atom2 atom2*)) (nreverse atoms*) 3 nil subst))) + +(defun hyperresolver2 (nucleus electrons atoms* n residues subst) + (declare (type fixnum n)) + (prog-> + (hyperresolution-orderfun -> orderfun) + (cond + ((null atoms*) + (when (and (or (row-supported nucleus) + (some (lambda (x) (row-supported (first x))) electrons)) + (selected-atoms-in-hyperresolution-electrons-p electrons subst)) + (make-hyperresolvent nucleus electrons residues subst))) + (t + (first atoms* -> atom*) + (when (test-option9?) + (let ((atom** (rewriter atom* subst))) + ;; should record what rewrites are used + (when (neq none atom*) + (cond + ((eq true atom**) + (return-from hyperresolver2 + (unless *negative-hyperresolution* + (hyperresolver2 nucleus electrons (rest atoms*) n residues subst)))) + ((eq false atom**) + (return-from hyperresolver2 + (when *negative-hyperresolution* + (hyperresolver2 nucleus electrons (rest atoms*) n residues subst)))) + (t + (setf atom* atom**)))))) + (prog-> + (dolist (and (compound-p atom*) + (function-resolve-code2 (head atom*) (if *negative-hyperresolution* false true))) + ->* fun) + (funcall fun atom* subst ->* subst &optional residue) + (cons (function-code-name (head atom*)) *resolve-functions-used* -> *resolve-functions-used*) + (hyperresolver2 nucleus electrons (rest atoms*) n (cons-unless-nil residue residues) subst)) + (retrieve-resolvable-entries + atom* + subst + (if *negative-hyperresolution* #'tme-rows-containing-atom-negatively #'tme-rows-containing-atom-positively) + ->* atomn-entry rowns) + (tme-term atomn-entry -> atomn) + (quote nil -> atomn*) + (map-rows :rowset rowns :reverse t ->* rown) + (selected-atoms-in-row rown orderfun -> selected-atoms-in-rown) + (when (and (row-given-p rown) + (not (row-hint-p rown)) + (row-hyperresolution-electron-p rown)) + (when (selected-atom-p + atomn + (hyperresolution-electron-polarity) + selected-atoms-in-rown + orderfun) + (unify (first atoms*) (setq-once atomn* (instantiate atomn n)) subst ->* subst) + (hyperresolver2 nucleus (cons (list rown atomn atomn*) electrons) (rest atoms*) (+ n 1) residues subst))))))) + +(defun ur-resolver (row) + (when (row-clause-p row) ;nucleus + (ur-resolver1 row)) + (when (row-unit-p row) ;electron + (prog-> + (map-atoms-in-wff (row-wff row) ->* atom2 polarity2) + (setf atom2 (instantiate atom2 2)) + (retrieve-resolvable-entries + atom2 + nil + (if (eq :pos polarity2) #'tme-rows-containing-atom-negatively #'tme-rows-containing-atom-positively) + ->* atom1-entry row1s) + (tme-term atom1-entry -> atom1) + (quote nil -> atom1*) + (map-rows :rowset row1s :reverse t ->* row1) ;nucleus + (when (and (row-given-p row1) + (row-clause-p row1) + (not (row-hint-p row1)) + (not (row-unit-p row1))) + (setq-once atom1* (instantiate atom1 1)) + (unify atom1* atom2 ->* subst) + (ur-resolve1 row1 (list row) nil nil subst (atoms-in-clause2 (row-wff row1) atom1) 3)))) + nil) + +(defun ur-resolver1 (nucleus) + (when (row-hint-p nucleus) + (return-from ur-resolver1 nil)) + (ur-resolve1 nucleus nil nil nil nil (atoms-in-clause2 (row-wff nucleus)) 2)) + +(defun ur-resolve1 (nucleus electrons target-atom target-polarity subst l k) + (declare (type fixnum k)) + (cond + ((null l) + (when (and (or electrons *resolve-functions-used*) + (or (row-supported nucleus) + (some #'row-supported electrons)) + (implies (and target-atom + (use-literal-ordering-with-ur-resolution?) + (clause-p (row-wff nucleus))) + (literal-is-not-dominating-in-clause-p + (use-literal-ordering-with-ur-resolution?) + target-atom + target-polarity + (instantiate (row-wff nucleus) 1) + subst))) + (make-ur-resolvent nucleus electrons target-atom target-polarity subst))) + (t + (let ((atom1 (instantiate (first (first l)) 1)) + (polarity1 (second (first l)))) + (when (null target-atom) + (ur-resolve1 nucleus electrons atom1 polarity1 subst (rest l) k)) + (when (eq target-polarity polarity1) + (prog-> + (unify target-atom atom1 subst ->* subst) + (ur-resolve1 nucleus electrons target-atom target-polarity subst (rest l) k))) + (prog-> + (dolist (and (compound-p atom1) (function-resolve-code2 (heada atom1) polarity1)) ->* fun) + (funcall fun atom1 subst ->* subst &optional residue) + (unless residue + (cons (function-code-name (head atom1)) *resolve-functions-used* -> *resolve-functions-used*) + (ur-resolve1 nucleus electrons target-atom target-polarity subst (rest l) k))) + (prog-> + (retrieve-resolvable-entries + atom1 + subst + (if (eq :pos polarity1) #'tme-rows-containing-atom-negatively #'tme-rows-containing-atom-positively) + ->* atomk-entry rowks) + (tme-term atomk-entry -> atomk) + (quote nil -> atomk*) + (map-rows :rowset rowks :reverse t ->* rowk) + (when (and (row-given-p rowk) + (not (row-hint-p rowk)) + (row-unit-p rowk)) + (setq-once atomk* (instantiate atomk k)) + (unify atom1 atomk* subst ->* subst) + (ur-resolve1 nucleus (cons rowk electrons) target-atom target-polarity subst (rest l) (+ k 1)))))))) + +(defun backward-demodulate-by (row1) + (when (row-hint-p row1) + (return-from backward-demodulate-by nil)) + (loop for rewrite in (row-rewrites row1) + as pattern = (rewrite-pattern rewrite) + as value = (rewrite-value rewrite) + as pattern-symbol-count = (rewrite-pattern-symbol-count rewrite) + as cond = (rewrite-condition rewrite) + as embeddings = (rewrite-embeddings rewrite) + when (if (or (eq true value) (eq false value)) + (and (use-simplification-by-units?) + (neq :forward (use-simplification-by-units?))) + (and (use-simplification-by-equalities?) + (neq :forward (use-simplification-by-equalities?)))) + do (prog-> + (row-context-live? row1 ->nonnil context1) + (instantiate pattern 1 -> pattern*) + (instantiate value 1 -> value*) + (retrieve-instance-entries pattern* nil ->* e-entry) + (tme-term e-entry -> e) + (let ((row2s (tme-rows-containing-term e-entry)) e*) ;paramodulatable term? + (unless (rowset-empty? row2s) + (when (block it + (prog-> + (rewrite-patterns-and-values + pattern* value* pattern-symbol-count embeddings (symbol-count e) ->* pattern** value**) + (subsume pattern** e nil ->* subst) + (when (and (or (eq cond t) (funcall cond pattern* value* subst)) + (term-subsort-p value** pattern** subst)) + (setf e* (instantiate value** subst)) + (return-from it t))) + nil) + (prog-> + (map-rows :rowset row2s :reverse t ->* row2) + (row-context-live? row2 ->nonnil context2) + (unless (or (eq row1 row2) + (row-embedding-p row2) + (row-deleted-p row2) + (not (eq t (context-subsumes? context1 context2)))) + (cond + ((row-hint-p row2) + (when (or (eq true value) (eq false value)) + (pushnew row2 *hints-subsumed*)) + nil) + ((or (eq true value) (eq false value)) + (let ((result (make-resolvent1 row1 pattern (if (eq true value) false true) + row2 e value nil context1 context2))) + (when result + (unless (eq :tautology result) + (setf (row-reason result) `(rewrite ,row2 ,row1))) + result))) + (t + (make-demodulant row1 row2 (substitute e* e (row-wff row2)) context1 context2)) + ->nonnil demodulant) + (if recursive-unstore + (recursively-unstore-wff row2 "Simplified" (lambda (x) (eq row1 x))) + (unstore-wff row2 "Simplified")) + (unless (eq :tautology demodulant) + (record-backward-simplifiable-wff demodulant))))))))) + (setf *printing-deleted-messages* nil) + (prog-> + (identity *hint-rows* -> hints) + (unless (rowset-empty? hints) + (row-wff row1 -> wff1) + (when (equality-p wff1) + (row-context-live? row1 ->nonnil context1) + (identity nil -> wff1*) + (map-rows :rowset hints ->* row2) + (row-context-live? row2 ->nonnil context2) + (unless (or (row-deleted-p row2) + (not (eq t (context-subsumes? context1 context2)))) + (setq-once wff1* (renumber-new wff1)) + (when (subsumes-p wff1* (row-wff row2)) + (pushnew row2 *hints-subsumed*)))))) + nil) + +(defun paramodulater-from (row1) + (when (row-hint-p row1) + (return-from paramodulater-from nil)) + (prog-> + (use-literal-ordering-with-paramodulation? -> orderfun) + (row-wff row1 -> wff1) + (when (and (implies (and orderfun + (not (test-option3?)) + (not (row-sequential row1)) ;don't restrict to equality wff if sequential snark-20061213b + (clause-p wff1)) + (positive-equality-wff-p wff1)) + (implies (use-paramodulation-only-from-units?) (equality-p wff1))) + (map-atoms-in-wff wff1 ->* atom1 polarity1) + (when (and (neq polarity1 :neg) + (equality-p atom1) + (if (row-sequential row1) + (atom-satisfies-sequential-restriction-p atom1 wff1) + (implies orderfun (literal-satisfies-ordering-restriction-p + orderfun atom1 :pos wff1)))) + (args atom1 -> args) + (first args -> a) + (second args -> b) + (unless (eq a b) ;equal-p => eq for canonical terms + (simplification-ordering-compare-equality-arguments atom1 nil -> dir) + (setf a (instantiate a 1)) + (setf b (instantiate b 1)) + (unless (or (variable-p a) (eq '< dir)) + (paramodulater-from1 row1 atom1 a b dir)) + (unless (or (variable-p b) (eq '> dir)) + (paramodulater-from1 row1 atom1 b a dir))))))) + +(defun paramodulater-from1 (row1 equality1 pattern1* value1* dir) + ;; row1 has the equality + (declare (ignore dir)) + (prog-> + (row-context-live? row1 ->nonnil context1) + (and (row-embedding-p row1) (embedding-variables row1 1) -> embedding-variables1) + (retrieve-paramodulatable-entries pattern1* nil ->* term2-entry) + (tme-term term2-entry -> term2) + (unless (variable-p term2) + (rows-containing-paramodulatable-term term2 -> row2s) + (when row2s + (setf row2s (impose-binary-restrictions row1 row2s)) + (when row2s + (instantiate term2 2 -> term2*) + (and embedding-variables1 ;unify-bag only cares if both terms are embeddings + (loop for row2 in row2s + always (and (row-embedding-p row2) + (or (equal-p term2 (first (args (row-wff row2))) nil) + (equal-p term2 (second (args (row-wff row2))) nil)))) + (embedding-variables (car row2s) 2) + -> embedding-variables2) + (and embedding-variables2 (append embedding-variables1 embedding-variables2) -> *embedding-variables*) + (when (allowable-embedding-superposition (row-embedding-p row1) (row-embedding-p (car row2s))) + (unify pattern1* term2* nil ->* subst) + (unless (or (equal-p pattern1* value1* subst) +;; (and (neq dir '>) +;; (neq dir '<) +;; (eq '< (simplification-ordering-compare-terms pattern1* value1* subst '<))) + ) + (dolist row2s ->* row2) + (row-context-live? row2 ->nonnil context2) + (make-paramodulant row1 equality1 value1* row2 term2* subst context1 context2)))))))) + +(defun paramodulater-to (row2) + (when (row-hint-p row2) + (return-from paramodulater-to nil)) + (prog-> + (quote nil -> done) + (use-literal-ordering-with-paramodulation? -> orderfun) + (row-wff row2 -> wff2) + (implies (and orderfun + (not (test-option3?)) + (clause-p wff2)) + (positive-equality-wff-p wff2) + -> paramodulate-to-equalities) + (dolist (selected-atoms-in-row row2 orderfun) ->* x) + (values-list x -> atom2 polarity2) + (cond + ((and (eq :pos polarity2) (equality-p atom2)) + (when paramodulate-to-equalities + (args atom2 -> args) + (first args -> a) + (second args -> b) + (simplification-ordering-compare-equality-arguments atom2 nil -> dir) + (unless (eq '< dir) + (map-terms-in-term a nil polarity2 ->* term2 polarity) + (declare (ignore polarity)) + (unless (or (variable-p term2) (member term2 done) (and (row-embedding-p row2) (neq term2 a))) + (paramodulater-to1 row2 term2 (instantiate term2 2) dir (eq term2 a)) + (push term2 done))) + (unless (eq '> dir) + (map-terms-in-term b nil polarity2 ->* term2 polarity) + (declare (ignore polarity)) + (unless (or (variable-p term2) (member term2 done) (and (row-embedding-p row2) (neq term2 b))) + (paramodulater-to1 row2 term2 (instantiate term2 2) dir (eq term2 b)) + (push term2 done))))) + ((not (row-embedding-p row2)) + (map-terms-in-atom atom2 nil :pos ->* term2 polarity) + (declare (ignore polarity)) + (unless (or (variable-p term2) (member term2 done)) + (paramodulater-to1 row2 term2 (instantiate term2 2) nil) + (push term2 done)))))) + +(defun paramodulater-to1 (row2 term2 term2* dir &optional code-only) + (declare (ignore dir)) + (prog-> + (row-context-live? row2 ->nonnil context2) + (when (row-supported row2) + (dolist (and (compound-p term2*) (function-paramodulate-code (head term2*))) ->* fun) + (funcall fun term2* nil ->* value1* subst) + (make-paramodulanta value1* row2 term2* subst context2)) + (when code-only + (return-from paramodulater-to1)) + (and (row-embedding-p row2) + (or (equal-p term2 (first (args (row-wff row2))) nil) + (equal-p term2 (second (args (row-wff row2))) nil)) + (embedding-variables row2 2) -> embedding-variables2) + (retrieve-paramodulatable-entries term2* nil #'tme-rows-containing-paramodulatable-equality ->* pattern1-entry ws) + (tme-term pattern1-entry -> pattern1) + (instantiate pattern1 1 -> pattern1*) + (dolist ws ->* w) + (car w -> row1) + (row-context-live? row1 ->nonnil context1) + (when (and (not (row-hint-p row1)) (meets-binary-restrictions-p row2 row1)) + (cdr w -> value1) + (unless (eq pattern1 value1) ;equal-p => eq for canonical terms + (make-compound *=* pattern1 value1 -> equality1) + (when (if (row-sequential row1) + (atom-satisfies-sequential-restriction-p equality1 (row-wff row1)) + (let ((orderfun (use-literal-ordering-with-paramodulation?))) + (implies orderfun (literal-satisfies-ordering-restriction-p + orderfun equality1 :pos (row-wff row1))))) + (instantiate value1 1 -> value1*) + (and embedding-variables2 ;unify-bag only cares if both terms are embeddings + (row-embedding-p row1) + (embedding-variables row1 1) + -> embedding-variables1) + (and embedding-variables1 (append embedding-variables1 embedding-variables2) -> *embedding-variables*) + (when (allowable-embedding-superposition (row-embedding-p row1) (row-embedding-p row2)) + (unify pattern1* term2* nil ->* subst) + (unless (or (equal-p pattern1* value1* subst) +;; (and (neq dir '>) +;; (neq dir '<) +;; (eq '< (simplification-ordering-compare-terms pattern1* value1* subst '<))) + ) + (unless (eql (row-number row1) (row-number row2)) + ;;don't duplicate work (DO THIS IN IMPOSE-BINARY-RESTRICTIONS INSTEAD) + (make-paramodulant row1 equality1 value1* row2 term2* subst context1 context2))))))))) + +(defun paramodulation-allowable-p (term row) + (prog-> + (row-wff row -> wff) + (map-atoms-in-wff wff ->* atom polarity) + (identity nil -> atom-not-selected) + (cond + ((and (eq :pos polarity) (equality-p atom)) + (args atom -> args) + (simplification-ordering-compare-equality-arguments atom nil -> dir) + (unless (eq '< dir) + (when (if (row-embedding-p row) (equal-p term (first args) nil) (occurs-p term (first args) nil)) + (if (if (row-sequential row) + (atom-satisfies-sequential-restriction-p atom wff) + (let ((orderfun (use-literal-ordering-with-paramodulation?))) + (implies orderfun (literal-satisfies-ordering-restriction-p orderfun atom polarity wff)))) + (return-from paramodulation-allowable-p t) + (setf atom-not-selected t)))) + (unless atom-not-selected + (unless (eq '> dir) + (when (if (row-embedding-p row) (equal-p term (second args) nil) (occurs-p term (second args) nil)) + (when (if (row-sequential row) + (atom-satisfies-sequential-restriction-p atom wff) + (let ((orderfun (use-literal-ordering-with-paramodulation?))) + (implies orderfun (literal-satisfies-ordering-restriction-p orderfun atom polarity wff)))) + (return-from paramodulation-allowable-p t)))))) + ((occurs-p term atom nil) + (when (if (row-sequential row) + (atom-satisfies-sequential-restriction-p atom wff) + (let ((orderfun (use-literal-ordering-with-paramodulation?))) + (implies orderfun (literal-satisfies-ordering-restriction-p orderfun atom polarity wff)))) + (return-from paramodulation-allowable-p t))))) + nil) + +(defun rows-containing-paramodulatable-term (term) + (rows :rowset (rows-containing-term term) + :reverse t + :test (lambda (row) + (and (row-given-p row) + (implies (use-paramodulation-only-into-units?) (row-unit-p row)) + (paramodulation-allowable-p term row))))) + +(defun make-embeddings (cc row) + (unless (row-embedding-p row) + (let ((wff (row-wff row))) + (when (equality-p wff) + (flet ((embed? (x) + (and (compound-appl-p x) + (function-associative (heada x)) + (dolist (fun (function-unify-code (heada x)) nil) + (when (or (eq 'ac-unify fun) (eq 'associative-unify fun)) + (return t))) + (not (function-do-not-paramodulate (heada x)))))) + (mvlet* (((list a b) (args wff)) + (embed-a (embed? a)) + (embed-b (embed? b))) + (when (or embed-a embed-b) + (with-clock-on embedding + (let ((dir (simplification-ordering-compare-terms a b))) + (cond + ((eq '> dir) + (when embed-a + (make-embeddings1 cc row a b))) + ((eq '< dir) + (when embed-b + (make-embeddings1 cc row b a))) + ((and embed-a embed-b (eq (heada a) (heada b))) + (make-embeddings1 cc row a b)) + (t + (when embed-a + (make-embeddings1 cc row a b)) + (when embed-b + (make-embeddings1 cc row b a))))))))))))) + +(defun make-embeddings1 (cc row a b) + (let* ((head (head a)) + (args (args a)) + (sort (function-sort head)) + (newvar2 (make-variable sort)) + (temp (append args (list newvar2)))) + (cond + ((function-commutative head) + (let ((a* (make-compound* head temp)) + (b* (make-compound head b newvar2))) ;might not be flattened + (unless (subsumes-p (renumber (cons a b)) (cons a* b*)) + (funcall cc (make-embedding row a* b* t))))) + (t + (let ((newvar1 (make-variable sort)) + (abs (list (renumber (cons a b))))) + (let ((a* (make-compound* head (cons newvar1 args))) + (b* (make-compound head newvar1 b))) ;might not be flattened + (unless (dolist (ab abs) + (when (subsumes-p ab (cons a* b*)) + (return t))) + (push (renumber (cons a* b*)) abs) + (funcall cc (make-embedding row a* b* :l)))) + (let ((a* (make-compound* head temp)) + (b* (make-compound head b newvar2))) ;might not be flattened + (unless (dolist (ab abs) + (when (subsumes-p ab (cons a* b*)) + (return t))) + (push (renumber (cons a* b*)) abs) + (funcall cc (make-embedding row a* b* :r)))) + (let ((a* (make-compound* head (cons newvar1 temp))) + (b* (make-compound head newvar1 b newvar2))) ;might not be flattened + (unless (dolist (ab abs) + (when (subsumes-p ab (cons a* b*)) + (return t))) + (funcall cc (make-embedding row a* b* :l&r))))))))) + +(defun make-embedding (row a1 b1 type) + (make-row :wff (make-equality a1 b1 nil) + :constraints (row-constraints row) + :answer (row-answer row) + :supported (row-supported row) + :sequential (row-sequential row) + :context (row-context row) + :reason (if (eq t type) `(embed ,row) `(embed ,row ,type)))) + +(defun embedding-variables (embedding+ n) + ;; may not return all embedding-variables because the embedding + ;; (= (f a ?x) (f b ?x)) might be stored as (= (f a ?x) (f ?x b)) if f is AC + (mvlet ((vars nil) + ((list arg1 arg2) (args (row-wff embedding+)))) + (when (and (compound-appl-p arg1) + (compound-appl-p arg2) + (eq (heada arg1) (heada arg2))) + (let ((type (row-embedding-p embedding+))) + (when (or (eq :l&r type) (eq :r type) (eq t type)) + (let ((x (first (last (argsa arg1)))) + (y (first (last (argsa arg2))))) + (when (and (eq x y) (variable-p x)) + (push (instantiate x n) vars)))) + (when (or (eq :l&r type) (eq :l type)) + (let ((x (first (argsa arg1))) + (y (first (argsa arg2)))) + (when (and (eq x y) (variable-p x)) + (push (instantiate x n) vars)))))) + vars)) + +(defun allowable-embedding-superposition (type1 type2) + (or (null type1) + (null type2) + (and (eq t type1) (eq t type2)) + (and (eq :l type1) (eq :r type2)) + (and (eq :r type1) (eq :l type2)))) + +(defun do-not-paramodulate (term &optional subst) + (dereference term subst :if-compound-appl (function-do-not-paramodulate (heada term)))) + +(defun meets-binary-restrictions-p (row1 row2) + (and (or (row-supported row1) (row-supported row2)) + (implies (use-unit-restriction?) (or (row-unit-p row1) (row-unit-p row2))) + (implies (use-input-restriction?) (or (row-input-p row1) (row-input-p row2))))) + +(defun impose-binary-restrictions (row1 l &key (key #'identity)) + (remove-if-not (lambda (x) (meets-binary-restrictions-p row1 (funcall key x))) l)) + +(defun process-new-row-msg (control-string &rest args) + (when (print-rows-when-processed?) + (with-clock-on printing + (format t "~%; ") + (apply #'format t control-string args)))) + +(defun maybe-new-row (row) + (cond + ((symbolp (row-reason row)) + (let ((row* (make-row :wff (row-wff row) + :constraints (row-constraints row) + :answer (row-answer row) + :reason row + :context (row-context row) + :supported (row-supported row) + :sequential (row-sequential row)))) + (setf (row-wff row) (flatten-term (row-wff row) nil)) + (renumber-row row) + (if (row-number row) + (set-row-number row* (incf *number-of-rows*)) ;new row is numbered iff original was + (set-row-number row (incf *number-of-rows*))) ;original row is now numbered + (incf *number-of-backward-eliminated-rows*) + row*)) + (t + row))) + +(defun process-new-row (row agenda-value agenda) + (with-clock-on process-new-row + (let ((*processing-row* row) + (wff (row-wff row)) + (*rewriting-row-context* (row-context-live? row))) + (unless *rewriting-row-context* + (return-from process-new-row nil)) + (when (print-rows-when-processed?) + (print-processed-row row)) + (when (eq true wff) + (process-new-row-msg "Row wff is true.") + (return-from process-new-row nil)) + (when (row-pure row) + (process-new-row-msg "Row is pure.") + (return-from process-new-row nil)) + (when (and (eq agenda *agenda-of-rows-to-process*) + (loop for parent in (row-parents row) + thereis (row-deleted-p parent))) + (process-new-row-msg "Row parent is deleted.") + (return-from process-new-row nil)) + #+ignore + (when (and (use-constraint-purification?) (not (constraint-purified-row-p row))) + (process-new-row-msg "Row wff is not purified.") + (return-from process-new-row nil)) + (when (and (use-clausification?) (not (clause-p wff))) + (process-new-row-msg "Row wff will be and-split.") + #+ignore (progn (terpri) (print-term wff)) + (clausify wff (lambda (clause) (insert-row-into-agenda (make-split row clause (row-answer row) :pos) agenda-value *agenda-of-rows-to-process* t))) + (return-from process-new-row nil)) + (dolist (fun (pruning-tests-before-simplification?)) + (when (funcall fun row) + (process-new-row-msg "Row is unacceptable before simplification.") + (return-from process-new-row nil))) + (let ((answer (row-answer row)) + constraint-alist + (and-split-this nil)) + (when (and (or (use-simplification-by-units?) (use-simplification-by-equalities?)) (not (row-hint-p row))) + (let ((*rewrites-used* (row-rewrites-used row))) + (unless (row-embedding-p row) + (let ((wff* (with-clock-on forward-simplification (rewriter wff nil)))) + (unless (eq wff wff*) + (when (eq true wff*) + (process-new-row-msg "Simplified row wff is true.") + (return-from process-new-row nil)) + (when *rewrites-used* + (setf row (maybe-new-row row)) + (setf (row-rewrites-used row) *rewrites-used*)) + (setf (row-wff row) (setf wff wff*)))) + (when (rewrite-answers?) + (let ((answer* (with-clock-on forward-simplification (rewriter answer nil)))) + (unless (eq answer answer*) + (when *rewrites-used* + (setf row (maybe-new-row row)) + (setf (row-rewrites-used row) *rewrites-used*)) + (setf (row-answer row) (setf answer answer*)))))) + ;; inefficient to always rewrite constraints + ;; can't rewrite constraints already in global data structures + (let ((constraints (row-constraints row))) + (when constraints + (let ((constraints* (with-clock-on forward-simplification (rewrite-constraint-alist constraints)))) + (unless (eq constraints constraints*) + (when *rewrites-used* + (setf row (maybe-new-row row)) + (setf (row-rewrites-used row) *rewrites-used*)) + (setf (row-constraints row) constraints*))))))) + (let ((*check-for-disallowed-answer* t)) + (when (answer-disallowed-p answer) + (process-new-row-msg "Row answer contains disallowed symbol.") + (return-from process-new-row nil))) + (setf constraint-alist (row-constraints row)) + (when constraint-alist + (with-clock-off constraint-simplification + (setf (row-constraints row) (setf constraint-alist (simplify-constraint-alist constraint-alist))))) + (dolist (x constraint-alist) + (when (eq false (cdr x)) + (process-new-row-msg "Row constraint is false.") + (return-from process-new-row nil))) + (when (and (use-function-creation?) (equality-p wff)) + (let* ((args (args wff)) + (vars1 (variables (first args))) + (vars2 (variables (second args)))) + ;; (when (and (set-difference vars1 vars2) + ;; (set-difference vars2 vars1)) + ;; (let* ((vars (intersection vars1 vars2)) + ;; (fn (declare-function (newsym) (length vars))) + ;; (val (make-compound* fn vars))) + (when (and vars1 vars2 (null (intersection vars1 vars2))) ;create only constants + (let* ((vars nil) + (fn (declare-constant (newsym))) + (val fn)) + (if vars + (setf (function-created-p fn) t) + (setf (constant-created-p fn) t)) + (when (eq :rpo (use-term-ordering?)) + (rpo-add-created-function-symbol fn)) + (setf (row-wff row) (setf wff (conjoin + (make-equality (first args) val) + (make-equality (second args) val)))) + (setf and-split-this t))))) + (when (or and-split-this (and (use-clausification?) (not (clause-p wff)))) + (process-new-row-msg "Row wff will be and-split.") + #+ignore (progn (terpri) (print-term wff)) + (clausify wff (lambda (clause) (insert-row-into-agenda (make-split row clause answer :pos) agenda-value *agenda-of-rows-to-process* t))) + (return-from process-new-row nil)) + (when (and (use-condensing?) (not (row-hint-p row)) (row-bare-p row) (not (literal-p wff)) (clause-p wff)) + (with-clock-on condensing + (let ((wff* (condenser wff))) + (unless (eq wff wff*) + (setf row (maybe-new-row row)) + (setf (row-wff row) (setf wff wff*)) + (setf (row-reason row) (list 'condense (row-reason row))))))) + (unless (or (not (use-subsumption?)) + (and (use-simplification-by-units?) (row-bare-unit-p row)) + (row-hint-p row) + (row-embedding-p row)) + (let ((subsuming-row (forward-subsumed row))) + (when subsuming-row + (process-new-row-msg "Row is forward subsumed by row ~A." (row-name-or-number subsuming-row)) + (return-from process-new-row nil)))) + (dolist (fun (pruning-tests?)) + (when (funcall fun row) + (process-new-row-msg "Row is unaccepable.") + (return-from process-new-row nil))) + (when (and (use-embedded-rewrites?) (not (row-hint-p row))) + (make-embeddings #'record-new-embedding row)) + (prog-> + (setf (row-wff row) (setf wff (flatten-term (row-wff row) nil))) + (renumber-row row) + (set-row-number row (+ *number-of-rows* 1)) + (when (prog1 (record-new-row-to-give row) (setf *printing-deleted-messages* nil)) + (incf *number-of-rows*) + (when (print-rows-when-derived?) + (print-derived-row row)) + (let ((*hints-subsumed* nil)) + (unless (or (not (use-subsumption?)) + (eq :forward (use-subsumption?)) + (and (use-simplification-by-units?) + (neq :forward (use-simplification-by-units?)) + (row-bare-unit-p row)) + (row-embedding-p row) + (row-hint-p row)) + (backward-subsumption + (lambda (subsumed-row) + (if recursive-unstore + (recursively-unstore-wff subsumed-row "Subsumed" (lambda (x) (eq row x))) + (unstore-wff subsumed-row "Subsumed"))) + (make-row0 :wff wff ;NOT RENUMBERED + :constraints constraint-alist + :answer answer + :context (row-context row) + :reason (row-reason row))) + (setf *printing-deleted-messages* nil)) + (rowset-insert row *rows*) + (when (eq false wff) + (if (row-constrained-p2 row) + (rowset-insert row *constraint-rows*) + (rowset-insert row *false-rows*))) + (when (and (row-hint-p row) (equality-p wff)) + (rowset-insert row *hint-rows*)) + (store-derived-wff row) + (unless (or (row-hint-p row) (row-embedding-p row)) + (with-clock-on backward-simplification + (backward-demodulate-by row))) + (when *hints-subsumed* + (setf (row-hints-subsumed row) *hints-subsumed*) + (record-new-row-to-give-again row))))) + nil)))) + +(defun row-pref (row) + (cond + ((row-hints-subsumed row) + 0) + (t + (funcall (agenda-ordering-function?) row)))) + +(defun agenda-item-row (form) + (ecase (car form) + (giver + (second form)) + (process-new-row + (second form)))) + +(defun agenda-item-val (form) + (ecase (car form) + (giver + (third form)) + (process-new-row + (third form)))) + +(defun same-agenda-item-p (form1 form2) + (let ((row1 (agenda-item-row form1)) + (row2 (agenda-item-row form2))) + (and (iff (row-number row1) (row-number row2)) + (implies (not (use-subsumption-by-false?)) (neq false (row-wff row1))) ;keep other proofs + (equal-p (row-wff row1) (row-wff row2)) + (equal-alist-p (row-constraints row1) (row-constraints row2) nil) + (equal-p (row-answer row1) (row-answer row2)) + ;; something for case + (equal (row-context row1) (row-context row2)) + (iff (row-hint-p row1) (row-hint-p row2)) + ))) + +(defun unstore-agenda-item (form) + (ecase (first form) + (giver + (let ((row (second form))) + (setf (row-agenda-entries row) (delete form (row-agenda-entries row))) ;don't double delete it from agenda + (unstore-wff row "Deleted because agenda full")) + (incf *number-of-agenda-full-deleted-rows*)))) + +(defun insert-row-into-agenda (row val agenda &optional at-front) + (let ((v (if (row-number row) + `(giver ,row ,val ,agenda) + `(process-new-row ,row ,val ,agenda)))) + (push v (row-agenda-entries row)) + (agenda-insert v val agenda at-front))) + +(defun delete-row-from-agenda (row &optional test) + (let ((undeleted-agenda-entries nil) undeleted-agenda-entries-last) + (dolist (x (row-agenda-entries row)) + (ecase (first x) + ((giver process-new-row) + (if (implies test (funcall test x)) + (agenda-delete x (third x) (fourth x)) + (collect x undeleted-agenda-entries))))) + (setf (row-agenda-entries row) undeleted-agenda-entries))) + +(defun pop-form-from-agenda () + (let ((form (pop-agenda *agenda*))) + (dolist (x (rest form)) + (when (row-p x) + (setf (row-agenda-entries x) (delete form (row-agenda-entries x))))) + form)) + +(defun record-new-embedding (row) + (insert-row-into-agenda row 0 *agenda-of-new-embeddings-to-process*)) + +(defun record-new-input-wff (row) + (insert-row-into-agenda row 0 *agenda-of-input-rows-to-process*)) + +(defun record-backward-simplifiable-wff (row) + (cond + ((eq false (row-wff row)) + (insert-row-into-agenda row 0 *agenda-of-false-rows-to-process*)) + (t + (insert-row-into-agenda row 0 *agenda-of-backward-simplifiable-rows-to-process* t)))) + +(defun record-new-derived-row (row) + (cond + ((eq false (row-wff row)) + (insert-row-into-agenda row 0 *agenda-of-false-rows-to-process*)) + (t + (mvlet (((values row-pref at-front) (row-pref row))) + (insert-row-into-agenda row row-pref *agenda-of-rows-to-process* at-front))))) + +(defun record-new-row-to-give (row) + (cond + ((eq false (row-wff row)) + (insert-row-into-agenda row 0 *agenda-of-false-rows-to-process*)) + (t + (mvlet (((values row-pref at-front) (row-pref row))) + (cond + ((row-input-p row) + (insert-row-into-agenda row row-pref *agenda-of-input-rows-to-give* at-front)) + ((let ((p (level-pref-for-giving?))) + (and p (<= (row-level row) p))) + (insert-row-into-agenda row (cons 3 row-pref) *agenda-of-rows-to-give* at-front)) + (t + (insert-row-into-agenda row (cons 4 row-pref) *agenda-of-rows-to-give* at-front))))))) + +(defun record-new-row-to-give-again (row) + ;; when the value of row-pref changes because the row subsumes a hint, + ;; use this to delete the row from the agenda and reinsert it with its higher priority + (when (row-agenda-entries row) + (delete-row-from-agenda row (lambda (x) (eq 'giver (first x)))) + (record-new-row-to-give row))) + +(defun giver (given-row &optional agenda-value agenda) + (declare (ignore agenda-value agenda)) + (unless (row-context-live? given-row) + (return-from giver nil)) + (incf *number-of-given-rows*) + (print-given-row given-row) + (when (use-replacement-resolution-with-x=x?) + (let ((*check-for-disallowed-answer* t)) + (when (resolve-with-x=x given-row) + (return-from giver nil)))) + (when (resolve-with-x-eq-x given-row) + (return-from giver nil)) + (when (resolve-with-x-eq-x2 given-row) + (return-from giver nil)) + (store-given-row given-row) + (when (row-hint-p given-row) + (return-from giver nil)) + (when (eq false (row-wff given-row)) + (cond + ((not (row-constrained-p2 given-row)) + (setf *proof* given-row) + (when (print-final-rows?) + (print-final-row given-row)) + (return-from giver t)) + (t + (give-constraint-row given-row) + (return-from giver nil)))) + (let ((use-factoring? (use-factoring?))) + (when (and use-factoring? + (not (literal-p (row-wff given-row))) + (implies (eq :pos use-factoring?) (row-positive-p given-row)) + (implies (eq :neg use-factoring?) (row-negative-p given-row))) + (with-clock-on factoring + (factorer given-row)))) + (when (use-resolution?) + (with-clock-on resolution + (resolver given-row))) + (when (use-hyperresolution?) + (with-clock-on resolution + (let ((*negative-hyperresolution* nil)) + (hyperresolver given-row)))) + (when (use-negative-hyperresolution?) + (with-clock-on resolution + (let ((*negative-hyperresolution* t)) + (hyperresolver given-row)))) + (when (use-ur-resolution?) + (with-clock-on resolution + (ur-resolver given-row))) +#+ignore + (when (use-ur-pttp?) + (with-clock-on resolution + (ur-pttp given-row))) + (when (use-paramodulation?) + (with-clock-on paramodulation + (paramodulater-from given-row) + (paramodulater-to given-row))) + (when (use-resolve-code?) + (with-clock-on resolution + (code-resolver given-row))) + nil) + +(defun give-constraint-row (given-row) + ;; given-row is of of the form 'constraints -> false' + (when (and (row-from-conjecture-p given-row) ;assumed consistent otherwise + (row-constraint-coverage (rows :rowset *constraint-rows* :reverse t))) + (record-new-derived-row + (make-row :wff false + :answer (let ((n 0)) + (disjoin* + (rows :collect (lambda (x) (instantiate (row-answer x) (incf n))) + :rowset *constraint-rows* + :reverse t))) +;;? :supported (row-supported row) +;;? :sequential (row-sequential row) + :context (row-context given-row) + :reason `(combine ,@(rows :rowset *constraint-rows* :reverse t)))) + (rowset-delete given-row *constraint-rows*))) + +(defun initialize-propositional-abstraction-of-input-wffs () + (let ((clause-set (make-dp-clause-set))) + (dp-insert (list (list (function-name *=*) (function-arity *=*))) clause-set) + (setf *propositional-abstraction-of-input-wffs* clause-set))) + +(defun check-propositional-abstraction-of-input-wffs () + ;; clause-set should be checkpointed so that + ;; assumptions and conjectures can be removed, e.g., by new-row-context + (with-clock-on satisfiability-testing + (let ((clause-set *propositional-abstraction-of-input-wffs*)) + (prog-> + (mapnconc-agenda *agenda-of-input-rows-to-process* ->* x) + (second x -> row) + (row-wff row -> wff) + (quote t -> *propositional-abstraction-term-to-lisp*) + (term-to-lisp wff -> wff*) + (cond + ((eq 'false wff*) + (return-from check-propositional-abstraction-of-input-wffs nil)) + ((neq 'true wff*) + (dp-insert-wff wff* clause-set :print-warnings nil))) + nil) +;; (dp-clauses 'print clause-set) + (dp-satisfiable-p clause-set + :find-all-models 1 + :print-summary nil + :print-warnings nil + :trace nil + :trace-choices nil + :branch-limit 10000000)))) + +(defun closure-init () + (when (use-assertion-analysis?) + (complete-assertion-analysis)) + (when critique-options + (with-clock-on printing + (critique-options))) + (unless rewrites-initialized + (initialize-rewrites) + (setf rewrites-initialized t)) + (unless (use-closure-when-satisfiable?) + (let ((v (check-propositional-abstraction-of-input-wffs))) + (when v + (with-clock-on printing + (warn "Propositional abstraction of input is satisfiable with model ~S." (first v))) + (return-from closure-init :satisfiable)))) + (when (use-purity-test?) + (with-clock-on purity-testing + (purity-test #'(lambda (cc) + (prog-> + (dolist *agenda* ->* agenda) + (mapnconc-agenda agenda ->* form) + (funcall cc (second form)) + nil))))) + nil) + +(defun give-is-next-in-agenda () + (dolist (agenda *agenda* nil) + (when (< 0 (agenda-length agenda)) + (let ((name (agenda-name agenda))) + (return (or (string= name "rows to give") + (string= name "input rows to give"))))))) + +(defun closure (&key + (number-of-given-rows-limit (number-of-given-rows-limit?)) + (number-of-rows-limit (number-of-rows-limit?)) + (run-time-limit (run-time-limit?)) + (only-unnumbered-rows nil) + (listen-for-commands (listen-for-commands?))) + (unwind-protect + (progn + (setf *snark-is-running* t) + (setf *proof* nil) + (let ((v (closure-init))) + (when v + (return-from closure v))) + (when number-of-given-rows-limit + (incf number-of-given-rows-limit *number-of-given-rows*)) + (when number-of-rows-limit + (incf number-of-rows-limit *number-of-rows*)) + (when run-time-limit + (incf run-time-limit (total-run-time))) + #+lcl5.0 + (when listen-for-commands + (clear-input)) + (loop + (when (and number-of-given-rows-limit (<= number-of-given-rows-limit *number-of-given-rows*) (give-is-next-in-agenda)) + (return :number-of-given-rows-limit)) + (when (and number-of-rows-limit (<= number-of-rows-limit *number-of-rows*)) + (return :number-of-rows-limit)) + (when (and run-time-limit (<= run-time-limit (total-run-time))) + (return :run-time-limit)) + (when listen-for-commands + (case (read-char-no-hang *terminal-io* nil nil) + ((nil) + ) + ((#\Q #\q) + (return :user-quit)) + ((#\B #\b) + (with-clock-on halted + (clear-input) + (break "Break in closure at user request."))) + (otherwise + (with-clock-on halted + (clear-input) + (when (yes-or-no-p "Stop now? ") + (return :user-quit)))))) + (when (and only-unnumbered-rows + (let ((v (agenda-first *agenda*))) + (and v (row-number (second v))))) + (return :only-unnumbered-rows)) + (prog-> + (pop-form-from-agenda -> form) + (cond + ((null form) + (return :agenda-empty)) + ((apply (car form) (cdr form)) + (return :proof-found)))))) + (setf *snark-is-running* nil) + (when (print-summary-when-finished?) + (terpri) + (print-summary + :clocks (print-clocks-when-finished?) + :term-memory (print-term-memory-when-finished?) + :agenda (print-agenda-when-finished?))) + (when (print-rows-when-finished?) + (print-rows :ancestry t)) + (nocomment))) + + +(defun proof () + ;; final row of the proof found in the most recent call on closure + ;; nil if no proof was found in the most recent call on closure + *proof*) + +(defun proofs () + ;; final rows of all proofs + (rows :rowset *false-rows*)) + +(defun answer (&optional term-to-lisp) + (and *proof* (if term-to-lisp (term-to-lisp (row-answer *proof*)) (row-answer *proof*)))) + +(defun answers (&optional term-to-lisp) + (rows :rowset *false-rows* :collect (lambda (*proof*) (answer term-to-lisp)))) + +(defun make-snark-system (&optional compile) + (cl-user::make-snark-system compile)) + +#+cmu +(defun save-snark-system (&key (name "snark-cmucl.core")) + (format t "~2%SNARK can be started by '~A -core ~A'" cl-user::*command-line-utility-name* name) + (format t "~2%") + (force-output) + (extensions:save-lisp name)) + +#+sbcl +(defun save-snark-system (&key executable (name (if executable + (if (member :x86-64 *features*) "snark-sbcl64" "snark-sbcl") + (if (member :x86-64 *features*) "snark-sbcl64.core" "snark-sbcl.core")))) + (cond + (executable + (format t "~2%SNARK can be started by '~A'" name) + (format t "~%followed by (in-package :snark-user)") + (format t "~2%") + (force-output) + (sb-ext:save-lisp-and-die name :executable t)) + (t + (format t "~2%SNARK can be started by '~A --core ~A'" (first cl-user::*posix-argv*) name) + (format t "~%followed by (in-package :snark-user)") + (format t "~2%") + (force-output) + (sb-ext:save-lisp-and-die name)))) + +#+(and ccl (not mcl)) +(defun save-snark-system (&key (name (if (member :x86-64 *features*) "snark-ccl64" "snark-ccl"))) + (format t "~2%SNARK can be started by '~A'" name) + (format t "~%followed by (in-package :snark-user)") + (format t "~2%") + (force-output) + (ccl:save-application name :prepend-kernel t)) + +#+allegro +(defun save-snark-system (&key (name "snark-acl.dxl")) + (format t "~2%SNARK can be started by '~A -I ~A'" (sys:command-line-argument 0) name) + (format t "~%followed by (in-package :snark-user)") + (format t "~2%") + (force-output) + (cl-user::dumplisp :name name) + (quit)) + +#+clisp +(defun save-snark-system (&key (name "snark-lispinit.mem")) + (format t "~2%SNARK can be started by '~A -M ~A'" "clisp" name) + (format t "~2%") + (force-output) + (ext:saveinitmem name) + (quit)) + +;;; wffs are stored with variables in block 0 +;;; these are used directly for demodulation and subsumption +;;; given wff is renumbered to have variables in block 1 +;;; additional inference operation inputs are renumbered to have variables in block 2, 3, ... +;;; result of inference operation will have variables in blocks 1, 2, 3, ... (but not 0) +;;; and possibly "temporary" variables as well + +;;; main.lisp EOF diff --git a/src/map-file.lisp b/src/map-file.lisp new file mode 100644 index 0000000..128b295 --- /dev/null +++ b/src/map-file.lisp @@ -0,0 +1,85 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*- +;;; File: map-file.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-lisp) + +(defun mapnconc-file-forms (function filespec &key (if-does-not-exist :error) (package *package*)) + ;; apply function to each form in file and return the result of nconc'ing the values + (with-open-file (stream filespec :direction :input :if-does-not-exist if-does-not-exist) + (when stream + (mapnconc-stream-forms function stream :package package)))) + +(defun mapnconc-file-lines (function filespec &key (if-does-not-exist :error) (package *package*)) + ;; apply function to each line in file and return the result of nconc'ing the values + (with-open-file (stream filespec :direction :input :if-does-not-exist if-does-not-exist) + (when stream + (mapnconc-stream-lines function stream :package package)))) + +(defun mapnconc-stream-forms (function stream &key (package *package*)) + ;; apply function to each form in stream and return the result of nconc'ing the values + (prog-> + (find-or-make-package package -> *package*) + (mapnconc-stream0 stream #'read ->* form) + (cond + ((and (consp form) (eq 'in-package (first form))) + (eval form) + nil) + ((or (null function) (eq 'list function) (eq #'list function)) + (list form)) + (t + (funcall function form))))) + +(defun mapnconc-stream-lines (function stream &key (package *package*)) + ;; apply function to each line in stream and return the result of nconc'ing the values + (prog-> + (find-or-make-package package -> *package*) + (mapnconc-stream0 stream #'read-line ->* line) + (cond + ((or (null function) (eq 'list function) (eq #'list function)) + (list line)) + (t + (funcall function line))))) + +(defun mapnconc-stream0 (function stream read-function) + (let ((eof (cons nil nil)) + (result nil) result-last) + (loop + (let ((x (funcall read-function stream nil eof))) + (if (eq eof x) + (return result) + (ncollect (funcall function x) result)))))) + +(defun read-file (filespec &rest mapnconc-file-forms-options) + (declare (dynamic-extent mapnconc-file-forms-options)) + (apply #'mapnconc-file-forms nil filespec mapnconc-file-forms-options)) + +(defun read-file-lines (filespec &rest mapnconc-file-lines-options) + (declare (dynamic-extent mapnconc-file-lines-options)) + (apply #'mapnconc-file-lines nil filespec mapnconc-file-lines-options)) + +(defun read-file-to-string (filespec &key (if-does-not-exist :error)) + (with-open-file (stream filespec :direction :input :if-does-not-exist if-does-not-exist) + (with-output-to-string (string) + (loop + (let ((ch (read-char stream nil :eof))) + (if (eq :eof ch) + (return string) + (write-char ch string))))))) + +;;; map-file.lisp EOF diff --git a/src/multiset-ordering.lisp b/src/multiset-ordering.lisp new file mode 100644 index 0000000..87a257e --- /dev/null +++ b/src/multiset-ordering.lisp @@ -0,0 +1,349 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: multiset-ordering.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; comparison function should return >, <, =, or ? +;;; +;;; if testval is non-nil, it should be one of >, <, or =, +;;; (eq testval (compare ... testval)) is true +;;; iff +;;; (eq testval (compare ...))) is true, +;;; but faster + +(defun compare-multisets (compare list1 list2 &optional testval) + (let ((eql-alist nil)) + (dolist (x list1) + (setf eql-alist (acons+ x 1 eql-alist))) + (dolist (y list2) + (setf eql-alist (acons+ y -1 eql-alist))) + (cond + ((alist-notany-minusp eql-alist) + (if (alist-notany-plusp eql-alist) '= '>)) + ((alist-notany-plusp eql-alist) + '<) + (t + (let ((alist nil)) + (flet ((equal0 (x y) (eq '= (funcall compare x y '=)))) + (declare (dynamic-extent #'equal0)) + (dolist (x eql-alist) + (setf alist (acons+ (car x) (cdr x) alist :test #'equal0)))) + (cond + ((alist-notany-minusp alist) + (if (alist-notany-plusp alist) '= '>)) + ((alist-notany-plusp alist) + '<) + ((and (or (null testval) (eq '> testval)) + (dolist (y alist t) + (declare (type cons y)) + (when (minusp (cdr y)) + (unless (dolist (x alist nil) + (declare (type cons x)) + (when (plusp (cdr x)) + (if (or testval (not (test-option39?))) + (when (eq '> (funcall compare (car x) (car y) '>)) + (return t)) + (case (funcall compare (car x) (car y)) + (> + (return t)) + (< + (setf (cdr x) 0)))))) + (return nil))))) + '>) + ((and (or (null testval) (eq '< testval)) + (dolist (x alist t) + (declare (type cons x)) + (when (plusp (cdr x)) + (unless (dolist (y alist nil) + (declare (type cons y)) + (when (minusp (cdr y)) + (when (eq '< (funcall compare (car x) (car y) '<)) + (return t)))) + (return nil))))) + '<) + (t + (if (null testval) '? nil)))))))) + +(defun compare-term-multisets (compare xargs yargs &optional subst testval) + + ;; first, strip off initial eql arguments + (loop + (cond + ((null xargs) + (return-from compare-term-multisets (if (null yargs) '= '<))) + ((null yargs) + (return-from compare-term-multisets '>)) + ((eql (first xargs) (first yargs)) + (setf xargs (rest xargs)) + (setf yargs (rest yargs))) + (t + (return)))) + + ;; quick comparison of singleton multisets + (cond + ((null (rest xargs)) + (cond + ((null (rest yargs)) + (return-from compare-term-multisets (funcall compare (first xargs) (first yargs) subst testval))) + ((member (first xargs) yargs) + (return-from compare-term-multisets '<)))) + ((null (rest yargs)) + (cond + ((member (first yargs) xargs) + (return-from compare-term-multisets '>))))) + + (let ((variable-counts nil) (constant-counts nil) (compound-counts nil) + (xargs-compound-exists nil) (yargs-compound-exists nil) + (xargs-remain nil) (yargs-remain nil) term) + + ;; destructively updates lists of + ;; variable and count pairs, + ;; constant and count pairs, and + ;; compound and count paris + ;; term and count pair is represented as (term . count) + (let (v) ;count variables and constants in xargs + (dolist (term xargs) + (dereference + term subst + :if-compound (setf xargs-compound-exists t) + :if-variable (cond + ((null variable-counts) + (setf variable-counts (cons (make-tc term 1) nil))) + ((setf v (assoc/eq term variable-counts)) + (incf (tc-count v))) + (t + (push (make-tc term 1) variable-counts))) + :if-constant (cond + ((null constant-counts) + (setf constant-counts (cons (make-tc term 1) nil))) + ((setf v (assoc term constant-counts)) + (incf (tc-count v))) + (t + (push (make-tc term 1) constant-counts)))))) + + (let (v) ;count variables and constants in yargs + (dolist (term yargs) + (dereference + term subst + :if-compound (setf yargs-compound-exists t) + :if-variable (cond + ((null variable-counts) + (if (eq '= testval) + (return-from compare-term-multisets nil) + (setf variable-counts (cons (make-tc term -1) nil)))) + ((setf v (assoc/eq term variable-counts)) + (if (and (eq '= testval) (eql 0 (tc-count v))) + (return-from compare-term-multisets nil) + (decf (tc-count v)))) + (t + (if (eq '= testval) + (return-from compare-term-multisets nil) + (push (make-tc term -1) variable-counts)))) + :if-constant (cond + ((null constant-counts) + (if (eq '= testval) + (return-from compare-term-multisets nil) + (setf constant-counts (cons (make-tc term -1) nil)))) + ((setf v (assoc term constant-counts)) + (if (and (eq '= testval) (eql 0 (tc-count v))) + (return-from compare-term-multisets nil) + (decf (tc-count v)))) + (t + (if (eq '= testval) + (return-from compare-term-multisets nil) + (push (make-tc term -1) constant-counts))))))) + + (when (eq '= testval) + (dolist (v constant-counts) + (unless (eql 0 (tc-count v)) + (return-from compare-term-multisets nil))) + (dolist (v variable-counts) + (unless (eql 0 (tc-count v)) + (return-from compare-term-multisets nil))) + (cond + ((not xargs-compound-exists) + (return-from compare-term-multisets (if yargs-compound-exists nil '=))) + ((not yargs-compound-exists) + (return-from compare-term-multisets nil)))) + + (when (or xargs-compound-exists yargs-compound-exists) + (flet ((equal0 (x y) (eq '= (funcall compare x y subst '=)))) + (declare (dynamic-extent #'equal0)) + + (when xargs-compound-exists + (let (v) ;count compounds in xargs + (dolist (term xargs) + (dereference + term subst + :if-compound (cond + ((null compound-counts) + (setf compound-counts (cons (make-tc term 1) nil))) + ((setf v (or (assoc/eq term compound-counts) + (assoc term compound-counts :test #'equal0))) + (incf (tc-count v))) + (t + (push (make-tc term 1) compound-counts))))))) + + (when yargs-compound-exists + (let (v) ;count compounds in yargs + (dolist (term yargs) + (dereference + term subst + :if-compound (cond + ((null compound-counts) + (if (eq '= testval) + (return-from compare-term-multisets nil) + (setf compound-counts (cons (make-tc term -1) nil)))) + ((setf v (or (assoc/eq term compound-counts) + (assoc term compound-counts :test #'equal0))) + (if (and (eq '= testval) (eql 0 (tc-count v))) + (return-from compare-term-multisets nil) + (decf (tc-count v)))) + (t + (if (eq '= testval) + (return-from compare-term-multisets nil) + (push (make-tc term -1) compound-counts)))))))))) + + (when (eq '= testval) + (dolist (v compound-counts) + (unless (eql 0 (tc-count v)) + (return-from compare-term-multisets nil))) + (return-from compare-term-multisets '=)) + + (dolist (x variable-counts) + (when (plusp (tc-count x)) + (setf term (tc-term x)) + (or (dolist (y compound-counts nil) + (when (minusp (tc-count y)) + (when (eq '> (funcall compare (tc-term y) term subst '>)) + (setf (tc-count x) 0) + (return t)))) + (cond ;uneliminated xarg variable + ((and testval (neq '> testval)) + (return-from compare-term-multisets nil)) + (t + (setf xargs-remain t)))))) + + (dolist (y variable-counts) + (when (minusp (tc-count y)) + (setf term (tc-term y)) + (or (dolist (x compound-counts nil) + (when (plusp (tc-count x)) + (when (eq '> (funcall compare (tc-term x) term subst '>)) + (setf (tc-count y) 0) + (return t)))) + (cond ;uneliminated yarg variable + ((and testval (neq '< testval)) + (return-from compare-term-multisets nil)) + (xargs-remain + (return-from compare-term-multisets '?)) + (t + (setf yargs-remain t)))))) + + (dolist (x constant-counts) + (when (plusp (tc-count x)) + (setf term (tc-term x)) + (dolist (y constant-counts nil) + (when (minusp (tc-count y)) + (ecase (symbol-ordering-compare term (tc-term y)) + (< + (setf (tc-count x) 0) + (return t)) + (> + (setf (tc-count y) 0)) + (? + )))))) + + (dolist (x constant-counts) + (when (plusp (tc-count x)) + (setf term (tc-term x)) + (or (dolist (y compound-counts nil) + (when (minusp (tc-count y)) + (ecase (funcall compare (tc-term y) term subst nil) + (> + (setf (tc-count x) 0) + (return t)) + (< + (setf (tc-count y) 0)) + (? + )))) + (cond ;uneliminated xarg constant + ((and testval (neq '> testval)) + (return-from compare-term-multisets nil)) + (yargs-remain + (return-from compare-term-multisets '?)) + (t + (setf xargs-remain t)))))) + + (dolist (y constant-counts) + (when (minusp (tc-count y)) + (setf term (tc-term y)) + (or (dolist (x compound-counts nil) + (when (plusp (tc-count x)) + (ecase (funcall compare (tc-term x) term subst nil) + (> + (setf (tc-count y) 0) + (return t)) + (< + (setf (tc-count x) 0)) + (? + )))) + (cond ;uneliminated yarg constant + ((and testval (neq '< testval)) + (return-from compare-term-multisets nil)) + (xargs-remain + (return-from compare-term-multisets '?)) + (t + (setf yargs-remain t)))))) + + (dolist (x compound-counts) + (when (plusp (tc-count x)) + (setf term (tc-term x)) + (or (dolist (y compound-counts nil) + (when (minusp (tc-count y)) + (ecase (funcall compare term (tc-term y) subst nil) + (< + (setf (tc-count x) 0) + (return t)) + (> + (setf (tc-count y) 0)) + (? + )))) + (cond ;uneliminated xarg compound + ((and testval (neq '> testval)) + (return-from compare-term-multisets nil)) + (yargs-remain + (return-from compare-term-multisets '?)) + (t + (setf xargs-remain t)))))) + + ;;(cl:assert (not (and xargs-remain yargs-remain))) + (cond + (yargs-remain + '<) + ((dolist (y compound-counts nil) + (when (minusp (tc-count y)) + (return t))) ;uneliminated yarg compound + (if xargs-remain '? '<)) + (xargs-remain + '>) + (t + '=)))) + +;;; multiset-ordering.lisp EOF diff --git a/src/mvlet.lisp b/src/mvlet.lisp new file mode 100644 index 0000000..3e9d3c3 --- /dev/null +++ b/src/mvlet.lisp @@ -0,0 +1,251 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*- +;;; File: mvlet.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-lisp) + +;;; MVLET and MVLET* are extensions of LET and LET* +;;; that add to the list of binding forms +;;; the forms ((values var1 var2 var*) [init-form]) +;;; ((list var1 var2 var*) [init-form]) +;;; ((list* var1 var2 var*) [init-form]) +;;; that does multiple-value-binding and list destructuring +;;; extra values in init-form are ignored; missing ones are replaced by nil +;;; note that allowing fewer than two variables isn't really useful +;;; +;;; the troublesome part: +;;; declarations at the beginning of the body +;;; are decoded and placed in the proper locations +;;; in the expansion +;;; +;;; stickel@ai.sri.com 1999-08-09 + +(defmacro mvlet (bindings &body body) + (mvlet-expansion bindings body nil)) + +(defmacro mvlet* (bindings &body body) + (mvlet-expansion bindings body :none)) + +(defun binding-p (x) + ;; var + ;; (var [init-form]) + ;; ((values var1 var2 var*) [init-form]) + ;; ((list var1 var2 var*) [init-form]) + ;; ((list* var1 var2 var*) [init-form]) + (or (symbolp x) + (and (consp x) + (listp (cdr x)) + (null (cddr x)) + (if (consp (car x)) + (case (caar x) + ((values list list* :values :list :list*) + (do ((l (cdar x) (cdr l)) + (n 0 (+ n 1))) + ((atom l) + (and (null l) (<= 2 n))) + (unless (symbolp (car l)) + (return nil))))) + (symbolp (car x)))))) + +(defun list-bindings (vars form &optional list*) + ;; (list-bindings '(a b c d) 'foo nil) -> ((v foo) (a (pop v)) (b (pop v)) (c (first v)) (d (second v))) + ;; (list-bindings '(a b c d) 'foo t) -> ((v foo) (a (pop v)) (b (pop v)) (c (first v)) (d (rest v))) + (let ((vars (reverse vars)) + (v (gensym))) + (do ((l (cddr vars) (cdr l)) + (l2 (list `(,(second vars) (first ,v)) + `(,(first vars) ,(if list* `(rest ,v) `(second ,v)))) + (cons `(,(first l) (pop ,v)) l2))) + ((null l) + (cons `(,v ,form) l2))))) + +(defun mvlet-expansion (bindings body subst) + (cond + ((null bindings) + `(let () ,@body)) + (t + (dolist (b bindings) + (unless (binding-p b) + (error "~S is not a proper binding." b))) + (multiple-value-bind (decl-specs body) (extract-declaration-specifiers body) + (first (expand-mvlet bindings decl-specs body subst)))))) + +(defun expand-mvlet (bindings decl-specs body subst) + (let (v) + (cond + ((null bindings) + (let ((result body)) + (when decl-specs + (setf result `((declare ,@decl-specs) ,@result))) + (when (consp subst) + (setf result `((let ,(reverse subst) ,@result)))) + result)) + + ;; var or (var constant) + ((or (symbolp (setf v (car bindings))) + (and (symbolp (setf v (caar bindings))) + (constantp (cadar bindings)))) + (let ((val (if (consp (car bindings)) (cadar bindings) nil))) + (if (and (listp subst) (rest bindings)) + (expand-mvlet (rest bindings) decl-specs body (cons (list v val) subst)) + `((let ((,v ,val)) + ,@(expand-mvlet1 (rest bindings) decl-specs body subst v)))))) + + ;; (var init-form) + ((symbolp v) + (when (and (listp subst) (rest bindings)) + (push (list v (setf v (make-symbol (symbol-name v)))) subst)) + `((let ((,v ,(cadar bindings))) + ,@(expand-mvlet1 (rest bindings) decl-specs body subst v)))) + + ;; ((values var1 var2 var*) [init-form]) + ((member (first (setf v (caar bindings))) '(values :values)) + (setf v (rest v)) + (when (and (listp subst) (rest bindings)) + (setf v (mapcar + #'(lambda (v1) + (push (list v1 (setf v1 (make-symbol (symbol-name v1)))) subst) + v1) + v))) + `((multiple-value-bind ,v ,(cadar bindings) + ,@(expand-mvlet1 (rest bindings) decl-specs body subst v)))) + + ;; ((list var1 var2 var*) [init-form]) + ;; ((list* var1 var2 var*) [init-form]) + ((member (first v) '(list list* :list :list*)) + (let ((b (list-bindings (rest v) (cadar bindings) (member (first v) '(list* :list*))))) + `((let (,(first b)) + ,@(expand-mvlet (append (rest b) (rest bindings)) decl-specs body subst)))))))) + +(defun expand-mvlet1 (bindings decl-specs body subst v) + (multiple-value-bind (l1 l2) (filter-declaration-specifiers decl-specs v subst) + (if (null l1) + (expand-mvlet bindings l2 body subst) + (cons `(declare ,@l1) (expand-mvlet bindings l2 body subst))))) + +(defun type-symbol-p (x) + ;; is X a symbol that names a type? + (and (symbolp x) + (handler-case + (progn (typep nil x) t) ;is there a better way? + (error () nil)))) + +(defun extract-declaration-specifiers (body) + ;; returns declaration-specifiers of declarations at beginning of body + ;; (declare (fixnum x y)) -> ((type fixnum x) (type fixnum y)) etc. + ;; declaration-specifier syntax + ;; relevant to mvlet + ;; (dynamic-extent [[var* | (function fn)*]]) + ;; (ignorable {var | (function fn)}*) (1) + ;; (ignore {var | (function fn)}*) + ;; (special var*) + ;; (type typespec var*) + ;; (a-symbol-which-is-the-name-of-a-type var*) + ;; irrelevant to mvlet? + ;; (declaration name*) + ;; (ftype type function-name*) + ;; (function ???) + ;; (inline function-name*) + ;; (notinline function-name*) + ;; (optimize ???) + ;; (a-symbol-declared-to-be-a-declaration-identifier ???) + ;; (1) fix CLHS glossary: add IGNORABLE to list of declaration identifiers + (let ((decl-specs nil) form) + (loop + (cond + ((and body (consp (setf form (first body))) (eq 'declare (first form))) + (dolist (decl-spec (rest form)) + (let ((decl-id (first decl-spec))) + (case decl-id + ((dynamic-extent ignorable ignore special) + (dolist (v (rest decl-spec)) + (push `(,decl-id ,v) decl-specs))) + (type + (let ((type (second decl-spec))) + (dolist (v (rest (rest decl-spec))) + (push `(,decl-id ,type ,v) decl-specs)))) + (otherwise + (if (type-symbol-p decl-id) + (dolist (v (rest decl-spec)) + (push `(type ,decl-id ,v) decl-specs)) + (push decl-spec decl-specs)))))) + (setf body (rest body))) + (t + (return (values (nreverse decl-specs) body))))))) + +(defun filter-declaration-specifiers (decl-specs v subst) + ;; returns (values l1 l2) where + ;; l1 are declaration specifiers in decl-specs that concern + ;; variable or variables v and + ;; l2 are declaration specifiers in decl-specs that don't + (if (null decl-specs) + (values nil nil) + (let ((d (first decl-specs)) + (r (rest decl-specs))) + (multiple-value-bind (l1 l2) (filter-declaration-specifiers r v subst) + (if (case (first d) + ((dynamic-extent ignorable ignore special) + (if (consp v) (member (second d) v) (eq (second d) v))) + (type + (if (consp v) (member (third d) v) (eq (third d) v)))) + (setf l1 (if (eq l1 r) decl-specs (cons d l1))) + (setf l2 (if (eq l2 r) decl-specs (cons d l2)))) + ;; also add to l1 some declarations for temporary variables + ;; that variable or variables v will be bound to + (when (consp subst) + (case (first d) + (dynamic-extent + (let ((x (second (assoc (second d) subst)))) + (when (and x (if (consp v) (member x v) (eq x v))) + (push `(,(first d) ,x) l1)))) + (type + (let ((x (second (assoc (third d) subst)))) + (when (and x (if (consp v) (member x v) (eq x v))) + (push `(,(first d) ,(second d) ,x) l1)))))) + (values l1 l2))))) + +(defun mvlet-test1 () + (let ((form '(mvlet* ((u (foo)) + (v 13) + ((values w x) (bar)) + (y (baz))) + (declare (fixnum v x) (special y w)) + (declare (dynamic-extent x)) + (list u v w x y))) + (*print-pretty* t)) + (print (macroexpand-1 (print form))) + (terpri) + (print (macroexpand-1 (print (cons 'mvlet (rest form))))) + nil)) + +(defun mvlet-test2 () + (let ((form '(mvlet (((values a1 a2 a3) (foo)) + ((list b1 b2 b3) (bar)) + ((list* c1 c2 c3) (baz))) + (list a1 a2 a3 b1 b2 b3 c1 c2 c3))) + (*print-pretty* t)) + (print (macroexpand-1 (print form))) + nil)) + +#+(and mcl (not openmcl)) +(progn + (pushnew '(mvlet . 1) ccl:*fred-special-indent-alist* :test #'equal) + (pushnew '(mvlet* . 1) ccl:*fred-special-indent-alist* :test #'equal) + nil) + +;;; mvlet.lisp EOF diff --git a/src/nonhorn-magic-set.lisp b/src/nonhorn-magic-set.lisp new file mode 100644 index 0000000..f4c1fac --- /dev/null +++ b/src/nonhorn-magic-set.lisp @@ -0,0 +1,131 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: nonhorn-magic-set.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun make-magic-goal-atom (atom) + (flet ((magic-goal-name (name) + (intern (to-string :goal_ name) :snark-user))) + (dereference + atom nil + :if-constant (let ((v (constant-magic atom))) + (if (or (null v) (eq 'goal v)) + true + (if (eq t v) + (setf (constant-magic atom) + (declare-proposition + (magic-goal-name atom) + :magic 'goal)) + v))) + :if-compound (let* ((head (head atom)) + (v (function-magic head))) + (if (or (null v) (eq 'goal v)) + true + (make-compound* (if (eq t v) + (setf (function-magic head) + (declare-relation + (magic-goal-name (function-name head)) + (function-arity head) + :commutative (function-commutative head) + :magic 'goal)) + v) + (args atom))))))) + +(defun magic-transform-clause (cc clause &key (transform-negative-clauses t) (transform-positive-units nil)) + ;; {d} yields + ;; {d} if transform-positive-units is false + ;; or + ;; {~goal_d, d} if transform-positive-units is true + ;; {d, e, f} yields + ;; {~goal_d, ~goal_e, ~goal_f, d, e, f} + ;; {~a} yields + ;; {goal_a} if transform-negative-clauses is true + ;; and + ;; {~a} + ;; {~a, ~b, ~c} yields + ;; {goal_a} if transform-negative-clauses is true + ;; and + ;; {~a, goal_b} if transform-negative-clauses is true + ;; and + ;; {~a, ~b, goal_c} if transform-negative-clauses is true + ;; and + ;; {~a, ~b, ~c} + ;; {~a, ~b, ~c, d, e, f} yields + ;; {~goal_d, ~goal_e, ~goal_f, goal_a} + ;; and + ;; {~goal_d, ~goal_e, ~goal_f, ~a, goal_b} + ;; and + ;; {~goal_d, ~goal_e, ~goal_f, ~a, ~b, goal_c} + ;; and + ;; {~goal_d, ~goal_e, ~goal_f, ~a, ~b, ~c, d, e, f} + (let ((posatoms nil) posatoms-last + (negatoms nil) negatoms-last) + (prog-> + (map-atoms-in-clause clause ->* atom polarity) + (if (eq :pos polarity) (collect atom posatoms) (collect atom negatoms))) + (cl:assert (not (and (null posatoms) (null negatoms)))) + (let ((l nil) l-last) + (dolist (atom posatoms) + (collect (negate (make-magic-goal-atom atom)) l)) + (dolist (atom negatoms) + (unless (and (null posatoms) (not transform-negative-clauses)) + (funcall cc (disjoin* (append l (list (make-magic-goal-atom atom)))))) + (collect (negate atom) l)) + (cond + ((and (null negatoms) (null (rest posatoms)) (not transform-positive-units)) + (funcall cc (first posatoms))) + (t + (funcall cc (disjoin* (append l posatoms))))))) + nil) + +(defun magic-transform-wff (wff &key (transform-negative-clauses t) (transform-positive-units nil)) + ;; for use only if wff is a clause or conjunction of clauses + ;; magic-transform-wff is idempotent + (if (or (eq true wff) (eq false wff)) + wff + (let ((clauses nil) clauses-last) + (prog-> + (map-conjuncts wff ->* clause) + (magic-transform-clause + clause + :transform-negative-clauses transform-negative-clauses + :transform-positive-units transform-positive-units + ->* clause) + (collect clause clauses)) + (conjoin* clauses)))) + +(defun proposition-magic-goal-p (prop) + (eq 'goal (constant-magic prop))) + +(defun relation-magic-goal-p (rel) + (eq 'goal (function-magic rel))) + +(defun magic-goal-atom-p (atom) + (dereference + atom nil + :if-constant (proposition-magic-goal-p atom) + :if-compound (relation-magic-goal-p (head atom)))) + +(defun magic-goal-occurs-p (wff) + (prog-> + (map-atoms-in-wff wff ->* atom polarity) + (when (and (eq :pos polarity) (magic-goal-atom-p atom)) + (return-from prog-> t)))) + +;;; nonhorn-magic-set.lisp EOF diff --git a/src/numbering-system.lisp b/src/numbering-system.lisp new file mode 100644 index 0000000..4249f4c --- /dev/null +++ b/src/numbering-system.lisp @@ -0,0 +1,32 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: numbering-system.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +(defpackage :snark-numbering + (:use :common-lisp :snark-lisp :snark-sparse-array) + (:export + #:nonce + #:initialize-numberings #:make-numbering + #:*standard-eql-numbering* + )) + +(loads "numbering") + +;;; numbering-system.lisp EOF diff --git a/src/numbering.lisp b/src/numbering.lisp new file mode 100644 index 0000000..2eff933 --- /dev/null +++ b/src/numbering.lisp @@ -0,0 +1,82 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-numbering -*- +;;; File: numbering.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-numbering) + +(defvar *nonce* 0) +(declaim (type integer *nonce*)) +(defvar *standard-eql-numbering*) + +(definline nonce () + ;; each call returns a new positive value in ascending order + (incf *nonce*)) + +(defun initialize-numberings () + (setf *nonce* 0) + (setf *standard-eql-numbering* (make-numbering :test #'eql)) + nil) + +(defun make-numbering (&key (test #'eql) (inverse t)) + ;; make-numbering returns a function f such that + ;; (f :lookup object) returns a unique number for object, adding one if necessary + ;; (f :lookup? object) returns the number for object or nil if there isn't one + ;; (f :delete object) deletes an object from the numbering + ;; (f :inverse number) returns an object by its number + ;; (f :map fn) applies binary function fn to each object and its number + (let ((table (make-hash-table :test test))) + (if inverse + (let ((invtable (make-sparse-vector :default-value '%absent%))) + (lambda (action arg) + (ecase action + (:lookup + (or (gethash arg table) + (let ((number (nonce))) + (setf (sparef invtable number) arg (gethash arg table) number)))) + (:lookup? + (gethash arg table)) + (:inverse + (let ((object (sparef invtable arg))) + (if (eq '%absent% object) (error "No object numbered ~D." arg) object))) + (:delete + (let ((number (gethash arg table))) + (when number + (setf (sparef invtable number) '%absent%) + (remhash arg table) + number))) + (:map + (map-sparse-vector-with-indexes arg invtable))))) + (lambda (action arg) + (ecase action + (:lookup + (or (gethash arg table) + (let ((number (nonce))) + (setf (gethash arg table) number)))) + (:lookup? + (gethash arg table)) + (:delete + (let ((number (gethash arg table))) + (when number + (remhash arg table) + number)))))))) + +#+ignore +(eval-when (:load-toplevel :execute) + (initialize-numberings)) + +;;; numbering.lisp EOF diff --git a/src/options.lisp b/src/options.lisp new file mode 100644 index 0000000..eabae51 --- /dev/null +++ b/src/options.lisp @@ -0,0 +1,395 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: options.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim (special *snark-globals* *agenda-of-rows-to-give* *agenda-of-rows-to-process*)) + +(defvar *snark-options* nil) + +(defmacro declare-snark-option (name &optional (default-value nil) (invisible-value :always-print)) + ;; example: + ;; (declare-snark-option USE-FOO t) + ;; yields the functions USE-FOO, DEFAULT-USE-FOO, USE-FOO? + ;; + ;; (USE-FOO value) sets the value of the USE-FOO option + ;; (USE-FOO) sets the value of the USE-FOO option to T + ;; + ;; (DEFAULT-USE-FOO value) sets the default value of the USE-FOO option + ;; (DEFAULT-USE-FOO) sets the default value of the USE-FOO option to T + ;; + ;; (USE-FOO?) returns the value of the USE-FOO option + ;; (DEFAULT-USE-FOO?) returns the default value of the USE-FOO option + ;; + ;; (initialize) will initialize options to their default values + ;; + ;; DEFAULT-USE-FOO should be used BEFORE initialize to establish a + ;; default value for foo for all future runs; USE-FOO should be used + ;; AFTER initialize to change the value of foo for an individual run + ;; + ;; (print-options) will print the value of each SNARK option + ;; whose value differs from its invisible value (:always-print + ;; or :never-print can be specified instead of an invisible value) + (cl:assert (or (symbolp name) (stringp name))) + (setf name (intern (string name) :snark)) + (let ((snark-option-variable-name (intern (to-string "*%" name "%*") :snark)) + (default-snark-option-variable-name (intern (to-string :*%default- name "%*") :snark)) + (invisible-snark-option-variable-name (intern (to-string :*%invisible- name "%*") :snark)) + (snark-option-access-function-name (intern (to-string name "?") :snark)) + (default-snark-option-function-name (intern (to-string :default- name) :snark)) + (default-snark-option-access-function-name (intern (to-string :default- name "?") :snark))) + `(progn + (unless (member ',name *snark-options*) + (setf *snark-options* (nconc *snark-options* (list ',name))) + (nconc *snark-globals* + (list ',snark-option-variable-name)) + (nconc *snark-nonsave-globals* + (list ',default-snark-option-variable-name + ',invisible-snark-option-variable-name))) + + (eval-when (:compile-toplevel :load-toplevel :execute) + (export '(,default-snark-option-access-function-name + ,default-snark-option-function-name + ,snark-option-access-function-name + ,name) + :snark)) + + (defparameter ,default-snark-option-variable-name ,default-value) + + (defparameter ,invisible-snark-option-variable-name ,invisible-value) + + (defvar ,snark-option-variable-name ,default-snark-option-variable-name) + + (defun ,default-snark-option-access-function-name () + ,default-snark-option-variable-name) + + (defun ,default-snark-option-function-name (&optional (value t)) + (setf ,default-snark-option-variable-name value)) ;affects only future runs + + (definline ,snark-option-access-function-name () + ,snark-option-variable-name) + + (defgeneric ,name (&optional value) + (:method (&optional (value t)) + (setf ,snark-option-variable-name value)))))) + +(declare-snark-option variable-symbol-prefixes '(#\?) :never-print) ;use first for output, any for input + +(declare-snark-option use-resolution nil) +(declare-snark-option use-hyperresolution nil) +(declare-snark-option use-negative-hyperresolution nil) +(declare-snark-option use-ur-resolution nil) +(declare-snark-option use-ur-pttp nil) +(declare-snark-option use-paramodulation nil) +(declare-snark-option use-factoring nil) +(declare-snark-option use-equality-factoring nil) +(declare-snark-option use-condensing t) +(declare-snark-option use-resolve-code nil) ;list of resolve-code functions + +(declare-snark-option use-unit-restriction nil) +(declare-snark-option use-input-restriction nil) +(declare-snark-option use-literal-ordering-with-resolution nil) +(declare-snark-option use-literal-ordering-with-hyperresolution nil) +(declare-snark-option use-literal-ordering-with-negative-hyperresolution nil) +(declare-snark-option use-literal-ordering-with-ur-resolution nil) +(declare-snark-option use-literal-ordering-with-paramodulation nil) + +(declare-snark-option use-subsumption t) ;nil, :forward, t +(declare-snark-option use-subsumption-by-false :false) ;nil, :false, :forward, t +(declare-snark-option use-lookahead-in-dpll-for-subsumption t t) +(declare-snark-option use-simplification-by-units t) ;nil, :forward, t +(declare-snark-option use-simplification-by-equalities t) ;nil, :forward, t +(declare-snark-option use-term-ordering :rpo) ;nil, :manual, :kbo, :rpo, or a function +(declare-snark-option use-term-ordering-cache nil nil) +(declare-snark-option use-default-ordering t) ;nil, :arity, :reverse, t +(declare-snark-option 1-ary-functions>2-ary-functions-in-default-ordering nil) +(declare-snark-option ordering-functions>constants nil) ;t for speed, only if functions > constants always +(declare-snark-option rpo-status :multiset) ;default status +(declare-snark-option kbo-status :left-to-right) ;default status +(declare-snark-option kbo-variable-weight 1 1) ;number or var->number function (so different sort variables can have different weights); constant-weight >= this > 0 +(declare-snark-option kbo-builtin-constant-weight 1 1) ;number or const->number function + +(declare-snark-option use-indefinite-answers nil) ;nil, :disjunctive, :conditional (UNIMPLEMENTED) +(declare-snark-option use-conditional-answer-creation nil) +(declare-snark-option use-constructive-answer-restriction nil :never-print) ;no longer necessary (use constant-allowed-in-answer and function-allowed-in-answer) +(declare-snark-option use-answers-during-subsumption t :never-print) ;no longer necessary (always enabled) +(declare-snark-option use-constraint-solver-in-subsumption nil) +(declare-snark-option allow-skolem-symbols-in-answers t) +(declare-snark-option rewrite-answers nil) +(declare-snark-option rewrite-constraints t :never-print) ;nop +(declare-snark-option use-constraint-purification nil) ;nil, t, 1, 2 +(declare-snark-option use-embedded-rewrites t t) +(declare-snark-option use-function-creation nil) +(declare-snark-option use-replacement-resolution-with-x=x nil) +(declare-snark-option use-paramodulation-only-into-units nil) +(declare-snark-option use-paramodulation-only-from-units nil) +(declare-snark-option use-single-replacement-paramodulation nil) + +(declare-snark-option use-partitions nil nil) ;nil or list of partition ids +(declare-snark-option partition-communication-table nil :never-print) + +(declare-snark-option declare-root-sort :top-sort-a :top-sort-a) +(declare-snark-option declare-string-sort 'string 'string) ;string, :top-sort + +(declare-snark-option assert-context :root) ;:root, :current + +(declare-snark-option assert-supported t) ;nil, t :uninherited +(declare-snark-option assume-supported t) ;nil, t, :uninherited +(declare-snark-option prove-supported t) ;nil, t, :uninherited +(declare-snark-option assert-sequential nil) ;nil, t, :uninherited +(declare-snark-option assume-sequential nil) ;nil, t, :uninherited +(declare-snark-option prove-sequential nil) ;nil, t, :uninherited + +(declare-snark-option prove-closure t :never-print) + +(declare-snark-option number-of-given-rows-limit nil) +(declare-snark-option number-of-rows-limit nil) +(declare-snark-option agenda-length-before-simplification-limit 10000) +(declare-snark-option agenda-length-limit 3000) +(declare-snark-option run-time-limit nil) +(declare-snark-option row-argument-count-limit nil nil) +(declare-snark-option row-weight-limit nil) +(declare-snark-option row-weight-before-simplification-limit nil) +(declare-snark-option level-pref-for-giving nil) +(declare-snark-option variable-weight 1 1) ;number or var->number function (so different sort variables can have different weights) +(declare-snark-option builtin-constant-weight 1 1) ;number or const->number function +(declare-snark-option bag-weight-factorial nil nil) + +(declare-snark-option agenda-ordering-function 'row-priority) +(declare-snark-option row-priority-size-factor 0 0) +(declare-snark-option row-priority-weight-factor 1 1) +(declare-snark-option row-priority-depth-factor 1 1) +(declare-snark-option row-priority-level-factor 1 1) +(declare-snark-option pruning-tests '(row-weight-limit-exceeded)) +(declare-snark-option pruning-tests-before-simplification '(row-weight-before-simplification-limit-exceeded)) + +(declare-snark-option use-clausification t) +(declare-snark-option use-equality-elimination nil) ;nil, t, or :unconstrained +(declare-snark-option use-magic-transformation nil) +(declare-snark-option use-ac-connectives t) +(declare-snark-option use-purity-test nil) +(declare-snark-option use-relevance-test nil) +(declare-snark-option use-assertion-analysis t t) + +(declare-snark-option use-associative-unification nil nil) ;for declarations by assertion analysis +(declare-snark-option use-associative-identity nil nil) ;for declarations by assertion analysis +(declare-snark-option use-dp-subsumption nil nil) +(declare-snark-option unify-bag-basis-size-limit 1000 1000) + +(declare-snark-option use-term-memory-deletion t t) + +(declare-snark-option variable-sort-marker #\. :never-print) + +(declare-snark-option use-variable-name-sorts nil :never-print) ;deprecated +(declare-snark-option use-well-sorting nil :never-print) ;nil, t, or :terms +(declare-snark-option use-extended-implications 'warn :never-print) ;nil, t, or warn +(declare-snark-option use-extended-quantifiers 'warn :never-print) ;nil, t, or warn +(declare-snark-option use-sort-relativization nil :never-print) +(declare-snark-option use-quantifier-preservation nil :never-print) + +(declare-snark-option input-floats-as-ratios t :never-print) ;nop (always input floats as ratios) + +(declare-snark-option use-closure-when-satisfiable t :never-print) + +(declare-snark-option listen-for-commands nil :never-print) + +(declare-snark-option use-to-lisp-code t :never-print) ;turn off use of to-lisp-code +(declare-snark-option variable-to-lisp-code nil :never-print) + +(declare-snark-option print-rows-when-given nil :never-print) +(declare-snark-option print-rows-when-derived t :never-print) +(declare-snark-option print-rows-when-processed nil :never-print) +(declare-snark-option print-final-rows t :never-print) ;nil, t, :tptp, :tptp-too +(declare-snark-option print-unorientable-rows t :never-print) +(declare-snark-option print-pure-rows nil :never-print) +(declare-snark-option print-irrelevant-rows nil :never-print) +(declare-snark-option print-rewrite-orientation nil :never-print) ;1998-07-29 + +(declare-snark-option print-rows-test nil :never-print) + +;;; the following options control how a row is printed +(declare-snark-option print-rows-shortened nil :never-print) +(declare-snark-option print-rows-prettily t :never-print) +(declare-snark-option print-row-wffs-prettily t :never-print) +(declare-snark-option print-row-answers t :never-print) +(declare-snark-option print-row-constraints t :never-print) +(declare-snark-option print-row-reasons t :never-print) +(declare-snark-option print-row-goals t :never-print) +(declare-snark-option print-row-partitions t :never-print) +(declare-snark-option print-row-length-limit nil :never-print) +(declare-snark-option print-given-row-lines-printing 2 :never-print) +(declare-snark-option print-given-row-lines-signalling 1 :never-print) + +;;; the following options control what is printed when closure finishes +(declare-snark-option print-summary-when-finished t :never-print) +(declare-snark-option print-clocks-when-finished t :never-print) +(declare-snark-option print-term-memory-when-finished t :never-print) +(declare-snark-option print-agenda-when-finished t :never-print) +(declare-snark-option print-rows-when-finished nil :never-print) + +(declare-snark-option print-options-when-starting t :never-print) +(declare-snark-option print-assertion-analysis-notes t :never-print) +(declare-snark-option print-symbol-table-warnings t :never-print) + +;;; the following options are for debugging +(declare-snark-option print-time-used nil :never-print) +(declare-snark-option trace-unify nil :never-print) +(declare-snark-option meter-unify-bag nil :never-print) ;nil, t, or number of seconds +(declare-snark-option trace-unify-bag-basis nil :never-print) +(declare-snark-option trace-unify-bag-bindings nil :never-print) +(declare-snark-option trace-dp-refute nil :never-print) +(declare-snark-option trace-rewrite nil :never-print) +(declare-snark-option trace-optimize-sparse-vector-expression nil :never-print) +(declare-snark-option trace-dpll-subsumption nil :never-print) ;nil, :summary, :clauses + +(declare-snark-option changeable-properties-of-locked-constant '(:alias :allowed-in-answer :kbo-weight :weight) :never-print) +(declare-snark-option changeable-properties-of-locked-function '(:alias :allowed-in-answer :kbo-weight :weight :weight-code :new-name) :never-print) + +(declare-snark-option test-option2 nil nil) ;simplification-ordering-compare-equality-arguments +(declare-snark-option test-option3 nil nil) ;paramodulater for waldinger +(declare-snark-option test-option6 nil nil) ;clausify +(declare-snark-option test-option8 nil nil) ;unify-bag +(declare-snark-option test-option9 nil nil) ;rewriting during hyperresolution +(declare-snark-option test-option14 nil nil) ;sparse-vector-expressions for indexing +(declare-snark-option test-option17 nil nil) ;revert to nonspecial unification for jepd relation atoms +(declare-snark-option test-option18 nil nil) ;instance-graph - insert uses might-unify-p +(declare-snark-option test-option19 nil nil) ;revert to earlier rpo +(declare-snark-option test-option20 nil nil) ;rpo +(declare-snark-option test-option21 nil nil) ;maximum-intersection-size in optimize-sparse-vector-expression +(declare-snark-option test-option23 t t ) ;make skolem symbols bigger than nonskolems in default symbol ordering +(declare-snark-option test-option29 nil nil) ;magic-transform-positive-units +(declare-snark-option test-option30 nil nil) ;declare sort coercion functions like the-bird, the-integer +(declare-snark-option test-option36 nil nil) ;nil or cutoff for number of unifiers for incomplete subsumption test +(declare-snark-option test-option37 nil nil) ;nop (always use extended any-ary sum and product functions) +(declare-snark-option test-option38 nil nil) ;turn off term hashing +(declare-snark-option test-option39 nil nil) ;compare-multisets +(declare-snark-option test-option40 nil nil) ;rpo-compare-multisets +(declare-snark-option test-option41 nil nil) ;resolve with $$eq in constraints +(declare-snark-option test-option42 nil nil) ;rewrite ($$less a b) to (not ($$lesseq b a)) and ($$lesseq a b) to (not ($$less b a)) +(declare-snark-option test-option43 nil nil) ;don't use do-not-resolve atoms for rewriting +(declare-snark-option test-option44 nil nil) ;associative-identity-paramodulater generates only collapsed terms +(declare-snark-option test-option45 nil nil) ;function-identity2 returns identity when subsuming as well as unifying +(declare-snark-option test-option49 nil nil) ;don't use feature-vector-indexing minimum-depth features +(declare-snark-option test-option50 nil nil) ;don't use feature-vector-indexing ground-literal features +(declare-snark-option test-option51 nil nil) ;use feature-vector-indexing for term generalization retrievals +(declare-snark-option test-option52 nil nil) ;use feature-vector-indexing for term instance retrievals +(declare-snark-option test-option53 nil nil) +(declare-snark-option test-option54 nil nil) +(declare-snark-option test-option55 nil nil) +(declare-snark-option test-option56 nil nil) +(declare-snark-option test-option57 nil nil) +(declare-snark-option test-option58 nil nil) +(declare-snark-option test-option59 nil nil) +(declare-snark-option test-option60 nil nil) + +(defvar options-have-been-critiqued) + +(defun initialize-options () + (setf options-have-been-critiqued nil) + (dolist (name *snark-options*) + (setf (symbol-value (intern (to-string "*%" name "%*") :snark)) + (symbol-value (intern (to-string :*%default- name "%*") :snark))))) + +(defun finalize-options () + (dolist (name *snark-options*) + (funcall name (symbol-value (intern (to-string "*%" name "%*") :snark))))) + +(defun snark-option-spec-p (x) + ;; accepts print-rows-when-given, (print-rows-when-given), (print-rows-when-given nil) + ;; and default-print-rows-when-given etc. + (and (or (atom x) (and (listp (rest x)) (null (rrest x)))) + (let ((name (if (atom x) x (first x)))) + (and (symbolp name) + (or (member name *snark-options*) + (let ((s (symbol-name name))) + (and (<= 8 (length s)) + (string= :default- s :end2 8) + (member s *snark-options* :test #'(lambda (x y) (string= x y :start1 8)))))))))) + +(defun set-options (options) + (dolist (x options) + (if (snark-option-spec-p x) + (if (atom x) (funcall x t) (funcall (first x) (second x))) + (warn "~S is not a SNARK option setting." x)))) + +(defmacro let-options (options &body forms) + (let ((bindings nil) (settings nil)) + (dolist (x options) + (cond + ((snark-option-spec-p x) + (push (intern (to-string "*%" (if (atom x) x (first x)) "%*") :snark) bindings) + (push x settings)) + (t + (warn "~S is not a SNARK option setting." x) ;treat it as an ordinary let binding + (push x bindings)))) + `(let ,(nreverse bindings) + ,@(nreverse settings) + ,@forms))) + +#+(and mcl (not openmcl)) +(progn + (pushnew '(let-options . 1) ccl:*fred-special-indent-alist* :test #'equal) + nil) + +(defun print-options (&optional all) + (with-standard-io-syntax2 + (format t "~&; The current SNARK option values are") + (dolist (name *snark-options*) + (let ((value + (symbol-value + (intern (to-string "*%" name "%*") :snark))) + (default-value + (symbol-value + (intern (to-string :*%default- name "%*") :snark))) + (invisible-value + (symbol-value + (intern (to-string :*%invisible- name "%*") :snark)))) + (when (or all + (and (neq :never-print invisible-value) + (or (eq :always-print invisible-value) + (neq value invisible-value)))) + (if (neql value default-value) + (format t "~%; (~A ~S)" name value) + (format t "~%; (~A ~S)" name value))))) + (format t "~%") + nil)) + +(defmethod agenda-length-limit :before (&optional (value t)) + (limit-agenda-length *agenda-of-rows-to-give* value)) + +(defmethod agenda-length-before-simplification-limit :before (&optional (value t)) + (limit-agenda-length *agenda-of-rows-to-process* value)) + +(defmethod use-resolve-code :around (&optional (value nil)) + (call-next-method + (if (listp value) + (remove-duplicates value :from-end t) ;replace + (cons value (remove value (use-resolve-code?)))))) ;add + +(defmethod use-term-ordering :around (&optional (value nil)) + (call-next-method + (case value + (:recursive-path :rpo) + (:knuth-bendix :kbo) + (otherwise value)))) + +(defmethod use-constraint-purification :around (&optional (value nil)) + (call-next-method (if value 2 nil))) + +;;; options.lisp EOF diff --git a/src/output.lisp b/src/output.lisp new file mode 100644 index 0000000..1a5062f --- /dev/null +++ b/src/output.lisp @@ -0,0 +1,506 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: output.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defmacro with-no-output (&body forms) + ;; turn off SNARK printing options and redirect any remaining output to /dev/null + ;; example usage: + ;; (with-no-output + ;; (initialize) + ;; (assert ...) + ;; (prove ...)) + `(let-options ((default-print-rows-when-derived nil) + (default-print-rows-when-given nil) + (default-print-rows-when-processed nil) + (default-print-final-rows nil) + (default-print-unorientable-rows nil) + (default-print-pure-rows nil) + (default-print-irrelevant-rows nil) + (default-print-rewrite-orientation nil) + (default-print-summary-when-finished nil) + (default-print-clocks-when-finished nil) + (default-print-term-memory-when-finished nil) + (default-print-agenda-when-finished nil) + (default-print-rows-when-finished nil) + (default-print-options-when-starting nil) + (default-print-assertion-analysis-notes nil) + (default-print-symbol-table-warnings nil) + (print-rows-when-derived nil) + (print-rows-when-given nil) + (print-rows-when-processed nil) + (print-final-rows nil) + (print-unorientable-rows nil) + (print-pure-rows nil) + (print-irrelevant-rows nil) + (print-rewrite-orientation nil) + (print-summary-when-finished nil) + (print-clocks-when-finished nil) + (print-term-memory-when-finished nil) + (print-agenda-when-finished nil) + (print-rows-when-finished nil) + (print-options-when-starting nil) + (print-assertion-analysis-notes nil) + (print-symbol-table-warnings nil) + ) + #+mcl + (progn ,@forms) + #-mcl + (with-open-file (*standard-output* + (make-pathname :directory '(:absolute "dev") :name "null") + :direction :output + :if-exists :append) + (let ((*error-output* *standard-output*)) + ,@forms)))) + +(defun print-function-symbol (fn &optional (stream *standard-output*) depth) + (declare (ignore depth)) + (write (function-name fn) :stream stream) + fn) + +(defun print-variable (x &optional (stream *standard-output*) depth) + (declare (ignore depth)) + (let ((num (variable-number x)) + (sort (variable-sort x))) + (princ (first (variable-symbol-prefixes?)) stream) + (mvlet (((values i j) (floor num 6))) + (princ (nth j '(x y z u v w)) stream) + (unless (eql 0 i) + (write i :stream stream :base 10 :radix nil))) + (unless (top-sort? sort) + (princ (variable-sort-marker?) stream) + (princ (sort-name sort) stream)) + x)) + +(defun print-term3 (term &optional (stream *standard-output*) depth) + (declare (ignore depth)) + (print-term term nil stream)) + +(defun print-term (term &optional subst (stream *standard-output*)) + ;; terms are printed by first converting them to lisp + (with-standard-io-syntax2 + (write (term-to-lisp term subst) :stream stream)) + term) + +(defun print-row-term (term &optional subst (stream *standard-output*)) + (let ((term term)) + (when (print-row-length-limit?) + (dereference + term subst + :if-compound-appl (when (and (eq *or* (heada term)) (< (print-row-length-limit?) (length (argsa term)))) + (setf term (make-compound* *or* (nconc (firstn (argsa term) (print-row-length-limit?)) '(---))))))) + (let ((*print-pretty2* (and (print-rows-prettily?) (print-row-wffs-prettily?)))) + (print-term term subst stream))) + term) + +(defmethod print-given-row (row) + (case (print-rows-when-given?) + ((nil) + (when (eq :signal (print-rows-when-derived?)) + (comment) + (princ #\|))) + (:signal + (comment) + (princ #\|)) + (otherwise + (with-clock-on printing + (when (print-time-used?) + (print-incremental-time-used)) + (dotimes (dummy (- (case (print-rows-when-derived?) + ((:signal nil) + (print-given-row-lines-signalling?)) + (otherwise + (print-given-row-lines-printing?))) + 1)) + (declare (ignorable dummy)) + (terpri)) + (terpri) + (print-row row :string "Infer_from_row ") + (princ " ") + (force-output)))) + row) + +(defmethod print-derived-row (row) + (case (print-rows-when-derived?) + ((nil) + ) + (:signal + (comment) + (princ #\+)) + #+ignore + (:fact + (when (let ((wff (row-wff row))) + (dereference wff nil :if-compound (eq fact-relation (head wff)))) + (with-clock-on printing + (when (print-time-used?) + (print-incremental-time-used)) + (terpri) + (print-row row) + (princ " ")))) + (otherwise + (with-clock-on printing + (when (print-time-used?) + (print-incremental-time-used)) + (terpri) + (print-row row) + (princ " ")))) + row) + +(defun print-processed-row (row) + (case (print-rows-when-processed?) + ((nil :signal) + ) + (otherwise + (with-clock-on printing + (when (print-time-used?) + (print-incremental-time-used)) + (terpri) + (let-options ((use-to-lisp-code nil)) + (print-row row :string "Processing_row ")) + (princ " ")))) + row) + +(defun print-pure-row (row) + (case (print-pure-rows?) + ((nil) + ) + (otherwise + (with-clock-on printing + (when (print-time-used?) + (print-incremental-time-used)) + (terpri) + (print-row row :string "Pure_row ") + (princ " ")))) + row) + +(defvar *printing-deleted-messages* nil) + +(defun print-deleted-wff (row msg) + (case (print-rows-when-derived?) + ((nil) + ) + (:signal + (comment) + (princ (if (equal "deleted because agenda full" msg) #\d #\-))) + #+ignore + (:fact + (when (let ((wff (row-wff row))) + (dereference wff nil :if-compound (eq fact-relation (head wff)))) + (with-clock-on printing + (terpri-comment) + (format t " ~A ~A" msg (row-name-or-number row))))) + (otherwise + (with-clock-on printing + (cond + ((equal *printing-deleted-messages* msg) + (format t ",~A" (row-name-or-number row))) + (t + (terpri-comment) + (format t "~A ~A" msg (row-name-or-number row)) + (setf *printing-deleted-messages* msg)))))) + row) + +(defun print-unorientable-wff (equality-or-equivalence) + (case (print-unorientable-rows?) + ((nil :signal) + ) + (otherwise + (with-clock-on printing + (warn "Could not orient ~A." equality-or-equivalence)))) + equality-or-equivalence) + +(defvar *szs-filespec* nil) + +(defvar *szs-conjecture* nil) + +(defun print-szs-status (status &optional (nocomment nil) (filespec *szs-filespec*)) + (unless nocomment + (terpri) + (princ "#||") + (terpri)) + (princ "% SZS status ") + (princ (case status + (:proof-found + (if *szs-conjecture* "Theorem" "Unsatisfiable")) + (:run-time-limit + "Timeout") + (:agenda-empty + "GaveUp") + (otherwise + status))) + (when filespec + (princ " for ") + (princ filespec)) + (unless nocomment + (terpri) + (princ "||#") + (terpri))) + +(defun print-szs-answers-short (answers) + (let ((answers (mapcan (lambda (answer) + (and (compound-p answer) (eq 'values (function-name (head answer))) (list (args answer)))) + answers))) + (when answers + (princ "% SZS answers short ") + (print-term-in-tptp-format answers) + (terpri) + t))) + +(defun print-final-row (row) + (let ((p (print-final-rows?))) + (cond + ((null p) + ) + ((eq :signal p) + (comment) + (princ #\.)) + (t + (with-clock-on printing + (unless (eq :tptp p) + (terpri) + (terpri) + (princ "(Refutation") + (print-ancestry row) + (terpri) + (princ ")")) + (when (or (eq :tptp p) (eq :tptp-too p)) + (terpri) + (terpri) + (princ "#||") + (terpri) + (print-szs-status :proof-found t) + (terpri) + (print-szs-answers-short (list (row-answer row))) + (princ "% SZS output start Refutation") + (print-ancestry row :format :tptp) + (terpri) + (princ "% SZS output end Refutation") + (terpri) + (princ "||#"))))) + row)) + +(defun replace-rows-by-name-or-number (x) + (cond + ((consp x) + (lcons (replace-rows-by-name-or-number (car x)) (replace-rows-by-name-or-number (cdr x)) x)) + ((row-p x) + (row-name-or-number x)) + (t + x))) + +(defun print-row-reason (row) + (with-standard-io-syntax2 + (prin1 (replace-rows-by-name-or-number (row-reason row)))) + nil) + +(defun print-row3 (row *standard-output* depth) + "this function is used in the defstruct for ROW to print rows." + (declare (ignore depth)) + (let-options ((print-rows-shortened nil) + (print-rows-prettily nil) + (print-row-reasons nil) + (print-row-answers nil) + (print-row-constraints nil) + (print-row-partitions nil)) + (print-row row))) + +(defun print-row-length-limit1 (row) + (let ((n1 (print-rows-shortened?))) + (and n1 + (let* ((reason (row-reason row)) + (n2 (and (consp reason) + (eq 'resolve (first reason)) + (row-p (third reason)) + (clause-p (row-wff (third reason))) + (wff-length (row-wff (third reason)))))) + (if (numberp n1) + (if n2 (min n1 n2) n1) + n2))))) + +(defun print-row (row &key (string "Row ") format ancestry reverse) + (setf row (row row 'warn)) + (cond + ((null row) + ) + (ancestry + (print-rows + :rowset (let ((rowset (make-rowset))) (rowset-insert row rowset) rowset) + :format format + :ancestry ancestry + :reverse reverse)) + (t + (ecase format + ((nil) + (with-standard-io-syntax2 + (princ "(") + (princ string) + (prin1 (row-name-or-number row)) + (cond + ((print-rows-prettily?) + (terpri) + (princ " ")) + (t + (princ " "))) + (let-options ((print-row-length-limit (print-row-length-limit1 row))) + (print-row-term + (cond + ((not (print-row-goals?)) + (prog-> + (map-atoms-in-wff-and-compose-result (row-wff row) ->* atom polarity) + (declare (ignore polarity)) + (dereference + atom nil + :if-constant (if (proposition-magic-goal-p atom) true atom) + :if-compound (if (relation-magic-goal-p (head atom)) true atom)))) + (t + (row-wff row))))) + (when (print-row-reasons?) + (cond + ((print-rows-prettily?) + (terpri) + (princ " ")) + (t + (format t "~70T"))) + (print-row-reason row)) + (when (print-row-constraints?) + (dolist (x (row-constraints row)) + (unless (eq true (cdr x)) + (terpri) + (princ " ") + (princ (string-capitalize (car x))) + (princ "-Constraint ") + (print-row-term (negate (cdr x)))))) + (when (print-row-answers?) + (let ((answer (row-answer row))) + (unless (eq false answer) + (terpri) + (princ " Answer ") + (print-row-term answer)))) + (when (and (use-partitions?) (print-row-partitions?)) + (terpri) + (princ " Partitions ") + (prin1 (mapcar #'car (row-context row)))) + (princ ")"))) + (:tptp + (print-row-in-tptp-format row))))) + row) + +(defvar *propositional-abstraction-term-to-lisp* nil) + +(defun term-to-lisp (term &optional subst) + "Return a Lisp data structure for the given term." + ;; returns (f a b c) for SNARK term f(a,b,c) + ;; returns (list a b c) for SNARK term [a,b,c] + ;; use variable-p, variable-number, variable-sort + ;; sort information is invalid after SNARK is reinitialized + (labels + ((term-to-lisp (term) + (dereference + term subst + :if-constant (let ((name (constant-name term))) + (cond + ((not (can-be-constant-name name)) + (list '$$quote name)) + (t + name))) + :if-variable (dolist (fun (if (use-to-lisp-code?) (mklist (variable-to-lisp-code?)) nil) term) + (let ((v (funcall fun term))) + (unless (eq none v) + (return v)))) + :if-compound (let ((head (head term)) + (args (args term))) + (cond + ((and *propositional-abstraction-term-to-lisp* + (not (function-logical-symbol-p head))) + (list (function-name head) (function-arity head))) + (t + (dolist (fun (if (use-to-lisp-code?) (function-to-lisp-code head) nil) (cons (function-name head) (args-to-lisp args))) + (let ((v (funcall fun head args subst))) + (unless (eq none v) + (return v))))))))) + (args-to-lisp (args) + (lcons (term-to-lisp (first args)) (args-to-lisp (rest args)) args))) + (term-to-lisp term))) + +(defun cons-term-to-lisp (head args subst) + ;; converts + ;; (a) to ($$list a) + ;; (a b) to ($$list a b) + ;; (a . b) to ($$cons a b) + ;; (a b . c) to ($$list* a b c) + ;; when used as to-lisp-code for cons + (cl:assert (eq *cons* head)) + (let* ((y (term-to-lisp (second args) subst)) + (x (term-to-lisp (first args) subst))) + (cond + ((null y) + (list (current-function-name '$$list :any) x)) + ((atom y) + (list (function-name head) x y)) + (t + (let ((v (first y)) list*) + (cond + ((eq v (current-function-name '$$list :any)) + (list* v x (rest y))) + ((or (eq v (setf list* (current-function-name '$$list* :any))) + (eq v (function-name head))) + (list* list* x (rest y))) + (t + (list (function-name head) x y)))))))) + +(defun quant-compound-to-lisp (head args subst) + (list (function-name head) + (mapcar (lambda (var-spec) + (if (variable-p var-spec) + (term-to-lisp var-spec subst) + (mapcar #'(lambda (x) (term-to-lisp x subst)) var-spec))) + (first args)) + (term-to-lisp (second args) subst))) + +(defun row-sorts (row &optional sorts) + (prog-> + (map-terms-in-wff (row-wff row) ->* term polarity) + (declare (ignore polarity)) + (let ((sort (term-sort term))) + (unless (top-sort? sort) + (pushnew (term-sort term) sorts :test #'same-sort?)))) + sorts) + +(defun derivation-sorts (row) + (let ((sorts nil)) + (dolist (row (row-ancestry row)) + (setf sorts (row-sorts row sorts))) + sorts)) + +(defun subsort-forms (sorts) + (let ((result nil)) + (dotails (l sorts) + (let ((sort1 (first l))) + (dolist (sort2 (rest l)) + (cond + ((subsort? sort1 sort2) + (push `(subsort ,(sort-name sort1) ,(sort-name sort2)) result)) + ((subsort? sort2 sort1) + (push `(subsort ,(sort-name sort2) ,(sort-name sort1)) result)))))) + result)) + +(defun derivation-subsort-forms (row) + (subsort-forms (derivation-sorts row))) + +;;; output.lisp EOF diff --git a/src/patches.lisp b/src/patches.lisp new file mode 100644 index 0000000..b15efff --- /dev/null +++ b/src/patches.lisp @@ -0,0 +1,26 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: patches.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2002. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun make-instance-graph (&rest args) + (declare (ignore args)) + nil) + +;;; patches.lisp EOF diff --git a/src/path-index.lisp b/src/path-index.lisp new file mode 100644 index 0000000..0794c49 --- /dev/null +++ b/src/path-index.lisp @@ -0,0 +1,870 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: path-index.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim (special *terpri-indent*)) + +(defvar *path-index*) + +(defstruct (path-index + (:constructor make-path-index0 (entry-constructor entries)) + (:copier nil)) + (entry-constructor nil :read-only t) ;term->entry function for new entry insertion + (node-counter (make-counter 1) :read-only t) + (entry-counter (make-counter) :read-only t) + (top-node (make-path-index-internal-node1 :mark nil) :read-only t) + (entries nil :read-only t)) ;term->entry hash-table for entry lookup + +(defstruct (path-index-node + (:copier nil)) + (parent-node nil :read-only t) + (mark (increment-counter (path-index-node-counter *path-index*)))) + +(defstruct (path-index-internal-node1 + (:include path-index-node) + (:copier nil)) + (variable-child-node nil) ;nil or internal-node + (constant-indexed-child-nodes (make-sparse-vector)) ;constant# -> leaf-node sparse-vector + (function-indexed-child-nodes (make-sparse-vector))) ;function# -> internal-node sparse-vector + +(defstruct (path-index-internal-node2 + (:include path-index-node) + (:copier nil)) + (integer-indexed-child-nodes nil :read-only t) ;vector of internal-nodes (or nil) indexed by argument position + query) ;node in integer-indexed-child-nodes to use to generate all instances + +(defstruct (path-index-leaf-node + (:include path-index-node) + (:copier nil)) + (entries (make-sparse-vector) :read-only t)) + +(defstruct (path-index-entry + (:include index-entry) + (:constructor make-path-index-entry (term)) + (:copier nil)) + in-nodes ;vector of (possible query) nodes that contain entry + in-nodes-last ;last index into in-nodes + (mark nil)) + +(defun make-path-index (&key (entry-constructor #'make-path-index-entry)) + (setf *path-index* (make-path-index0 entry-constructor (make-sparse-vector)))) + +(defmacro path-index-internal-node1-function-indexed-child-node (head node1) + `(sparef (path-index-internal-node1-function-indexed-child-nodes ,node1) (function-number ,head))) + +(defmacro path-index-internal-node1-constant-indexed-child-node (const node1) + `(sparef (path-index-internal-node1-constant-indexed-child-nodes ,node1) (constant-number ,const))) + +(defmacro add-path-index-internal-node1-function-indexed-child-node (head node1 node) + `(setf (path-index-internal-node1-function-indexed-child-node ,head ,node1) ,node)) + +(defmacro add-path-index-internal-node1-constant-indexed-child-node (const node1 node) + `(setf (path-index-internal-node1-constant-indexed-child-node ,const ,node1) ,node)) + +(defun path-index-entry (term) + ;; return path-index-entry for term + ;; create one if there isn't one + (let ((term# (funcall *standard-eql-numbering* :lookup term))) + (or (sparef (path-index-entries *path-index*) term#) + (path-index-insert term)))) + +(defun the-path-index-entry (term) + ;; return path-index-entry for term + ;; error if there isn't one + (let ((term# (funcall *standard-eql-numbering* :lookup term))) + (or (sparef (path-index-entries *path-index*) term#) + (progn + (cl:assert (eql term (hash-term term))) + (error "No path-index-entry for term."))))) + +(defun some-path-index-entry (term) + ;; return path-index-entry for term + ;; return nil if there isn't one + (let ((term# (funcall *standard-eql-numbering* :lookup term))) + (or (sparef (path-index-entries *path-index*) term#) + (progn + #+ignore (cl:assert (eql term (hash-term term))) + nil)))) + +(defun path-index-delete (term) + (let* ((path-index *path-index*) + (term# (funcall *standard-eql-numbering* :lookup term)) + (entry (or (sparef (path-index-entries path-index) term#) + (progn + #+ignore (cl:assert (eql term (hash-term term))) + nil)))) + (when entry + (every (lambda (node) + (when (path-index-leaf-node-p node) + (let ((entries (path-index-leaf-node-entries node))) + (setf (sparef entries (tme-number entry)) nil) + (when (= 0 (sparse-vector-count entries)) + (path-index-delete-leaf-node node)))) + t) + (path-index-entry-in-nodes entry)) + (setf (sparef (path-index-entries path-index) term#) nil) + (decrement-counter (path-index-entry-counter path-index))) + entry)) + +(defun path-index-delete-leaf-node (node) + (let ((path-index *path-index*) + (parent (path-index-node-parent-node node))) + (cond + ((eq node (path-index-internal-node1-variable-child-node parent)) + (setf (path-index-internal-node1-variable-child-node parent) nil)) + (t + (let ((table (path-index-internal-node1-constant-indexed-child-nodes parent))) + (map-sparse-vector-with-indexes + (lambda (value key) + (when (eq node value) + (setf (sparef table key) nil))) + table)))) + (decrement-counter (path-index-node-counter path-index)))) + +(defvar *path-index-insert-entry*) +(defvar *path-index-insert-entry-leaf-nodes*) +(defvar *path-index-insert-entry-internal-nodes*) + +(defun path-index-insert (term) + #+ignore (cl:assert (eql term (hash-term term))) + (let* ((path-index *path-index*) + (entry (funcall (path-index-entry-constructor path-index) term))) + (increment-counter (path-index-entry-counter path-index)) + (let ((term# (funcall *standard-eql-numbering* :lookup term))) + (setf (sparef (path-index-entries path-index) term#) entry)) + (let ((*path-index-insert-entry* entry) + (*path-index-insert-entry-leaf-nodes* nil) + (*path-index-insert-entry-internal-nodes* nil)) + ;; FOR EMBEDDINGS + (when (compound-p term) + (let ((head (head term))) + (when (function-associative head) + (setf term (make-compound* head (make-variable) (args term)))))) + (path-index-insert* term (path-index-top-node path-index)) + (let* ((l (nconc *path-index-insert-entry-internal-nodes* *path-index-insert-entry-leaf-nodes*)) + (n (length l))) + (setf (path-index-entry-in-nodes entry) (make-array n :initial-contents l)) + (setf (path-index-entry-in-nodes-last entry) (- n 1)))) + entry)) + +(defun path-index-insert* (term node1 &optional head-if-associative) + ;; find or create paths for term so that term can be inserted in path-index + (dereference + term nil + :if-variable (let ((leaf (path-index-internal-node1-variable-child-node node1))) + (unless leaf + (setf leaf (make-path-index-leaf-node :parent-node node1)) + (setf (path-index-internal-node1-variable-child-node node1) leaf)) + (path-index-insert-at-leaf leaf)) + :if-constant (let ((leaf (path-index-internal-node1-constant-indexed-child-node term node1))) + (unless leaf + (setf leaf (make-path-index-leaf-node :parent-node node1)) + (add-path-index-internal-node1-constant-indexed-child-node term node1 leaf)) + (path-index-insert-at-leaf leaf)) + :if-compound (let ((args (args term))) + (if args + (path-index-insert-appl (head term) args node1 head-if-associative) + (path-index-insert* (function-name (head term)) node1 head-if-associative))))) ;handle 0-ary as constant + +(defun path-index-insert-appl (head args node1 head-if-associative) + (cond + ((eq head-if-associative head) + (dolist (arg args) + (path-index-insert* arg node1 head-if-associative))) + ((no-integer-indexed-child-nodes-p head) + (let ((node1a (path-index-internal-node1-function-indexed-child-node head node1))) + (unless node1a + (setf node1a (make-path-index-internal-node1 :parent-node node1)) + (add-path-index-internal-node1-function-indexed-child-node head node1 node1a)) + (let ((l *path-index-insert-entry-internal-nodes*)) + (unless (member node1a l) + (setf *path-index-insert-entry-internal-nodes* (cons node1a l)))) + (ecase (function-index-type head) + (:commute ;no integer indexed child nodes => arity=2 + (path-index-insert* (first args) node1a) + (path-index-insert* (second args) node1a)) + (:jepd + (path-index-insert* (first args) node1a) + (path-index-insert* (second args) node1a)) + (:hash-but-dont-index + (path-index-insert* (function-name head) node1 head-if-associative)) ;as if there were no arguments + ((nil) + (case (function-arity head) + (otherwise + (let ((head-if-associative (and (function-associative head) head))) + (dolist (arg args) + (path-index-insert* arg node1a head-if-associative))))))))) + (t + (ecase (function-index-type head) + ((nil) + (path-index-insert-list head args node1)) + (:commute + (path-index-insert-list head args node1 #'c-index)))))) + +(defun path-index-insert-list (head args node1 &optional indexfun) + (loop with node2 = (path-index-insert-list1 head (length args) node1 indexfun) + with iinodes = (path-index-internal-node2-integer-indexed-child-nodes node2) + for arg in args + as i from 0 + do (path-index-insert* arg (svref iinodes (if indexfun (funcall indexfun head i) i))))) + +(defun path-index-insert-list1 (head arity node1 indexfun) + (let ((node2 (path-index-internal-node1-function-indexed-child-node head node1))) + (unless node2 + (let ((iinodes (make-array arity :initial-element nil))) + (setf node2 (make-path-index-internal-node2 :parent-node node1 :integer-indexed-child-nodes iinodes)) + (dotimes (i arity) + (let ((i* (if indexfun (funcall indexfun head i) i))) + (unless (svref iinodes i*) + (setf (svref iinodes i*) (make-path-index-internal-node1 :parent-node node2))))) + (loop for i downfrom (- arity 1) + as v = (svref iinodes i) + do (when v + (setf (path-index-internal-node2-query node2) v) + (return)))) + (add-path-index-internal-node1-function-indexed-child-node head node1 node2)) + (let ((l *path-index-insert-entry-internal-nodes*) + (n (path-index-internal-node2-query node2))) + (unless (member n l) + (setf *path-index-insert-entry-internal-nodes* (cons n l)))) + node2)) + +(defun path-index-insert-at-leaf (leaf) + (let ((entry *path-index-insert-entry*) + (entries (path-index-leaf-node-entries leaf))) + (let ((num (tme-number entry))) + (unless (sparef entries num) + (push leaf *path-index-insert-entry-leaf-nodes*) + (setf (sparef entries num) entry))))) + +(defun no-integer-indexed-child-nodes-p (head) + (ecase (function-index-type head) + (:commute + (or (eql 2 (function-arity head)) (eq *=* head))) + ((:jepd :hash-but-dont-index) + t) + ((nil) + (let ((arity (function-arity head))) + (or (eql 1 arity) + (function-associative head) + (eq :any arity)))))) + +(defun c-index (head i) + (declare (ignore head)) + (if (eql 1 i) 0 i)) + +(defmacro path-index-variable-leaf (node1) + `(let ((v (path-index-internal-node1-variable-child-node ,node1))) + (and v + (neql 0 (sparse-vector-count (path-index-leaf-node-entries v))) + v))) + +(defmacro path-index-constant-leaf (node1 const) + `(let ((v (path-index-internal-node1-constant-indexed-child-node ,const ,node1))) + (and v + (neql 0 (sparse-vector-count (path-index-leaf-node-entries v))) + v))) + +(defun make-path-index-query (type term &optional subst) +;;(print type) (print-term term subst) + (let ((query + (ecase type + (:generalization + (make-path-index-query-g term subst (path-index-top-node *path-index*))) + (:instance + (make-path-index-query-i term subst (path-index-top-node *path-index*))) + (:unifiable + (make-path-index-query-u term subst (path-index-top-node *path-index*))) + (:variant + (make-path-index-query-v term subst (path-index-top-node *path-index*)))))) + #+ignore + (progn + (terpri-comment-indent) + (print-term term subst) + (format t " ~(~A~) query:" type) + (print-path-index-query query) + (terpri)) + query)) + +(defun make-path-index-query-v (term subst node1 &optional head-if-associative) + (dereference + term subst + :if-variable (path-index-variable-leaf node1) + :if-constant (path-index-constant-leaf node1 term) + :if-compound (let ((head (head term)) + (args (args term))) + (if (and args (not (eq :hash-but-dont-index (function-index-type head)))) + (make-path-index-query-appl #'make-path-index-query-v head args subst node1 head-if-associative) + (make-path-index-query-v (function-name head) subst node1 head-if-associative))))) ;handle 0-ary as constant + +(defun make-path-index-query-i (term subst node1 &optional head-if-associative) + (dereference + term subst + :if-variable t + :if-constant (path-index-constant-leaf node1 term) + :if-compound (let ((head (head term)) + (args (args term))) + (if (and args (not (eq :hash-but-dont-index (function-index-type head)))) + (make-path-index-query-appl #'make-path-index-query-i head args subst node1 head-if-associative) + (make-path-index-query-i (function-name head) subst node1 head-if-associative))))) ;handle 0-ary as constant + +(defun make-path-index-query-g (term subst node1 &optional head-if-associative) + (dereference + term subst + :if-variable (path-index-variable-leaf node1) + :if-constant (make-uniond-query2 + (path-index-constant-leaf node1 term) + (path-index-variable-leaf node1)) + :if-compound (let ((head (head term)) + (args (args term))) + (if (and args (not (eq :hash-but-dont-index (function-index-type head)))) + (make-uniond-query2 + (make-path-index-query-appl #'make-path-index-query-g head args subst node1 head-if-associative) + (path-index-variable-leaf node1)) + (make-path-index-query-g (function-name head) subst node1 head-if-associative))))) ;handle 0-ary as constant + +(defun make-path-index-query-u (term subst node1 &optional head-if-associative) + (dereference + term subst + :if-variable t + :if-constant (make-uniond-query2 + (path-index-constant-leaf node1 term) + (path-index-variable-leaf node1)) + :if-compound (let ((head (head term)) + (args (args term))) + (if (and args (not (eq :hash-but-dont-index (function-index-type head)))) + (make-uniond-query2 + (make-path-index-query-appl #'make-path-index-query-u head args subst node1 head-if-associative) + (path-index-variable-leaf node1)) + (make-path-index-query-u (function-name head) subst node1 head-if-associative))))) ;handle 0-ary as constant + +(defun make-path-index-query-appl (make-query head args subst node1 head-if-associative) + (cond + ((eq head-if-associative head) + (let ((v (let ((qq nil) qq-last) + (dolist (arg args) + (let ((q (funcall make-query arg subst node1 head-if-associative))) + (cond + ((null q) + (return-from make-path-index-query-appl nil)) + ((neq t q) + (collect q qq))))) + (make-boolean-query 'intersection qq)))) + (if (eq t v) node1 v))) + ((no-integer-indexed-child-nodes-p head) + (let ((node1a (path-index-internal-node1-function-indexed-child-node head node1))) + (and node1a + (let ((v (let ((qq nil) qq-last) + (ecase (function-index-type head) + ((nil :commute) + (case (function-arity head) + (otherwise + (let ((head-if-associative (and (function-associative head) head))) + (dolist (arg args) + (let ((q (funcall make-query arg subst node1a head-if-associative))) + (cond + ((null q) + (return-from make-path-index-query-appl nil)) + ((neq t q) + (collect q qq))))))))) + (:jepd + (dolist (arg (firstn args 2)) + (let ((q (funcall make-query arg subst node1a))) + (cond + ((null q) + (return-from make-path-index-query-appl nil)) + ((neq t q) + (collect q qq))))))) + (make-boolean-query 'intersection qq)))) + (if (eq t v) node1a v))))) + (t + (ecase (function-index-type head) + ((nil) + (make-path-index-query-list make-query head args subst node1)) + (:commute + (make-path-index-query-list make-query head args subst node1 #'c-index)))))) + +(defun make-path-index-query-list (make-query head args subst node1 &optional indexfun) + (let ((node2 (path-index-internal-node1-function-indexed-child-node head node1))) + (and node2 + (let ((v (make-boolean-query + 'intersection + (loop with iinodes = (path-index-internal-node2-integer-indexed-child-nodes node2) + for arg in args + as i from 0 + as q = (funcall make-query arg subst (svref iinodes (if indexfun (funcall indexfun head i) i))) + when (null q) + do (return-from make-path-index-query-list nil) + unless (eq t q) + collect q)))) + (if (eq t v) (path-index-internal-node2-query node2) v))))) + +(defmacro map-leaf0 (leaf x &optional y) + `(prog-> + (map-sparse-vector (path-index-leaf-node-entries ,leaf) ->* entry) + (cond + ((eq query-id (path-index-entry-mark entry)) + ) + ,@(when y (list y)) + ((or (null queries) (path-index-entry-satisfies-query-p entry (first queries) (rest queries))) + ,x + (setf (path-index-entry-mark entry) query-id))))) + +(defmacro map-leaf (leaf) + `(if (null test) + (map-leaf0 ,leaf (funcall cc entry)) + (map-leaf0 ,leaf (funcall cc entry test-value) + ((null (setf test-value (funcall test entry))) + (setf (path-index-entry-mark entry) query-id))))) + +;;; test is a predicate applied to a path-index-entry before path-index +;;; query evaluation is complete to quickly determine whether the +;;; path-index-entry should be retrieved if it satisfies the query +;;; the result of test is also passed as second argument to cc + +(defun map-path-index-entries (cc type term &optional subst test query-id) + (let ((query (make-path-index-query type term subst))) + (when query + (map-path-index-by-query cc query test query-id)))) + +(defun map-path-index-by-query (cc query &optional test query-id) + (let ((optimized nil)) + (unless query-id + (setf query-id (cons 'query-id nil))) ;query-id unique, eq testable + (cond + ((test-option14?) + (when (path-index-sparse-vector-expression-p query) + (setf query (fix-path-index-sparse-vector-expression query)) + (setf query (if (trace-optimize-sparse-vector-expression?) + (traced-optimize-sparse-vector-expression query) + (optimize-sparse-vector-expression query))) + (let ((n (test-option21?))) + (when (and n (consp query) (eq 'intersection (first query))) + (setf query (firstn query (+ n 1))))) ;keep only first n terms of intersection + (if test + (let (test-value) + (flet ((filter (entry) (setf test-value (funcall test entry)))) + (declare (dynamic-extent #'filter)) + (prog-> + (map-sparse-vector-expression query :reverse t :filter #'filter ->* entry) + (unless (eq query-id (path-index-entry-mark entry)) + (funcall cc entry test-value) + (setf (path-index-entry-mark entry) query-id))))) + (prog-> + (map-sparse-vector-expression query :reverse t ->* entry) + (unless (eq query-id (path-index-entry-mark entry)) + (funcall cc entry) + (setf (path-index-entry-mark entry) query-id)))) + (return-from map-path-index-by-query)))) + (let (test-value) + (labels + ((map-path-index-by-query* (query queries) + (loop + (cond + ((not (consp query)) + (cond + ((path-index-leaf-node-p query) + (map-leaf query) + (return)) + (t + (when (path-index-internal-node2-p query) + (setf query (path-index-internal-node2-query query))) + (map-sparse-vector + (lambda (v) (map-leaf v)) + (path-index-internal-node1-constant-indexed-child-nodes query) + :reverse t) + (let ((var-leaf (path-index-internal-node1-variable-child-node query))) + (when var-leaf + (map-leaf var-leaf))) + (let ((q nil)) + (map-sparse-vector + (lambda (v) + (when q + (map-path-index-by-query* q queries)) + (setf q v)) + (path-index-internal-node1-function-indexed-child-nodes query) + :reverse t) + (if q + (setf query q) + (return)))))) + ((eq 'intersection (first query)) + (dolist (q (prog1 (setf query (rest query)) + (setf query (if optimized (first query) (select-query query))))) + (unless (eq q query) + (push q queries)))) + (t +;; (cl:assert (member (first query) '(union uniond))) + (do* ((l (rest query) l1) + (l1 (rest l) (rest l1))) + ((null l1) + (setf query (first l))) + (map-path-index-by-query* (first l) queries))))))) + #+ignore (cl:assert query) + (when (eq t query) + (setf query (path-index-top-node *path-index*))) + (map-path-index-by-query* query nil))))) + +(defmacro mark-path-index-entry-in-nodes (entry) + (cl:assert (symbolp entry)) + (let ((v (gensym)) (i (gensym))) + `(let ((,v (path-index-entry-in-nodes ,entry)) + (,i (path-index-entry-in-nodes-last ,entry))) + (declare (type vector ,v) (type fixnum ,i)) + (loop + (setf (path-index-node-mark (svref ,v ,i)) ,entry) + (if (eql 0 ,i) + (return) + (decf ,i)))))) + +(defmacro member-path-index-entry-in-nodes (query entry) + (cl:assert (symbolp query)) + (cl:assert (symbolp entry)) + (let ((v (gensym)) (i (gensym))) + `(let ((,v (path-index-entry-in-nodes ,entry)) + (,i (path-index-entry-in-nodes-last ,entry))) + (declare (type vector ,v) (type fixnum ,i)) + (loop + (when (eq (svref ,v ,i) ,query) + (return t)) + (if (eql 0 ,i) + (return nil) + (decf ,i)))))) + +(defun path-index-entry-satisfies-query-p (entry query &optional more-queries) + (cond + (more-queries + (mark-path-index-entry-in-nodes entry) + (and (path-index-entry-satisfies-query-p* entry query) + (path-index-entry-satisfies-query-p* entry (first more-queries)) + (dolist (query (rest more-queries) t) + (unless (path-index-entry-satisfies-query-p* entry query) + (return nil))))) + ((consp query) + (mark-path-index-entry-in-nodes entry) + (path-index-entry-satisfies-query-p* entry query)) + (t + (member-path-index-entry-in-nodes query entry)))) + +(defun path-index-entry-satisfies-query-p* (entry query) + (loop + (cond + ((not (consp query)) ;query is a node + (return-from path-index-entry-satisfies-query-p* + (eq (path-index-node-mark query) entry))) + ((eq 'intersection (first query)) ;intersection + (do* ((l (rest query) l1) + (l1 (rest l) (rest l1))) + ((null l1) + (setf query (first l))) + (unless (path-index-entry-satisfies-query-p* entry (first l)) + (return-from path-index-entry-satisfies-query-p* + nil)))) + (t +;; (cl:assert (member (first query) '(union uniond))) + (do* ((l (rest query) l1) + (l1 (rest l) (rest l1))) + ((null l1) + (setf query (first l))) + (when (path-index-entry-satisfies-query-p* entry (first l)) + (return-from path-index-entry-satisfies-query-p* + t))))))) + +(defun retrieval-size (query bound) + (cond + ((not (consp query)) + (cond + ((path-index-leaf-node-p query) + (sparse-vector-count (path-index-leaf-node-entries query))) + (t + (when (path-index-internal-node2-p query) + (setf query (path-index-internal-node2-query query))) + (let ((total-size 0)) + (let ((var-leaf (path-index-internal-node1-variable-child-node query))) + (when var-leaf + (incf total-size (sparse-vector-count (path-index-leaf-node-entries var-leaf))) + (when (>= total-size bound) + (return-from retrieval-size bound)))) + (map-sparse-vector + (lambda (v) + (incf total-size (sparse-vector-count (path-index-leaf-node-entries v))) + (when (>= total-size bound) + (return-from retrieval-size bound))) + (path-index-internal-node1-constant-indexed-child-nodes query)) + (map-sparse-vector + (lambda (v) + (incf total-size (retrieval-size v (- bound total-size))) + (when (>= total-size bound) + (return-from retrieval-size bound))) + (path-index-internal-node1-function-indexed-child-nodes query)) + total-size)))) + ((eq 'intersection (first query)) + (let* ((args (rest query)) + (min-size (retrieval-size (first args) bound))) + (dolist (arg (rest args)) + (let ((n (retrieval-size arg min-size))) + (when (< n min-size) + (when (<= (setf min-size n) 1) + (return))))) + min-size)) + (t +;; (cl:assert (member (first query) '(union uniond))) + (let ((total-size 0)) + (dolist (arg (rest query)) + (incf total-size (retrieval-size arg (- bound total-size))) + (when (>= total-size bound) + (return-from retrieval-size bound))) + total-size)))) + +(defun select-query (args) + (let* ((best (first args)) + (min-size (retrieval-size best 1000000))) + (dolist (arg (rest args)) + (let ((n (retrieval-size arg min-size))) + (when (< n min-size) + (setf best arg) + (when (<= (setf min-size n) 1) + (return))))) + best)) + +(defun make-boolean-query* (fn l) + (let ((a (first l)) + (d (rest l))) + (if (null d) + (if (and (consp a) (eq fn (first a))) + (rest a) + l) + (let ((d* (make-boolean-query* fn d))) + (cond + ((and (consp a) (eq fn (first a))) + (nodup-append (rest a) d*)) + ((equal a (first d*)) + d*) + ((member a (rest d*) :test #'equal) + (cons a (cons (first d*) (remove a (rest d*) :test #'equal)))) + ((eq d d*) + l) + (t + (cons a d*))))))) + +(defun make-boolean-query (fn l) + (cond + ((null l) + (ecase fn + (intersection + t) + ((union uniond) + nil))) + (t + (let ((l* (make-boolean-query* fn l))) + (cond + ((null (rest l*)) + (first l*)) + (t + (cons fn l*))))))) + +(defun make-uniond-query2 (q1 q2) + (cond + ((null q1) + q2) + ((null q2) + q1) + (t + (make-boolean-query 'uniond (list q1 q2))))) + +(defun nodup-append (l1 l2 &optional (l2* nil)) + ;; append l1 and l2 eliminating items in l2 that appear in l1 + (if (null l2) + (if (null l2*) + l1 + (append l1 (nreverse l2*))) + (nodup-append l1 + (rest l2) + (if (member (first l2) l1 :test #'equal) + l2* + (cons (first l2) l2*))))) + +(defun path-index-sparse-vector-expression-p (x) + (cond + ((atom x) + (when (path-index-leaf-node-p x) + (setf x (path-index-leaf-node-entries x))) + (and (sparse-vector-p x) (null (sparse-vector-default-value x)))) + (t + (let ((fn (first x)) + (args (rest x))) + (and (or (eq 'intersection fn) (eq 'union fn) (eq 'uniond fn)) + args + (dolist (arg args t) + (unless (path-index-sparse-vector-expression-p arg) + (return nil)))))))) + +(defun fix-path-index-sparse-vector-expression (x) + (cond + ((atom x) + (if (path-index-leaf-node-p x) + (path-index-leaf-node-entries x) + x)) + (t + (dotails (l (rest x)) + (setf (first l) (fix-path-index-sparse-vector-expression (first l)))) + x))) + +(defun sparse-vector-expression-description (expr) + (cond + ((atom expr) + (sparse-vector-count expr)) + (t + (cons (ecase (first expr) (intersection '&) (union 'u) (uniond 'v)) + (mapcar #'sparse-vector-expression-description (rest expr)))))) + +(defun sz (x) + (if (atom x) 0 (+ (sz (car x)) (sz (cdr x)) 1))) + +(defun traced-optimize-sparse-vector-expression (expr) + (let* ((desc (sparse-vector-expression-description expr)) + (expr* (optimize-sparse-vector-expression expr)) + (desc* (sparse-vector-expression-description expr*))) + (format t "~%~A" desc*) + (unless (eql (sz desc) (sz desc*)) + (format t " optimized from ~A" desc)) + expr*)) + +(defun print-path-index (&key terms nodes) + (let ((index *path-index*)) + (mvlet (((:values current peak added deleted) (counter-values (path-index-entry-counter index)))) + (format t "~%; Path-index has ~:D entr~:@P (~:D at peak, ~:D added, ~:D deleted)." current peak added deleted)) + (mvlet (((:values current peak added deleted) (counter-values (path-index-node-counter index)))) + (format t "~%; Path-index has ~:D node~:P (~:D at peak, ~:D added, ~:D deleted)." current peak added deleted)) + (when (or nodes terms) + (print-index* (path-index-top-node index) nil terms)))) + +(defmethod print-index-leaf-node ((node path-index-leaf-node) revpath print-terms) + (with-standard-io-syntax2 + (prog-> + (format t "~%; Path ") + (print-revpath revpath) + (path-index-leaf-node-entries node -> entries) + (format t " has ~:D entr~:@P." (sparse-vector-count entries)) + (when print-terms + (map-sparse-vector entries ->* entry) + (format t "~%; ") + (print-term (index-entry-term entry)))))) + +(defmethod map-index-leaf-nodes (cc (node path-index-internal-node1) revpath) + (let ((v (path-index-internal-node1-variable-child-node node))) + (when v + (map-index-leaf-nodes cc v (cons "variable" revpath)))) + (map-sparse-vector-with-indexes + (lambda (v k) + (map-index-leaf-nodes cc v (cons (symbol-numbered k) revpath))) + (path-index-internal-node1-constant-indexed-child-nodes node) + :reverse t) + (map-sparse-vector-with-indexes + (lambda (v k) + (map-index-leaf-nodes cc v (cons (symbol-numbered k) revpath))) + (path-index-internal-node1-function-indexed-child-nodes node) + :reverse t)) + +(defmethod map-index-leaf-nodes (cc (node path-index-internal-node2) revpath) + (let ((iinodes (path-index-internal-node2-integer-indexed-child-nodes node))) + (dotimes (i (array-dimension iinodes 0)) + (let ((v (svref iinodes i))) + (when v + (map-index-leaf-nodes cc v (cons i revpath))))))) + +(defmethod map-index-leaf-nodes (cc (node path-index-leaf-node) revpath) + (funcall cc node revpath)) + +(defun print-revpath (revpath) + (princ "[") + (dolist (x (reverse (rest revpath))) + (cond + ((function-symbol-p x) + (prin1 x)) + (t + (cl:assert (integerp x)) + (cond + ((< x 0) + (princ "list") + (princ (- x))) + (t + (princ "arg") + (princ (+ x 1)))))) + (princ ",")) + (prin1 (first revpath) *standard-output*) + (princ "]")) + +(defun path-index-key-for-value (value table) + (map-sparse-vector-with-indexes + (lambda (v k) + (when (eq value v) + (return-from path-index-key-for-value (symbol-numbered k)))) + table)) + +(defun path-index-node-revpath (node) + (let ((parent-node (path-index-node-parent-node node))) + (cond + ((path-index-internal-node1-p parent-node) + (cons (or (if (eq node (path-index-internal-node1-variable-child-node parent-node)) "variable" nil) + (path-index-key-for-value node (path-index-internal-node1-function-indexed-child-nodes parent-node)) + (path-index-key-for-value node (path-index-internal-node1-constant-indexed-child-nodes parent-node))) + (path-index-node-revpath parent-node))) + ((path-index-internal-node2-p parent-node) + (cons (position node (path-index-internal-node2-integer-indexed-child-nodes parent-node)) + (path-index-node-revpath parent-node))) + (t + nil)))) + +(defun print-path-index-query (query &key terms) + (cond + ((or (null query) (eq t query)) + (terpri-comment-indent) + (princ query)) + ((and (consp query) (eq 'intersection (first query))) + (terpri-comment-indent) + (princ "(intersection") + (let ((*terpri-indent* (+ *terpri-indent* 3))) + (mapc (lambda (q) (print-path-index-query q :terms terms)) (rest query))) + (princ ")")) + ((and (consp query) (eq 'union (first query))) + (terpri-comment-indent) + (princ "(union") + (let ((*terpri-indent* (+ *terpri-indent* 3))) + (mapc (lambda (q) (print-path-index-query q :terms terms)) (rest query))) + (princ ")")) + ((and (consp query) (eq 'uniond (first query))) + (terpri-comment-indent) + (princ "(uniond") + (let ((*terpri-indent* (+ *terpri-indent* 3))) + (mapc (lambda (q) (print-path-index-query q :terms terms)) (rest query))) + (princ ")")) + ((path-index-leaf-node-p query) + (print-index* query (path-index-node-revpath query) terms)) + (t + (terpri-comment-indent) + (let ((revpath (path-index-node-revpath query))) + (princ "(all-entries ") + (print-revpath (cons "..." revpath)) +;; (let ((*terpri-indent* (+ *terpri-indent* 3))) +;; (print-path-index* query revpath terms)) + (princ ")")))) + nil) + +;;; path-index.lisp EOF diff --git a/src/pattern-match.lisp b/src/pattern-match.lisp new file mode 100644 index 0000000..efeb6fb --- /dev/null +++ b/src/pattern-match.lisp @@ -0,0 +1,45 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*- +;;; File: pattern-match.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-lisp) + +(defun pattern-match (pat expr &optional alist) + ;; matches pat to expr creating bindings in alist for ?vars in pat + ;; sublis can be used to make instances of other expressions that contain ?vars + ;; (nil) is used as value for successful match with no bindings + (cond + ((consp pat) + (and (consp expr) + (setf alist (pattern-match (car pat) (car expr) alist)) + (pattern-match (cdr pat) (cdr expr) alist))) + ((and pat (symbolp pat) (eql #\? (char (symbol-name pat) 0))) + (cond + ((null (first alist)) + (acons pat expr nil)) + (t + (let ((v (assoc pat alist))) + (if v + (if (equal (cdr v) expr) alist nil) + (acons pat expr alist)))))) + ((eql pat expr) + (or alist '(nil))) + (t + nil))) + +;;; pattern-match.lisp EOF diff --git a/src/posets.lisp b/src/posets.lisp new file mode 100644 index 0000000..42dc63a --- /dev/null +++ b/src/posets.lisp @@ -0,0 +1,69 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: posets.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2005. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; notes: +;;; integers are used as elements so that sparse-arrays can be used + +(defun make-poset (&rest args) + (declare (ignore args)) + (make-sparse-matrix :boolean t)) + +(definline poset-greaterp (poset x y) + (and (not (eql x y)) + (sparef poset x y))) + +(definline poset-lessp (poset x y) + (and (not (eql x y)) + (sparef poset y x))) + +(defun poset-equivalent (poset x y) + (declare (ignorable poset)) + (or (eql x y) + (unimplemented))) + +(defun declare-poset-greaterp (poset x y) + (add-edge-transitively poset x y)) + +(defun declare-poset-lessp (poset x y) + (add-edge-transitively poset y x)) + +(defun poset-superiors (poset element) + (setf (sparse-matrix-column poset element) t)) + +(defun poset-inferiors (poset element) + (setf (sparse-matrix-row poset element) t)) + +(defun add-edge-transitively (graph vertex1 vertex2) + (let ((l1 (list vertex1)) + (l2 (list vertex2))) + (let ((col (sparse-matrix-column graph vertex1))) + (when col (map-sparse-vector (lambda (vertex) (push vertex l1)) col))) + (let ((row (sparse-matrix-row graph vertex2))) + (when row (map-sparse-vector (lambda (vertex) (push vertex l2)) row))) + (dolist (v1 l1) + (dolist (v2 l2) + (cond + ((eql v1 v2) + (error "Trying to define node ~A > node ~A in ordering relation." v1 v2)) + (t + (setf (sparef graph v1 v2) t))))))) + +;;; posets.lisp EOF diff --git a/src/progc.lisp b/src/progc.lisp new file mode 100644 index 0000000..d208187 --- /dev/null +++ b/src/progc.lisp @@ -0,0 +1,288 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*- +;;; File: progc.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-lisp) + +(defparameter *prog->-function-second-forms* + '(funcall apply map map-into)) + +(defparameter *prog->-special-forms* + '( +;; (pattern . forms) + + ((dolist list-form &rest l ->* var) + (dolist (var list-form . l) + (unnamed-prog-> . prog->-tail))) + ((dotails list-form &rest l ->* var) + (dotails (var list-form . l) + (unnamed-prog-> . prog->-tail))) + ((dopairs list-form &rest l ->* var1 var2) + (dopairs (var1 var2 list-form . l) + (unnamed-prog-> . prog->-tail))) + ((dotimes count-form &rest l ->* var) + (dotimes (var count-form . l) + (unnamed-prog-> . prog->-tail))) + ((identity form -> var) + (let ((var form)) + (unnamed-prog-> . prog->-tail))) + )) + +(defun prog->*-function-second-form-p (fn) + (member fn *prog->-function-second-forms*)) + +(defun prog->-special-form (fn) + (assoc fn *prog->-special-forms* :key #'first)) + +(defun prog->-special-form-pattern (fn) + (car (prog->-special-form fn))) + +(defun prog->-special-form-args (fn) + (rest (prog->-special-form-pattern fn))) + +(defun prog->-special-form-result (fn) + (cdr (prog->-special-form fn))) + +(defun prog->-special-form-match-error (form) + (error "~S doesn't match prog-> special form ~S." + form (prog->-special-form-pattern (first form)))) + +(defun prog->-no-variable-error (form) + (error "No variable to assign value to in (prog-> ... ~S ...)." + form)) + +(defun prog->-too-many-variables-error (form) + (error "More than one variable to assign value to in (prog-> ... ~S ...)." form)) + +(defun prog->-too-many->s-error (form) + (error "More than one -> in (prog-> ... ~S ...)." form)) + +(defun prog->-unrecognized->-atom (atom form) + (error "Unrecognized operation ~S in (prog-> ... ~S ...)." atom form)) + +(defun prog->-atom (x) + (and (symbolp x) + (<= 2 (length (string x))) + (string= x "->" :end1 2))) + +(defun prog->*-function-argument (forms args) + (cond + ((and (null (rest forms)) + (consp (first forms)) + (eq (caar forms) 'funcall) + (equal (cddar forms) args)) + (cadar forms)) + ((and (null (rest forms)) + (consp (first forms)) + (not (#-(or lucid (and mcl (not openmcl))) special-operator-p +;; #-(or allegro lucid) special-form-p +;; #+allegro cltl1:special-form-p + #+(and mcl (not openmcl)) special-form-p + #+lucid lisp:special-form-p + (caar forms))) + (not (macro-function (caar forms))) + (equal (cdar forms) args)) + `(function ,(caar forms))) + (t + `(function (lambda ,args ,@forms))))) + +(defun process-prog-> (forms) + (cond + ((null forms) + nil) + (t + (let ((form (first forms))) + (cond + ((not (consp form)) + (cons form (process-prog-> (rest forms)))) + (t + (let* ((args (rest form)) + (x (member-if #'prog->-atom args))) + (cond + ((null x) + (cons (case (first form) ;forms with explicit or implicit progn also get prog-> processing + ((progn) + (process-prog->-progn (rest form))) + ((block when unless let let* mvlet mvlet* catch) + (list* (first form) + (second form) + (process-prog-> (cddr form)))) + ((multiple-value-bind progv) + (list* (first form) + (second form) + (third form) + (process-prog-> (cdddr form)))) + ((cond) + (cons (first form) + (mapcar (lambda (x) + (cons (first x) + (process-prog-> (rest x)))) + (rest form)))) + ((case ecase ccase typecase etypecase ctypecase) + (list* (first form) + (second form) + (mapcar (lambda (x) + (cons (first x) + (process-prog-> (rest x)))) + (cddr form)))) + ((if) + (cl:assert (<= 3 (length form) 4)) + (list (first form) + (second form) + (process-prog->-progn (list (third form))) + (process-prog->-progn (list (fourth form))))) + (otherwise + form)) + (process-prog-> (rest forms)))) + ((prog->-special-form (first form)) + (do ((formals (prog->-special-form-args (first form)) (rest formals)) + (args args (rest args)) + (alist (acons 'prog->-tail (rest forms) nil))) + (nil) + (cond + ((and (endp formals) (endp args)) + (return (sublis alist (prog->-special-form-result (first form))))) + ((endp formals) + (prog->-special-form-match-error form)) + ((eq (first formals) '&rest) + (setf formals (rest formals)) + (cond + ((or (endp args) (prog->-atom (first args))) + (setf args (cons nil args)) + (setf alist (acons (first formals) nil alist))) + (t + (setf alist (acons (first formals) + (loop collect (first args) + until (or (endp (rest args)) (prog->-atom (second args))) + do (pop args)) + alist))))) + ((endp args) + (prog->-special-form-match-error form)) + ((prog->-atom (first formals)) + (unless (string= (string (first formals)) (string (first args))) + (prog->-special-form-match-error form))) + (t + (setf alist (acons (first formals) (first args) alist)))))) + ((member-if #'prog->-atom (rest x)) + (prog->-too-many->s-error form)) + (t + (let ((inputs (ldiff args x)) + (outputs (rest x))) + (cond + ((string= (string (first x)) "->*") + (let ((funarg (prog->*-function-argument (process-prog-> (rest forms)) outputs))) + (cond + ((and (consp funarg) + (eq 'function (first funarg)) + (consp (second funarg)) + (eq 'lambda (first (second funarg)))) + (let ((g (gensym))) + (list + `(flet ((,g ,@(rest (second funarg)))) + (declare (dynamic-extent (function ,g))) + ,@(prog->*-call form inputs `(function ,g)))))) + (t + (prog->*-call form inputs funarg))))) + ((null outputs) + (prog->-no-variable-error form)) + ((string= (string (first x)) "->") + (cond + ((null (rest outputs)) + (cond + ((and (consp (first outputs)) + (member (first (first outputs)) '(values list list* :values :list :list*))) + (list `(mvlet ((,(first outputs) (,(first form) ,@inputs))) + ,@(process-prog-> (rest forms))))) + (t + (list `(let ((,(first outputs) (,(first form) ,@inputs))) + ,@(process-prog-> (rest forms))))))) + (t + (list `(multiple-value-bind ,outputs + (,(first form) ,@inputs) + ,@(process-prog-> (rest forms))))))) + ((string= (string (first x)) (symbol-name :->nonnil)) + (cond + ((null (rest outputs)) + (cond + ((and (consp (first outputs)) + (member (first (first outputs)) '(values list list* :values :list :list*))) + (list `(mvlet ((,(first outputs) (,(first form) ,@inputs))) + (when ,(first outputs) + ,@(process-prog-> (rest forms)))))) + (t + (list `(let ((,(first outputs) (,(first form) ,@inputs))) + (when ,(first outputs) + ,@(process-prog-> (rest forms)))))))) + (t + (list `(multiple-value-bind ,outputs + (,(first form) ,@inputs) + (when ,(first outputs) + ,@(process-prog-> (rest forms)))))))) + ((rest outputs) + (prog->-too-many-variables-error form)) + ((string= (string (first x)) (symbol-name :->stack)) + (list `(let ((,(first outputs) (,(first form) ,@inputs))) + (declare (dynamic-extent ,(first outputs))) + ,@(process-prog-> (rest forms))))) + ((string= (string (first x)) (symbol-name :->progv)) + (list `(let ((!prog->temp1! (list (,(first form) ,@inputs))) + (!prog->temp2! (list ,(first outputs)))) + (declare (dynamic-extent !prog->temp1! !prog->temp2!)) + (progv !prog->temp2! !prog->temp1! ,@(process-prog-> (rest forms)))))) + (t + (prog->-unrecognized->-atom (first x) form))))))))))))) + +(defun prog->*-call (form inputs funarg) + (cond + ((prog->*-function-second-form-p (first form)) + (list `(,(first form) ,(first inputs) ,funarg ,@(rest inputs)))) + (t + (list `(,(first form) ,funarg ,@inputs))))) + +(defun wrap-progn (forms &optional no-simplification) + (cond + ((and (null forms) + (not no-simplification)) + nil) + ((and (null (rest forms)) + (not no-simplification)) + (first forms)) + (t + (cons 'progn forms)))) + +(defun wrap-block (name forms &optional no-simplification) + (cond + ((and (null forms) + (not no-simplification)) + nil) + (t + (list* 'block name forms)))) + +(defun process-prog->-progn (forms) + (wrap-progn (process-prog-> forms))) + +(defun process-prog->-block (forms) + (wrap-block 'prog-> (process-prog-> forms))) + +(defmacro unnamed-prog-> (&body forms) + (process-prog->-progn forms)) + +(defmacro prog-> (&body forms) + (process-prog->-block forms)) + +;;; progc.lisp EOF diff --git a/src/recursive-path-ordering.lisp b/src/recursive-path-ordering.lisp new file mode 100644 index 0000000..831a73d --- /dev/null +++ b/src/recursive-path-ordering.lisp @@ -0,0 +1,292 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: recursive-path-ordering.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *rpo-cache*) +(defvar *rpo-cache-numbering*) +(defvar *ac-rpo-cache*) + +(defun rpo-compare-terms-top (x y &optional subst testval) + (let ((*rpo-cache* nil) + (*rpo-cache-numbering* nil) + (*ac-rpo-cache* nil)) + (rpo-compare-terms x y subst testval))) + +(defun rpo-cache-lookup (x y) + (and *rpo-cache* + (let ((x# (funcall *rpo-cache-numbering* :lookup x)) + (y# (funcall *rpo-cache-numbering* :lookup y))) + (sparef *rpo-cache* x# y#)))) + +(defun rpo-cache-store (x y com) + (when com + (unless *rpo-cache* + (setf *rpo-cache* (make-sparse-vector)) + (setf *rpo-cache-numbering* (make-numbering))) + (let ((x# (funcall *rpo-cache-numbering* :lookup x)) + (y# (funcall *rpo-cache-numbering* :lookup y))) + (setf (sparef *rpo-cache* x# y#) com)))) + +(definline rpo-compare-variable*compound (x y subst testval) + (and (or (null testval) (eq '< testval)) (if (variable-occurs-p x y subst) '< '?))) + +(definline rpo-compare-compound*variable (x y subst testval) + (and (or (null testval) (eq '> testval)) (if (variable-occurs-p y x subst) '> '?))) + +(defun rpo-compare-terms (x y &optional subst testval) + (cond + ((eql x y) + '=) + (t + (dereference2 + x y subst + :if-variable*variable (if (eq x y) '= '?) + :if-variable*constant '? + :if-constant*variable '? + :if-variable*compound (rpo-compare-variable*compound x y subst testval) + :if-compound*variable (rpo-compare-compound*variable x y subst testval) + :if-constant*constant (symbol-ordering-compare x y) + :if-compound*constant (and (neq '= testval) (rpo-compare-compound*constant x y subst testval)) + :if-constant*compound (and (neq '= testval) (rpo-compare-constant*compound x y subst testval)) + :if-compound*compound (rpo-compare-compounds x y subst testval))))) + +(defun rpo-compare-compound*constant (compound constant subst testval) + ;; for a constant to be bigger than a compound, + ;; constant must be bigger than every constant/function symbol in compound + ;; and compound must be ground + ;; + ;; for a constant to be less than a compound, + ;; constant must be smaller than or identical to some constant/function symbol in compound + (let ((can-be-< t)) + (labels + ((compare-with-term (term) + (dereference + term subst + :if-variable (if (eq '< testval) (return-from rpo-compare-compound*constant nil) (setf can-be-< nil)) + :if-constant (ecase (symbol-ordering-compare term constant) + ((> =) + (return-from rpo-compare-compound*constant '>)) + (? + (if (eq '< testval) (return-from rpo-compare-compound*constant nil) (setf can-be-< nil))) + (< + )) + :if-compound (progn + (ecase (symbol-ordering-compare (head term) constant) + (> + (return-from rpo-compare-compound*constant '>)) + (? + (if (eq '< testval) (return-from rpo-compare-compound*constant nil) (setf can-be-< nil))) + (< + )) + (dolist (arg (args term)) + (compare-with-term arg)))))) + (let ((head (head compound))) + (cond + ((function-boolean-valued-p head) + (return-from rpo-compare-compound*constant + (if (constant-boolean-valued-p constant) + (if (ordering-functions>constants?) '> (symbol-ordering-compare head constant)) ;no subterm comparisons + '>))) ;atom > term + ((constant-boolean-valued-p constant) + (return-from rpo-compare-compound*constant '<)) ;term < atom + ((ordering-functions>constants?) + '>) + (t + (ecase (symbol-ordering-compare head constant) + (> + (return-from rpo-compare-compound*constant '>)) + (? + (if (eq '< testval) (return-from rpo-compare-compound*constant nil) (setf can-be-< nil))) + (< + )) + (dolist (arg (args compound)) + (compare-with-term arg)) + (if can-be-< '< '?))))))) + +(defun rpo-compare-constant*compound (constant compound subst testval) + (opposite-order (rpo-compare-compound*constant compound constant subst (opposite-order testval)))) + +(defun rpo-compare-compounds (x y subst testval) + (cond + ((eq x y) + '=) + ((test-option19?) + (rpo-compare-compounds0 x y subst testval)) + (t + (ecase testval + (> + (and (implies (test-option20?) (no-new-variable-occurs-p y subst (variables x subst))) + (rpo-compare-compounds0 x y subst '>))) + (< + (and (implies (test-option20?) (no-new-variable-occurs-p x subst (variables y subst))) + (rpo-compare-compounds0 x y subst '<))) + (= + (let ((xvars (variables x subst)) + (yvars (variables y subst))) + (and (length= xvars yvars) + (dolist (v xvars t) + (unless (member v yvars :test #'eq) + (return nil))) + (rpo-compare-compounds0 x y subst '=)))) + ((nil) + (let ((xvars (variables x subst)) + (yvars (variables y subst))) + (dolist (v xvars) + (unless (member v yvars :test #'eq) + (setf testval '>) + (return))) + (dolist (v yvars) + (unless (member v xvars :test #'eq) + (cond + ((null testval) + (setf testval '<) + (return)) + (t + (return-from rpo-compare-compounds '?)))))) + (let ((v (rpo-compare-compounds0 x y subst testval))) + (if (or (null testval) (eq testval v)) v '?))))))) + +(defun rpo-compare-compounds0 (x y subst testval) + (let ((fn (head x))) + (ecase (symbol-ordering-compare fn (head y)) + (= + (case (function-arity fn) + (1 + (rpo-compare-terms (arg1 x) (arg1 y) subst testval)) + (otherwise + (let ((status (function-rpo-status fn))) + (ecase status + (:left-to-right + (rpo-compare-lists x y (args x) (args y) subst testval)) + (:right-to-left + (rpo-compare-lists x y (reverse (args x)) (reverse (args y)) subst testval)) + ((:commutative :multiset) + (let ((xargs (args x)) + (yargs (args y))) + (cond + ((and (eq :commutative status) (or (rrest xargs) (rrest yargs))) + (rpo-compare-terms (make-compound* *a-function-with-left-to-right-ordering-status* + (make-compound *a-function-with-multiset-ordering-status* (first xargs) (second xargs)) + (rrest xargs)) + (make-compound* *a-function-with-left-to-right-ordering-status* + (make-compound *a-function-with-multiset-ordering-status* (first yargs) (second yargs)) + (rrest yargs)) + subst + testval)) + (t + (compare-term-multisets #'rpo-compare-terms xargs yargs subst testval))))) + (:ac + (with-clock-on ordering-ac + (ac-rpo-compare-compounds fn (flatargs x subst) (flatargs y subst) subst))) + ((:none) + ;; (unimplemented) + (cond + ((equal-p x y subst) + '=) + (t + '?)))))))) + (> + (and (neq '= testval) (rpo-compare-compounds> x (flatargs y subst) subst testval))) + (< + (and (neq '= testval) (rpo-compare-compounds< (flatargs x subst) y subst testval))) + (? + (and (neq '= testval) (rpo-compare-compounds? x y (flatargs x subst) (flatargs y subst) subst testval)))))) + +(defun rpo-compare-lists (x y xargs yargs subst testval) + (let (xarg yarg) + (loop + (cond + ((null xargs) + (return (if (null yargs) '= '<))) + ((null yargs) + (return '>)) + ((eql (setf xarg (pop xargs)) (setf yarg (pop yargs))) + ) + (t + (ecase (rpo-compare-terms xarg yarg subst nil) + (> + (return (and (neq '= testval) (rpo-compare-compounds> x yargs subst testval)))) + (< + (return (and (neq '= testval) (rpo-compare-compounds< xargs y subst testval)))) + (? + (return (and (neq '= testval) (rpo-compare-compounds? x y xargs yargs subst testval)))) + (= + ))))))) + +(defun rpo-compare-compounds> (x yargs subst testval) + (if (or (null yargs) (function-boolean-valued-p (head x))) + '> + (let ((can-be-> t)) + (dolist (yarg yargs (if can-be-> '> '?)) + (ecase (rpo-compare-terms x yarg subst nil) + (? + (if (eq '> testval) (return nil) (setf can-be-> nil))) + ((< =) + (return '<)) + (> + )))))) + +(defun rpo-compare-compounds< (xargs y subst testval) + (if (or (null xargs) (function-boolean-valued-p (head y))) + '< + (let ((can-be-< t)) + (dolist (xarg xargs (if can-be-< '< '?)) + (ecase (rpo-compare-terms xarg y subst nil) + (? + (if (eq '< testval) (return nil) (setf can-be-< nil))) + ((> =) + (return '>)) + (< + )))))) + +(defun rpo-compare-compounds? (x y xargs yargs subst testval) + (cond + ((and (or (null testval) (eq '> testval)) (thereis-rpo-equal-or-greaterp xargs y subst)) + '>) + ((and (or (null testval) (eq '< testval)) (thereis-rpo-equal-or-greaterp yargs x subst)) + '<) + ((null testval) + '?))) + +(defun thereis-rpo-equal-or-greaterp (args term subst) + (and (not (function-boolean-valued-p (head term))) + (dolist (arg args nil) + (dereference + arg subst + :if-constant (when (eq '< (rpo-compare-compound*constant term arg subst '<)) + (return t)) + :if-compound (case (rpo-compare-compounds arg term subst '>) + ((> =) ;= should be returned if they're equal even if testval is > + (return t))))))) + +(defun rpo-compare-alists (alist1 alist2 subst testval) + ;; this should be specialized for better performance + (labels + ((rpo-alist-args (alist) + (dereference + alist subst + :if-variable (list alist) + :if-constant nil + :if-compound (lcons (first alist) + (rpo-alist-args (rest alist)) + alist)))) + (compare-term-multisets #'rpo-compare-terms (rpo-alist-args alist1) (rpo-alist-args alist2) subst testval))) + +;;; recursive-path-ordering.lisp EOF diff --git a/src/resolve-code-tables.lisp b/src/resolve-code-tables.lisp new file mode 100644 index 0000000..798456b --- /dev/null +++ b/src/resolve-code-tables.lisp @@ -0,0 +1,154 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: resolve-code-tables.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2006. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun table-satisfier (cc atom subst) + ;; enables procedural attachment of a table to a relation + (let* ((args (args atom)) + (pattern (table-lookup-pattern args subst))) + (cond + ((eq none pattern) + ) ;inapplicable + (t + (prog-> + (predicate-to-table (function-name (head atom)) -> table mapper exporters) + (funcall mapper table exporters pattern subst ->* subst) + (funcall cc subst)))))) + +(defun table-rewriter (atom subst) + ;; assume completeness of table to return false + (let* ((args (args atom)) + (pattern (table-lookup-pattern args subst))) + (cond + ((eq none pattern) + none) ;inapplicable + ((ground-p pattern) + (prog-> + (predicate-to-table (function-name (head atom)) -> table mapper exporters) + (funcall mapper table exporters pattern nil ->* subst) + (declare (ignore subst)) + (return-from table-rewriter true)) ;true if in table + (dolist (x pattern) + (unless (constant-constructor x) + (return-from table-rewriter none))) ;don't rewrite if args aren't constructors + false) ;false if not in table + (t + (dolist (x pattern) + (unless (or (variable-p x) (constant-constructor x)) + (return-from table-rewriter none))) ;don't rewrite if args aren't constructors + (prog-> + (predicate-to-table (function-name (head atom)) -> table mapper exporters) + (quote nil -> *frozen-variables*) + (funcall mapper table exporters pattern nil ->* subst) + (declare (ignore subst)) + (return-from table-rewriter none)) ;don't rewrite if an instance exists + false)))) ;false if there are no instances + +(defun table-lookup-pattern (args subst) + (mapcar + (lambda (arg) + (dereference + arg subst + :if-compound (return-from table-lookup-pattern none) ;inapplicable + :if-variable arg + :if-constant arg)) + args)) + +(defun simple-table-mapper (cc table exporters pattern subst) + ;; this mapper function just does linear search of the table + (let ((revvars nil)) + (dolist (x pattern) + (when (variable-p x) + (push x revvars))) + (dolist (row table) + (do ((r row (rest r)) + (p pattern (rest p))) + ((or (null r) (null p)) + (when (and (null r) (null p)) + (do ((r row (rest r)) + (p pattern (rest p)) + (e exporters (rest e)) + (revvals nil)) + ((null r) + (unify cc revvars revvals subst)) + (when (variable-p (first p)) + (push (if (first e) + (funcall (first e) (first r)) + (declare-constant (first r))) + revvals))))) + (unless (or (equal (first r) (first p)) (variable-p (first p))) + (return)))) + nil)) + +(defun predicate-to-table (p) + (relation-to-table p)) + +(defun relation-to-table (p) + ;; return table for relation p (could be filename or some other way to refer to a file), + ;; a mapper function (finds tuples in the table that match the pattern), + ;; and an export function for each column + (case p + ;; supervises example + ;; (in package SNARK-USER so it's largely invisible except for running the example) + (snark-user::supervises + (values '(("perrault" "lowrance") + ("lowrance" "stickel") + ("lowrance" "waldinger")) + 'simple-table-mapper + (consn (lambda (x) (declare-constant x :sort 'person)) nil 2))) + )) + +(defun test-table-resolver (&optional (test 1)) + (initialize) + (use-resolution) + (declare-sort 'person) + (declare-relation + 'snark-user::supervises 2 + :satisfy-code 'table-satisfier + :rewrite-code 'table-rewriter) + (declare-constant "lowrance" :sort 'person) + (declare-constant "stickel" :sort 'person) + (declare-constant 'stickel :sort 'person) + (ecase test + (1 + (prove '(snark-user::supervises "lowrance" "stickel"))) + (2 + (prove '(snark-user::supervises "lowrance" ?person) :answer '(values ?person))) + (3 + (prove '(snark-user::supervises ?person "stickel") :answer '(values ?person))) + (4 + (prove '(snark-user::supervises ?person1 ?person2) :answer '(values ?person1 ?person2))) + (5 + (prove '(not (snark-user::supervises "stickel" "perrault")))) + (6 + (prove '(not (snark-user::supervises "stickel" ?person)) :answer '(values ?person))) + (7 + ;; should fail (stickel isn't constructor) + (prove '(not (snark-user::supervises stickel "perrault")))) + (8 + ;; should fail (stickel isn't constructor) + (prove '(not (snark-user::supervises stickel ?person)))) + ) + (loop + (when (eq :agenda-empty (closure)) + (return))) + (print-rows)) + +;;; resolve-code-tables.lisp EOF diff --git a/src/resolve-code.lisp b/src/resolve-code.lisp new file mode 100644 index 0000000..f1c76ed --- /dev/null +++ b/src/resolve-code.lisp @@ -0,0 +1,193 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: resolve-code.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun reflexivity-satisfier (cc atom subst) + ;; example: this is called when trying to resolve away (not (rel a b)) after + ;; doing (declare-relation 'rel 2 :satisfy-code 'reflexivity-satisfier) + ;; (rel a b) -> true after unifying a and b + (mvlet (((list a b) (args atom))) + (unify cc a b subst))) ;call cc with resulting substitutions + +(defun irreflexivity-falsifier (cc atom subst) + (reflexivity-satisfier cc atom subst)) + +(defun constructor-reflexivity-satisfier (cc atom subst) + (mvlet (((list a b) (args atom))) + (when (or (constructor-term-p a subst) (constructor-term-p b subst)) + (unify cc a b subst)))) + +(defun constructor-irreflexivity-falsifier (cc atom subst) + (constructor-reflexivity-satisfier cc atom subst)) + +(defun variables-reflexivity-satisfier (cc atom subst) + (mvlet (((list a b) (args atom))) + (when (and (dereference a subst :if-variable t) (dereference b subst :if-variable t)) + (unify cc a b subst)))) + +(defun variables-irreflexivity-falsifier (cc atom subst) + (variables-reflexivity-satisfier cc atom subst)) + +(defun variable-satisfier (cc atom subst) + (let ((x (arg1 atom))) + (dereference + x subst + :if-variable (funcall cc subst)))) + +(defun nonvariable-satisfier (cc atom subst) + (let ((x (arg1 atom))) + (dereference + x subst + :if-constant (funcall cc subst) + :if-compound (funcall cc subst)))) + +(defun resolve-code-example1 (&optional (case 1)) + (let ((mother-table (print '((alice betty) + (alice barbara) + (betty carol) + (betty claudia))))) + (flet ((mother-satisfier (cc atom subst) + ;; the two definitions below are equivalent + #+ignore + (let ((args (args atom))) + (mapc (lambda (pair) (unify cc args pair subst)) + mother-table)) + (prog-> + (args atom -> args) + (mapc mother-table ->* pair) + (unify args pair subst ->* subst2) + (funcall cc subst2)))) + (initialize) + (print-options-when-starting nil) + (print-rows-when-derived nil) + (print-summary-when-finished nil) + (case case + (1 + (use-resolution t)) + (2 + (use-hyperresolution t)) + (3 + (use-negative-hyperresolution t))) + (declare-relation 'mother 2 :satisfy-code #'mother-satisfier) + (prove '(mother betty ?x) :answer '(values ?x) :name 'who-is-bettys-child?) + (loop + (when (eq :agenda-empty (closure)) + (return))) + (mapcar (lambda (x) (arg1 x)) (answers))))) + +(defun resolve-code-example2 (&optional (case 1)) + ;; silly example to illustrate satisfy/falsify code with residue + ;; suppose (* a b c) means a*b=c + ;; then use satisfy code with residue for the following resolution operations + ;; (not (* ?x a b)) -> (not (= a b)) with {?x <- 1} + ;; (not (* a ?x b)) -> (not (= a b)) with {?x <- 1} + (initialize) + (declare-constant 1) + (declare-relation '* 3 :satisfy-code 'resolve-code-example2-satisfier) + (case case + (1 + (use-resolution t) + (prove '(and (not (p ?x ?y ?z)) (* ?x a b) (* c ?y d) (* e ?z ?z)))) ;nucleus + (2 + (use-hyperresolution t) + (prove '(and (not (p ?x ?y ?z)) (* ?x a b) (* c ?y d) (* e ?z ?z)))) ;nucleus + (3 + (use-negative-hyperresolution t) + (prove '(* ?x a b))) ;electron + (4 + (use-ur-resolution t) + (prove '(and (not (p ?x ?y ?z)) (* ?x a b) (* c ?y d) (* e ?z ?z)))) ;nucleus + )) + +(defun resolve-code-example2-satisfier (cc atom subst) + (prog-> + (args atom -> args) + (unify 1 (first args) subst ->* subst) + (funcall cc subst (make-compound *not* (make-compound *=* (second args) (third args))))) + (prog-> + (args atom -> args) + (unify 1 (second args) subst ->* subst) + (funcall cc subst (make-compound *not* (make-compound *=* (first args) (third args)))))) + +(define-plist-slot-accessor function :resolve-code-satisfy-code) +(define-plist-slot-accessor function :resolve-code-falsify-code) + +(defun resolve-code-resolver1 (cc wff subst) + ;; resolve-code takes wff and substitution as input, + ;; calls continuation with new substitution and optional new wff (residue) as result + ;; + ;; this particular sample resolve-code uses functions, written in the style + ;; of function-satisfy-code and function-falsify-code, but stored as + ;; function-resolve-code-satisfy-code and function-resolve-code-falsify-code + ;; to simultaneously satisfy/falsify literals in a clause in all possible ways + (when (clause-p wff) + (mvlet (((values negatoms posatoms) (atoms-in-clause3 wff))) + (labels + ((resolver (negatoms posatoms subst residue) + (cond + (negatoms + (let ((atom (pop negatoms))) + (dereference + atom subst + :if-compound-appl + (prog-> + ;; for every way of satisfying this atom by code, + ;; try to satisfy/falsify the remaining atoms by code + (dolist (function-resolve-code-satisfy-code (head atom)) ->* fun) + (funcall fun atom subst ->* subst res) + (resolver negatoms posatoms subst (if (and residue res) + (disjoin residue res) + (or residue res))))) + ;; also try to satisfy/falsify remaining atoms leaving this atom in residue + (resolver negatoms posatoms subst (if residue + (disjoin residue (negate atom)) + (negate atom))))) + (posatoms + (let ((atom (pop posatoms))) + (dereference + atom subst + :if-compound-appl + (prog-> + ;; for every way of falsifying this atom by code, + ;; try to satisfy/falsify the remaining atoms by code + (dolist (function-resolve-code-falsify-code (head atom)) ->* fun) + (funcall fun atom subst ->* subst res) + (resolver negatoms posatoms subst (if (and residue res) + (disjoin residue res) + (or residue res))))) + ;; also try to satisfy/falsify remaining atoms leaving this atom in residue + (resolver negatoms posatoms subst (if residue + (disjoin residue atom) + atom)))) + (t + (funcall cc subst residue))))) + (resolver negatoms posatoms subst nil))))) + +(defun resolve-code-example3 () + ;; silly example to illustrate resolve-code for whole formulas + ;; gives same result as resolve-code-example2, but in single rather than multiple steps + (initialize) + (declare-relation '* 3) + (setf (function-resolve-code-satisfy-code (input-relation-symbol '* 3)) + '(resolve-code-example2-satisfier)) + (use-resolve-code 'resolve-code-resolver1) + (prove '(and (not (p ?x ?y ?z)) (* ?x a b) (* c ?y d) (* e ?z ?z)))) + +;;; resolve-code.lisp EOF diff --git a/src/rewrite-code.lisp b/src/rewrite-code.lisp new file mode 100644 index 0000000..cde5f25 --- /dev/null +++ b/src/rewrite-code.lisp @@ -0,0 +1,402 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: rewrite-code.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun equality-rewriter (atom subst) + ;; (= t t) -> true + ;; (= t s) -> false if t and s are headed by different constructors + ;; (= (f t1 ... tn) (f s1 ... sn)) -> (and (= t1 s1) ... (= tn sn)) if f is injective + ;; (= t s) -> false if t and s have disjoint sorts + ;; also try equality-rewrite-code functions for (= (f ...) (f ...)) + ;; none otherwise + (mvlet ((*=* (head atom)) + ((list x y) (args atom))) + (or (dereference2 + x y subst + :if-variable*variable (cond + ((eq x y) + true)) + :if-constant*constant (cond + ((eql x y) + true)) + :if-compound*compound (cond + ((equal-p x y subst) + true) + (t + (let ((fn1 (head x)) (fn2 (head y))) + (cond + ((eq fn1 fn2) + (cond + ((dolist (fun (function-equality-rewrite-code fn1) nil) + (let ((v (funcall fun atom subst))) + (unless (eq none v) + (return v))))) + ((function-associative fn1) + nil) + ((and (function-constructor fn1) (function-commutative fn1)) + (let ((xargs (args x)) + (yargs (args y))) + (if (length= xargs yargs) + (conjoin (let ((x1 (first xargs)) (x2 (second xargs)) + (y1 (first yargs)) (y2 (second yargs))) + (disjoin (conjoin (make-equality x1 y1) (make-equality x2 y2) subst) + (conjoin (make-equality x1 y2) (make-equality x2 y1) subst) + subst)) + (conjoin* (mapcar #'make-equality (rrest xargs) (rrest yargs)) subst) + subst) + false))) + ((function-injective fn1) + (let ((xargs (args x)) + (yargs (args y))) + (if (length= xargs yargs) + (conjoin* (mapcar #'make-equality xargs yargs) subst) ;may result in nonclause + false)))))))))) + (let ((xconstant nil) (xcompound nil) (xconstructor nil) xsort + (yconstant nil) (ycompound nil) (yconstructor nil) ysort) + (dereference + x nil + :if-constant (setf xconstant t xconstructor (constant-constructor x)) + :if-compound (setf xcompound t xconstructor (function-constructor (head x)))) + (dereference + y nil + :if-constant (setf yconstant t yconstructor (constant-constructor y)) + :if-compound (setf ycompound t yconstructor (function-constructor (head y)))) + (cond + ((or (and xconstructor yconstructor (implies (and xcompound ycompound) (neq (head x) (head y)))) + (sort-disjoint? + (setf xsort (if xcompound (compound-sort x subst) (if xconstant (constant-sort x) (variable-sort x)))) + (setf ysort (if ycompound (compound-sort y subst) (if yconstant (constant-sort y) (variable-sort y))))) + (and (not (same-sort? xsort ysort)) + (or (and xconstructor (not (subsort? xsort ysort)) (not (same-sort? xsort (sort-intersection xsort ysort)))) + (and yconstructor (not (subsort? ysort xsort)) (not (same-sort? ysort (sort-intersection xsort ysort)))))) + (and xconstructor + xcompound + (cond + (yconstant (constant-occurs-below-constructor-p y x subst)) + (ycompound (compound-occurs-below-constructor-p y x subst)) + (t (variable-occurs-below-constructor-p y x subst)))) + (and yconstructor + ycompound + (cond + (xconstant (constant-occurs-below-constructor-p x y subst)) + (xcompound (compound-occurs-below-constructor-p x y subst)) + (t (variable-occurs-below-constructor-p x y subst))))) + false))) + none))) + +(defun make-characteristic-atom-rewriter (pred sort) + (setf sort (the-sort sort)) + (lambda (atom subst) + (let ((term (arg1 atom)) s) + (or (dereference + term subst + :if-variable (progn (setf s (variable-sort term)) nil) + :if-constant (cond + ((funcall pred term) + true) + ((constant-constructor term) + false) + (t + (progn (setf s (constant-sort term)) nil))) + :if-compound-cons (cond + ((funcall pred term) ;for pred being listp or consp + true) + (t + false)) + :if-compound-appl (cond + ((funcall pred term) ;for pred being bagp + true) + ((function-constructor (head term)) + false) + (t + (progn (setf s (compound-sort term subst)) nil)))) + (cond +;; ((subsort? s sort) +;; true) + ((sort-disjoint? s sort) + false)) + none)))) + +(defun reflexivity-rewriter (atom subst) + ;; example: this is called when trying to rewrite (rel a b) after + ;; doing (declare-relation 'rel 2 :rewrite-code 'reflexivity-rewriter) + ;; (rel a b) -> true after unifying a and b + ;; returns new value (true) or none (no rewriting done) + (let ((args (args atom))) + (if (equal-p (first args) (second args) subst) true none))) + +(defun irreflexivity-rewriter (atom subst) + ;; example: this is called when trying to rewrite (rel a b) after + ;; doing (declare-relation 'rel 2 :rewrite-code 'irreflexivity-rewriter) + ;; (rel a b) -> false after unifying a and b + ;; returns new value (false) or none (no rewriting done) + (let ((args (args atom))) + (if (equal-p (first args) (second args) subst) false none))) + +(defun associative-identity-rewriter (term subst) + ;; remove identities from argument list + ;; eliminate head when less than two arguments + (let* ((head (head term)) + (identity (function-identity head))) + (unless (eq none identity) + (labels + ((simp (args) + (if (null args) + nil + (let* ((y (rest args)) + (y* (simp y)) + (x (first args))) + (if (dereference x subst :if-constant (eql identity x)) + y* + (if (eq y y*) args (cons x y*))))))) + (let* ((args (flatargs term)) + (args* (simp args))) + (cond + ((null args*) + identity) + ((null (rest args*)) + (first args*)) + ((neq args args*) + (make-compound* head args*)) + (t + none))))))) + +(defun associative-identity-paramodulater (cc term subst0 &optional (collapse (test-option44?))) + (let* ((head (head term)) + (identity (function-identity head))) + (unless (eq none identity) + (labels + ((param (args subst l) + (if (null args) + (unless (eq subst0 subst) + (funcall cc (make-a1-compound* head identity (reverse l)) subst)) + (let ((x (first args))) + (dereference + x subst + :if-variable (unless (member x l) + (prog-> + (unify x identity subst ->* subst) + (param (rest args) subst l)))) + (cond + ((eql identity x) + (param (rest args) subst l)) + ((implies collapse (null l)) + (param (rest args) subst (cons x l)))))))) + (param (flatargs term subst0) subst0 nil))))) + +(defun nonvariable-rewriter (atom subst) + (let ((x (arg1 atom))) + (dereference + x subst + :if-variable none + :if-constant true + :if-compound true))) + +(defun the-term-rewriter (term subst) + ;; (the sort value) -> value, if value's sort is a subsort of sort + (let* ((args (args term)) + (arg1 (first args)) + (arg2 (second args))) + (if (dereference + arg1 subst + :if-constant (and (sort-name? arg1) (subsort? (term-sort arg2 subst) (the-sort arg1)))) + arg2 + none))) + +(defun not-wff-rewriter (wff subst) + (declare (ignore subst)) + (let ((arg (arg1 wff))) + (cond + ((eq true arg) + false) + ((eq false arg) + true) + (t + none)))) + +(defun and-wff-rewriter (wff subst) + (let ((wff* (conjoin* (args wff) subst))) + (if (equal-p wff wff* subst) none wff*))) + +(defun or-wff-rewriter (wff subst) + (let ((wff* (disjoin* (args wff) subst))) + (if (equal-p wff wff* subst) none wff*))) + +(defun implies-wff-rewriter (wff subst) + (let ((args (args wff))) + (implies-wff-rewriter1 (first args) (second args) subst))) + +(defun implied-by-wff-rewriter (wff subst) + (let ((args (args wff))) + (implies-wff-rewriter1 (second args) (first args) subst))) + +(defun implies-wff-rewriter1 (x y subst) + (or (dereference2 + x y subst + :if-variable*variable (cond + ((eq x y) + true)) + :if-variable*constant (cond + ((eq true y) + true) + ((eq false y) + (negate x subst))) + :if-constant*variable (cond + ((eq true x) + y) + ((eq false x) + true)) + :if-constant*constant (cond + ((eql x y) + true) + ((eq true x) + y) + ((eq false x) + true) + ((eq true y) + true) + ((eq false y) + (negate x subst))) + :if-variable*compound (cond + ((and (negation-p y) (eq x (arg1 y))) + false)) + :if-compound*variable (cond + ((and (negation-p x) (eq (arg1 x) y)) + false)) + :if-constant*compound (cond + ((eq true x) + y) + ((eq false x) + true) + ((and (negation-p y) (eql x (arg1 y))) + false)) + :if-compound*constant (cond + ((eq true y) + true) + ((eq false y) + (negate x subst)) + ((and (negation-p x) (eql (arg1 x) y)) + false)) + :if-compound*compound (cond + ((equal-p x y subst) + true) + ((and (negation-p x) (equal-p (arg1 x) y subst)) + false) + ((and (negation-p y) (equal-p x (arg1 y) subst)) + false))) + none)) + +(defun distributive-law1-p (lhs rhs &optional subst) + ;; checks if LHS=RHS is of form X*(Y+Z)=(X*Y)+(X*Z) for variables X,Y,Z and distinct function symbols *,+ + (let (fn1 fn2 vars sort) + (and (dereference + lhs subst + :if-compound (progn (setf fn1 (head lhs)) t)) + (dereference + rhs subst + :if-compound (neq (setf fn2 (head rhs)) fn1)) + (= (length (setf vars (variables rhs subst (variables lhs subst)))) 3) + (same-sort? (setf sort (variable-sort (first vars))) (variable-sort (second vars))) + (same-sort? sort (variable-sort (third vars))) + (let ((x (make-variable sort)) + (y (make-variable sort)) + (z (make-variable sort))) + (variant-p (cons (make-compound fn1 x (make-compound fn2 y z)) + (make-compound fn2 (make-compound fn1 x y) (make-compound fn1 x z))) + (cons lhs rhs) + subst))))) + +(defun cancel1 (eq fn identity terms1 terms2 subst) + (prog-> + (count-arguments fn terms2 subst (count-arguments fn terms1 subst) -1 -> terms-and-counts cancel) + (cond + ((null cancel) + none) + (t + (quote nil -> args1) + (quote nil -> args2) + (progn + (dolist terms-and-counts ->* v) + (tc-count v -> count) + (cond + ((> count 0) + (setf args1 (consn (tc-term v) args1 count))) + ((< count 0) + (setf args2 (consn (tc-term v) args2 (- count)))))) + (if (or (and (null args1) args2 (null (cdr args2)) (eql identity (car args2))) + (and (null args2) args1 (null (cdr args1)) (eql identity (car args1)))) ;don't simplify x+0=x + none + (make-compound eq + (make-a1-compound* fn identity args1) + (make-a1-compound* fn identity args2))))))) + +(defun make-cancel (eq fn identity) + (lambda (equality subst) + (prog-> + (args equality -> args) + (first args -> x) + (second args -> y) + (cond + ((dereference x subst :if-compound (eq fn (head x))) + (cancel1 eq fn identity (args x) (list y) subst)) + ((dereference y subst :if-compound (eq fn (head y))) + (cancel1 eq fn identity (list x) (args y) subst)) + (t + none))))) + +(defun declare-cancellation-law (equality-relation-symbol function-symbol identity-symbol) + (let ((eq (input-relation-symbol equality-relation-symbol 2)) + (fn (input-function-symbol function-symbol 2)) + (id (input-constant-symbol identity-symbol))) + (declare-relation equality-relation-symbol 2 :locked nil :rewrite-code (make-cancel eq fn id)))) + +(defun distributivity-rewriter (term subst op2) + ;; distributes (head term) over op2 (e.g., * over + in (* (+ a b) c)) + ;; flattens argument lists of both operators + (let* ((head (head term)) + (args (argument-list-a1 head (args term) subst))) + (cond + ((member-if #'(lambda (arg) (dereference arg subst :if-compound-appl (eq op2 (heada arg)))) args) + (labels + ((distribute (args) + (if (null args) + (list nil) + (let ((l (distribute (rest args))) + (arg (first args))) + (if (dereference arg subst :if-compound-appl (eq op2 (heada arg))) + (prog-> + (mapcan (argument-list-a1 op2 (args arg) subst) ->* x) + (mapcar l ->* y) + (cons x y)) + (prog-> + (mapcar l ->* y) + (cons arg y))))))) + (make-compound* op2 (mapcar #'(lambda (x) (make-compound* head x)) (distribute args))))) + (t + none)))) + +(defun declare-distributive-law (fn1 fn2) + (let ((fn1 (input-function-symbol fn1 2)) ;sum + (fn2 (input-function-symbol fn2 2))) ;product + (declare-function + fn2 (function-arity fn2) + :rewrite-code (lambda (term subst) (distributivity-rewriter term subst fn1))))) + +;;; rewrite-code.lisp EOF diff --git a/src/rewrite.lisp b/src/rewrite.lisp new file mode 100644 index 0000000..cea6f62 --- /dev/null +++ b/src/rewrite.lisp @@ -0,0 +1,488 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: rewrite.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim (special *subsuming* *frozen-variables* *processing-row*)) + +(defstruct (rewrite + (:constructor make-rewrite (row pattern value condition pattern-symbol-count new-value-variables polarity))) + row + pattern + value + condition + pattern-symbol-count + new-value-variables + (embeddings nil) + (polarity nil) + ) + +(defvar *redex-path* nil) ;(polarity-n function-n ... polarity-1 function-1) + +(defun rewrite-patterns-and-values (function pattern value pattern-symbol-count embeddings symbol-count) + ;; calls function with rewrite's pattern and value, and patterns and values for any embeddings, + ;; provided size of the pattern does not exceed size of the term + (prog-> + (when (symbol-count-not-greaterp pattern-symbol-count symbol-count) + (funcall function pattern value) + (when embeddings + (- (symbol-count-total symbol-count) (symbol-count-total pattern-symbol-count) -> size-difference) + (unless (< size-difference 2) + (dereference pattern nil) + (head pattern -> head) + (function-sort head -> sort) + (make-variable sort -> newvar1) + (ecase embeddings + (:l + (funcall function + (make-compound head newvar1 pattern) ;left embedding + (make-compound head newvar1 value))) + (:r + (funcall function + (make-compound head pattern newvar1) ;right embedding + (make-compound head value newvar1))) + (:l&r + (funcall function + (make-compound head newvar1 pattern) ;left embedding + (make-compound head newvar1 value)) + (funcall function + (make-compound head pattern newvar1) ;right embedding + (make-compound head value newvar1)) + (unless (< size-difference 4) + (make-variable sort -> newvar2) + (funcall function + (make-compound head newvar1 pattern newvar2) ;left & right embedding + (make-compound head newvar1 value newvar2)))))))))) + +(defvar *rewrites-used*) + +(defvar rewrite-strategy :innermost) +;; options: +;; :innermost simplifies subterms first +;; :outermost tries to simplify outer terms first, subterms in left-to-right order otherwise + +(defvar fully-rewritten-compounds) + +(defun redex-at-top? () + (null *redex-path*)) + +(defun redex-polarity (&optional (rp *redex-path*)) + (if (null rp) + :pos + (first rp))) + +(defun set-redex-polarity (polarity) + (setf (first *redex-path*) polarity)) + +(defun redex-literal? (&optional (rp *redex-path*)) + (or (null rp) + (and (eq 'not (function-logical-symbol-p (second rp))) + (redex-literal? (cddr rp))))) + +(defun redex-clause? (&optional (rp *redex-path*)) + (or (null rp) + (and (redex-clause? (cddr rp)) + (let ((c (function-logical-symbol-p (second rp)))) + (or (not c) + (case c + (not + t) + (and + (eq :neg (redex-polarity (cddr rp)))) + (or + (eq :pos (redex-polarity (cddr rp)))) + (implies + (eq :pos (redex-polarity (cddr rp)))) + (implied-by + (eq :pos (redex-polarity (cddr rp)))) + (otherwise + nil))))))) + +(defun rewriter (term subst) + (dereference + term subst + :if-variable term + :if-constant (if (or (eq true term) (eq false term)) + term + (let ((*subsuming* t) + (*frozen-variables* *frozen-variables*) + (fully-rewritten-compounds nil)) + (ecase rewrite-strategy + (:innermost + (rewrite-innermost term subst nil)) + (:outermost + (rewrite-outermost term subst nil))))) + :if-compound (let ((*subsuming* t) + (*frozen-variables* (variables term subst *frozen-variables*)) + (fully-rewritten-compounds nil)) + (ecase rewrite-strategy +;; (:innermost +;; (rewrite-innermost term subst nil)) + (:innermost ;rewrite at top first, then do innermost simplification + (let ((term* (rewrite-compound term subst (head term)))) + (cond + ((eq none term*) + (rewrite-innermost term subst :top)) + ((or (eq true term*) (eq false term*)) + term*) + (t + (rewrite-innermost term* subst nil))))) + (:outermost + (rewrite-outermost term subst nil)))))) + +(defun rewrite-constant (term) + ;; it is assumed that the lhs of any applicable rewrite must be identical to term + (prog-> + (dolist (rewrites term) ->* rewrite) + (rewrite-row rewrite -> w) + (rewrite-condition rewrite -> cond) + (when (and (implies w (and (eq t (context-subsumes? (row-context-live? w) *rewriting-row-context*)) (not (row-hint-p w)))) + (implies (rewrite-polarity rewrite) (eq (rewrite-polarity rewrite) (redex-polarity))) + (or (eq cond t) (funcall cond (rewrite-pattern rewrite) (rewrite-value rewrite) nil)) + (term-subsort-p (rewrite-value rewrite) term nil)) + (pushnew-unless-nil w *rewrites-used*) + (return-from rewrite-constant + (rewrite-value rewrite)))) + none) + +(defun rewrite-compound (term subst head) + (let* ((funs (function-rewrite-code head)) + (v (if funs (rewrite-compound-by-code term subst funs) none))) + (cond + ((neq none v) + v) + ((function-rewritable-p head) + (rewrite-compound-by-rule term subst (symbol-count term subst))) + (t + none)))) + +(defun rewrite-compound-by-code (term subst funs) + (dolist (fun funs none) + (let ((result (funcall fun term subst))) + (unless (eq none result) +;; (setf result (declare-constants result)) + (when (term-subsort-p result term subst) + (let ((head (head term))) + (pushnew-unless-nil + (and (not (function-logical-symbol-p head)) + (function-code-name head)) + *rewrites-used*)) + (return result)))))) + +(defun declare-constants (x &optional subst) + (prog-> + (map-terms-in-term-and-compose-result x subst ->* term polarity) + (declare (ignore polarity)) + (if (constant-p term) (declare-constant term) term))) + +(defun rewrite-compound-by-rule (term subst symbol-count) + (prog-> + ;; ASSUME THAT IF EMBEDDED REWRITE IS NEEDED, ITS UNEMBEDDED FORM WILL BE RETRIEVED + (when (trace-rewrite?) + (format t "~2%; REWRITE-COMPOUND-BY-RULE will try to rewrite~%; ~A." (term-to-lisp term subst))) + (retrieve-generalization-entries term subst #'tme-rewrites ->* e rewrites) + (declare (ignore e)) + (dolist rewrites ->* rewrite) + (rewrite-row rewrite -> w) + (when (and (implies w (and (eq t (context-subsumes? (row-context-live? w) *rewriting-row-context*)) (not (row-hint-p w)))) + (implies (rewrite-polarity rewrite) (eq (rewrite-polarity rewrite) (redex-polarity)))) + (rewrite-condition rewrite -> cond) + (rewrite-pattern rewrite -> pattern) + (rewrite-value rewrite -> value) + (when (eq :verbose (trace-rewrite?)) + (format t "~%; Try ~A -> ~A." pattern value)) + (rewrite-pattern-symbol-count rewrite -> pattern-symbol-count) + (quote nil -> v) + (cond + ((and (setf v (ac-inverse-rule-p pattern value cond subst)) + (setf v (apply-ac-inverse-rule (args term) (car v) (cadr v) (caddr v) subst))) + (return-from rewrite-compound-by-rule v)) + (t + (rewrite-patterns-and-values + pattern + value + pattern-symbol-count + (rewrite-embeddings rewrite) + symbol-count + ->* pattern* value*) + (when (eq :verbose (trace-rewrite?)) + (format t "~%; Try ~A LHS." pattern*) +;; (format t "~%; FROZEN: ~A" (setf *frz* *frozen-variables*)) +;; (format t "~%; PATTERN*: ~A" (setf *pat* pattern*)) +;; (format t "~%; TERM: ~A" (setf *trm* term)) +;; (format t "~%; SUBST: ~A" (setf *subst* subst)) +;; (format t "~%; Unifiable: ") (unless (prin1 (unify-p pattern* term subst)) (break)) + ) + (unify pattern* term subst ->* subst) + (when (and (or (eq cond t) (funcall cond pattern value subst)) ;CHECK ORDER OF UNEMBEDDED REWRITE + (term-subsort-p value* pattern* subst)) + (pushnew-unless-nil w *rewrites-used*) + (dolist (var (rewrite-new-value-variables rewrite)) + (let ((v (make-variable (variable-sort var)))) + (setf subst (bind-variable-to-term var v subst)) + (push v *frozen-variables*))) + (instantiate value* subst -> term*) + (when (trace-rewrite?) + (format t "~%; REWRITE-COMPOUND-BY-RULE rewrote it to~%; ~A" (term-to-lisp term* subst)) + (format t "~%; by ~A -> ~A." pattern* value*)) + (return-from rewrite-compound-by-rule term*)))))) + (when (trace-rewrite?) + (format t "~%; REWRITE-COMPOUND-BY-RULE failed to rewrite it.")) + none) + +(defun rewrite-list (term subst) + (rewrite-list-by-rule term subst (symbol-count term subst))) + +(defun rewrite-list-by-rule (term subst symbol-count) + (prog-> + (retrieve-generalization-entries term subst #'tme-rewrites ->* e rewrites) + (declare (ignore e)) + (dolist rewrites ->* rewrite) + (rewrite-row rewrite -> w) + (when (implies w (and (eq t (context-subsumes? (row-context-live? w) *rewriting-row-context*)) (not (row-hint-p w)))) + (rewrite-condition rewrite -> cond) + (rewrite-pattern rewrite -> pattern) + (rewrite-value rewrite -> value) + (rewrite-pattern-symbol-count rewrite -> pattern-symbol-count) + (rewrite-patterns-and-values + pattern + value + pattern-symbol-count + (rewrite-embeddings rewrite) + symbol-count + ->* pattern* value*) + (unify pattern* term subst ->* subst) + (when (and (or (eq cond t) (funcall cond pattern value subst)) ;CHECK ORDER OF UNEMBEDDED REWRITE + (term-subsort-p value* pattern* subst)) + (pushnew-unless-nil w *rewrites-used*) + (dolist (var (rewrite-new-value-variables rewrite)) + (let ((v (make-variable (variable-sort var)))) + (setf subst (bind-variable-to-term var v subst)))) + (instantiate value* subst -> term*) + (return-from rewrite-list-by-rule + term*)))) + none) + +(defvar *rewrite-count-warning* t) + +(defmacro rewrite-*most (appl-code) + `(block rewrite-*most + (let ((term original-term) (count 0)) + (loop + (when *rewrite-count-warning* + (when (and (eql 0 (rem count 1000)) (not (eql 0 count))) + (warn "~A has been rewritten ~D times;~%value now is ~A." (term-to-lisp original-term subst) count (term-to-lisp term subst)))) + (incf count) + (dereference + term subst + :if-variable (return-from rewrite-*most term) + :if-constant (cond + ((or (eq true term) (eq false term)) + (return-from rewrite-*most term)) + (t + (let ((result (rewrite-constant term))) + (cond + ((neq none result) + (setf term result)) + (t + (return-from rewrite-*most term)))))) + :if-compound (cond + ((member term fully-rewritten-compounds :test #'eq) + (return-from rewrite-*most term)) + (t + ,appl-code))))))) + +(defun eq-args (term args) + (dereference + term nil + :if-compound-cons (and (eql (carc term) (first args)) + (eql (cdrc term) (second args))) + :if-compound-appl (eq (argsa term) args))) + +(defun rewrite-innermost (original-term subst head-if-associative) + ;; requires that original-term be fully dereferenced IF REWRITE CACHE IS USED + ;; (otherwise, input-outputs of dereferencing put into rewrite cache) + (rewrite-*most + (let ((head (head term)) + (args (args term)) + args*) + (cond + ((or (null args) + (eq args (setf args* (let ((*redex-path* (list* nil head *redex-path*))) + (rewrite-list-innermost + args subst + (if (function-associative head) head nil) + (function-polarity-map head)))))) + ) + (t + (setf term (fancy-make-compound* head args*)))) + (dereference term subst) + (cond + ((not (and (compound-p term) ;fancy-make-compound changed it? + (eq (head term) head) + (eq-args term args*))) + (when (eq :top head-if-associative) + (setf head-if-associative nil))) + ((and (eq :top head-if-associative) + (progn (setf head-if-associative nil) t) + (compound-p term) + (eq (head term) head) + (eq-args term args)) + (return-from rewrite-*most term)) + ((and head-if-associative (eq head head-if-associative)) + (return-from rewrite-*most term)) + (t + (let ((result (rewrite-compound term subst head))) + (cond + ((neq none result) + (setf term result)) + (t + (pushnew term fully-rewritten-compounds :test #'eq) + (return-from rewrite-*most term))))))))) + +(defun rewrite-outermost (original-term subst head-if-associative) + ;; requires that original-term be fully dereferenced IF REWRITE CACHE IS USED + ;; (otherwise, input-outputs of dereferencing put into rewrite cache) + (rewrite-*most + (let ((head (head term))) + (cond + ((and head-if-associative (eq head head-if-associative)) + (let ((args (args term)) args*) + (cond + ((or (null args) + (eq args (setf args* (let ((*redex-path* (list* nil head *redex-path*))) + (rewrite-list-outermost + args subst + (if (function-associative head) head nil) + (function-polarity-map head)))))) + (return-from rewrite-*most term)) + (t + (setf term (fancy-make-compound* head args*)))))) + (t + (let ((result (rewrite-compound term subst head))) + (cond + ((neq none result) + (setf term result)) + (t + (let ((args (args term)) args*) + (cond + ((or (null args) + (eq args (setf args* (rewrite-list-outermost + args subst + (if (function-associative head) head nil) + (function-polarity-map head))))) + (return-from rewrite-*most term)) + (t + (setf term (fancy-make-compound* head args*))))))))))))) + +(defun rewrite-list-innermost (terms subst head-if-associative polarity-map &optional rewrite-alist) + ;; rewrite nonempty list of terms, using innermost simplification first + (let* ((x (first terms)) + (newly-simplified nil) + (x* (let ((v (assoc x rewrite-alist :test (lambda (x y) (equal-p x y subst))))) + (cond + (v + (cdr v)) + (t + (setf newly-simplified t) + (set-redex-polarity (map-polarity (first polarity-map) (redex-polarity (cddr *redex-path*)))) + (rewrite-innermost x subst head-if-associative))))) + (y (rest terms))) + (lcons x* + (rewrite-list-innermost y subst head-if-associative (rest polarity-map) + (if newly-simplified + (acons x x* rewrite-alist) + rewrite-alist)) + terms))) + +(defun rewrite-list-outermost (terms subst head-if-associative polarity-map) + ;; rewrite nonempty list of terms, using outermost simplification first + (let* ((x (first terms)) + (x* (progn + (set-redex-polarity (map-polarity (first polarity-map) (redex-polarity (cddr *redex-path*)))) + (rewrite-outermost x subst head-if-associative)))) + (cond + ((neql x* x) + (cons x* (rest terms))) + (t + (let ((y (rest terms))) + (cond + ((null y) + terms) + (t + (let ((y* (rewrite-list-outermost y subst head-if-associative (rest polarity-map)))) + (if (eq y* y) terms (cons x* y*)))))))))) + +(defun ac-inverse-rule-p (pattern value cond subst) + (and + (eq cond t) + (ground-p value subst) + (dereference + pattern subst + :if-compound (let ((f (head pattern))) + (and + (function-associative f) + (function-commutative f) + (let ((args (args pattern))) + (and + (eql 2 (length args)) + (let ((arg1 (first args)) (arg2 (second args))) + (dereference2 + arg1 arg2 subst + :if-variable*compound (let ((g (head arg2))) + (and + (eql (function-arity g) 1) + (equal-p arg1 (arg1 arg2) subst) + (list f g value))) + :if-compound*variable (let ((g (head arg1))) + (and + (eql (function-arity g) 1) + (equal-p arg2 (arg1 arg1) subst) + (list f g value)))))))))))) + +(defun apply-ac-inverse-rule (args f g e subst) + ;; f(x,g(x)) -> e + (apply-ac-inverse-rule* (count-arguments f args subst) f g e subst)) + +(defun apply-ac-inverse-rule* (terms-and-counts f g e subst) + (prog-> + (dolist terms-and-counts ->* tc) + (when (> (tc-count tc) 0) + (tc-term tc -> term) + (when (dereference term subst :if-compound (eq g (head term))) + (recount-arguments f + (list* (make-tc term -1) + (make-tc (arg1 term) -1) + (make-tc e 1) + terms-and-counts) + subst + -> new-terms-and-counts) + (when (loop for tc in new-terms-and-counts + never (< (tc-count tc) 0)) + (return-from apply-ac-inverse-rule* + (or + (apply-ac-inverse-rule* new-terms-and-counts f g e subst) + (let ((args nil)) + (prog-> + (dolist new-terms-and-counts ->* tc) + (setf args (consn (tc-term tc) args (tc-count tc)))) + (make-a1-compound* f nil args)))))))) + nil) + +;;; rewrite.lisp EOF diff --git a/src/row-contexts.lisp b/src/row-contexts.lisp new file mode 100644 index 0000000..8e4700d --- /dev/null +++ b/src/row-contexts.lisp @@ -0,0 +1,184 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: row-contexts.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2008. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; assertions ordinarily go into root context +;;; assumptions and negated conjectures go into (current-row-context) +;;; inferred rows go into the maximum of the contexts of the rows they're inferred from + +;;; add assert-context-type snark option? +;;; add assume-context-type snark option? + +(defvar *root-row-context*) +(defvar *current-row-context*) + +(defmacro root-row-context () + `*root-row-context*) + +(defmacro current-row-context () + `*current-row-context*) + +(defun initialize-row-contexts () + (setf (root-row-context) (make-feature :name '#:root-row-context :children-incompatible t)) + (setf (current-row-context) (make-feature :parent (root-row-context) :children-incompatible t)) + nil) + +(definline context-parent (c) + (feature-parent c)) + +(definline context-live? (c) + (feature-live? c)) + +(defun print-row-context-tree () + (print-feature-tree :node (root-row-context))) + +(defun the-row-context (context &optional action) + (cond + ((or (eq :root context) (eql 1 context)) + (root-row-context)) + ((eq :current context) + (current-row-context)) + (t + (the-feature context action)))) ;should verify that it's really a row-context, not just a feature + +(defun make-row-context (&key name parent (children-incompatible t)) + (make-feature :name name + :children-incompatible children-incompatible + :parent (if parent (the-row-context parent 'error) (current-row-context)))) + +(defun delete-row-context (context) + (when (setf context (the-row-context context 'warn)) + (cond + ((eq (root-row-context) context) + (warn "Cannot delete root row context ~A." context)) + (t + (when (eq (current-row-context) context) + (let ((parent (context-parent context))) + (setf (current-row-context) parent) + (warn "Deleting current row context; now in parent row context ~A." parent))) + (delete-feature context) + (delete-rows :test (lambda (row) (not (row-context-live? row)))) + t)))) + +(defun in-row-context (context) + (setf context (the-row-context context 'error)) + (setf (current-row-context) context)) + +(defun push-row-context (&key name (children-incompatible t)) + (setf (current-row-context) (make-row-context :name name :children-incompatible children-incompatible))) + +(defun pop-row-context () + (let* ((context (current-row-context)) + (parent (context-parent context))) + (cond + ((null parent) + (warn "Cannot delete root row context ~A." context)) + (t + (setf (current-row-context) parent) + (delete-row-context context) + parent)))) + +(defun new-row-context (&key name (children-incompatible t)) + (pop-row-context) + (push-row-context :name name :children-incompatible children-incompatible)) + +;;; when partitions are used +;;; row-context is represented as list of elements of the form +;;; (partition-id . row-context) + +(defun the-row-context2 (context partitions) + ;; (use-partitions?) is either nil (partitions are not being used) + ;; or a list of partition ids + (setf context (the-row-context context 'error)) + (let ((all-partitions (use-partitions?))) + (cond + (all-partitions + (mapcar (lambda (part) + (if (member part all-partitions) + (cons part context) + (error "~A is not a partition." part))) + (mklist partitions))) + (t + context)))) + +(defun row-context-live? (row) + (let ((context (row-context row))) + (cond + ((use-partitions?) + (mapcan (lambda (pcd) + (let* ((part (car pcd)) + (cd (cdr pcd)) + (cd* (context-live? cd))) + (when cd* + (list (if (eq cd cd*) pcd (cons part cd*)))))) + context)) + (t + (context-live? context))))) + +(defun context-intersection-p (x y) + (cond + ((use-partitions?) + (mapcan (lambda (pcd) + (let* ((part (car pcd)) + (cd (cdr pcd)) + (cd* (feature-union (cdr (assoc part x)) cd))) + (when cd* + (list (if (eq cd cd*) pcd (cons part cd*)))))) + y)) + (t + (feature-union x y)))) + +(defun context-subsumes? (x y) + (cond + ((use-partitions?) + (let ((w (mapcan (lambda (pcd) + (let* ((part (car pcd)) + (cd (cdr pcd)) + (v (cdr (assoc part x)))) + (cond + ((null v) + (list pcd)) + (t + (let ((cd* (feature-subsumes? v cd))) + (cond + ((null cd*) + (list pcd)) + ((eq t cd*) + nil) + (t + (list (cons part cd*))))))))) + y))) + (cond + ((null w) ;x always includes y + t) + ((equal x w) ;x never includes y + nil) + (t ;x partly includes y + w)))) + (t + (feature-subsumes? x y)))) + +;;; *rewriting-row-context* is rebound around the code for rewriting to +;;; restrict what rewrites are available and thus prevent application of +;;; a rewrite to a row in a lower context + +(defvar *rewriting-row-context* nil) + +;;; row-contexts.lisp EOF diff --git a/src/rows.lisp b/src/rows.lisp new file mode 100644 index 0000000..27b277f --- /dev/null +++ b/src/rows.lisp @@ -0,0 +1,387 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: rows.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *rowsets*) +(defvar *rows*) +(defvar *row-count* 0) +(defvar *number-of-rows* 0) +(defvar *row-names*) +(declaim (type integer *row-count* *number-of-rows*)) + +(defun uninitialized (slot-name) + (error "Value of row slot ~A was not supplied to make-row." slot-name)) + +(defstruct (row + (:constructor make-row0) + (:print-function print-row3)) + (number nil) + (wff nil) + (constraints nil) ;alist of theory names and wffs + (answer false) + (reason (uninitialized 'reason)) + (hints-subsumed nil) ;hint rows that are backward subsumed by this row + (context (uninitialized 'context)) ;row was added to/deleted from this pair of contexts + (children nil) + (rewrites nil) ;list of rewrites formed from this row + (supported nil) + (sequential nil) ;only leftmost literal usable + (positive-or-negative none) + (subsumption-mark nil) + (status nil) + (agenda-entries nil) + (level0 nil) ;computed and set by row-level function + (wff-symbol-counts0 nil) + (selections-alist nil) + (plist nil)) ;property list for more properties + +(define-plist-slot-accessor row :documentation) +(define-plist-slot-accessor row :author) +(define-plist-slot-accessor row :source) +(define-plist-slot-accessor row :name) +(define-plist-slot-accessor row :conc-name) +(define-plist-slot-accessor row :input-wff) + +(defun row-wff-symbol-counts (row) + (or (row-wff-symbol-counts0 row) + (setf (row-wff-symbol-counts0 row) (wff-symbol-counts (row-wff row))))) + +(defun row-name-or-number (row) + (or (row-name row) (row-number row))) + +(defmacro make-row (&rest args) + (let ((args0 nil) args0-last + (plist nil) plist-last + (v (gensym))) + (do ((l args (cddr l))) + ((endp l)) + (cond + ((member (first l) '(:documentation :author :source :name :conc-name :input-wff)) + (collect `(let ((,v ,(second l))) (if ,v (list ,(first l) ,v) nil)) plist)) + (t + (collect (first l) args0) + (collect (second l) args0)))) + (when plist + (collect :plist args0) + (collect (if (rest plist) (cons 'nconc plist) (first plist)) args0)) + `(prog1 + (make-row0 ,@args0) + (incf *row-count*)))) + +(defun initialize-rows () + ;; row structures can be stored in sets called rowsets + ;; *rowsets* is a matrix that stores all of the rowsets + ;; each row-index is (row-number row-defstruct) + ;; each column is one of the rowsets + ;; (the column-index is arbitrary because they are not accessed by number) + ;; the value of each entry is the row-defstruct + (setf *rowsets* (make-sparse-matrix)) + (setf *rows* (make-rowset)) + (setf *row-names* (make-hash-table)) + nil) + +(defun row-given-p (row) + (eq :given (row-status row))) + +(defun row-deleted-p (row) + (eq :deleted (row-status row))) + +(defun row-hint-p (row) + (eq 'hint (row-reason row))) + +(defun row-input-p (row) + (= 0 (row-level row))) + +(defun row-nonassertion-p (x) + (when (row-p x) + (setf x (row-reason x))) + (if (consp x) + (some #'row-nonassertion-p (rest x)) + (member x '(assumption negated_conjecture)))) + +(defun row-from-conjecture-p (x) + (when (row-p x) + (setf x (row-reason x))) + (if (consp x) + (some #'row-from-conjecture-p (rest x)) + (member x '(negated_conjecture)))) + +(defun row-parents (row) + (rows-in-reason (row-reason row))) + +(defun row-parent (row) + (let ((l (row-parents row))) + (cl:assert (and l (null (rest l)))) + (first l))) + +(defun row-embedding-p (row) + (let ((reason (row-reason row))) + (and (consp reason) + (eq 'embed (first reason)) + (or (third reason) t)))) + +(defun row-rewrites-used (row) + (let ((reason (row-reason row))) + (cond + ((and (consp reason) (eq 'rewrite (first reason))) + (rrest reason)) + (t + nil)))) + +(defun (setf row-rewrites-used) (value row) + (let ((reason (row-reason row))) + (cond + ((and (consp reason) (eq 'rewrite (first reason))) + (cl:assert (tailp (rrest reason) value)) + (setf (row-reason row) (list* 'rewrite (second reason) value))) + (value + (setf (row-reason row) (list* 'rewrite reason value)))) + value)) + +(defun row-level (row) + (or (row-level0 row) + (setf (row-level0 row) + (labels + ((row-level* (reason) + (ecase (if (consp reason) (first reason) reason) + ((resolve hyperresolve negative-hyperresolve ur-resolve ur-pttp paramodulate combine) + (+ 1 (loop for parent in (rest reason) + when (row-p parent) + maximize (row-level parent)))) + ((rewrite factor condense embed case-split purify) + ;; ignore level of rewriters + (let ((parent (second reason))) + (if (row-p parent) + (row-level parent) + (row-level* parent)))) + ((assertion assumption negated_conjecture hint) + 0) + (and + (loop for reason in (rest reason) + minimize (row-level* reason)))))) + (row-level* (row-reason row)))))) + +(defun row-clause-p (row) + (clause-p (row-wff row))) + +(defun row-unit-p (row) + (literal-p (row-wff row))) + +(defun row-bare-p (row) + (and (eq false (row-answer row)) + (not (row-constrained-p row)) +;; (null (row-dp-alist row)) + )) + +(defun row-bare-unit-p (row) + (and (row-unit-p row) + (row-bare-p row))) + +(defun row-positive-p (row) + (let ((v (row-positive-or-negative row))) + (when (eq none v) + (setf v (setf (row-positive-or-negative row) (wff-positive-or-negative (row-wff row))))) + (eq :pos v))) + +(defun row-negative-p (row) + (let ((v (row-positive-or-negative row))) + (when (eq none v) + (setf v (setf (row-positive-or-negative row) (wff-positive-or-negative (row-wff row))))) + (eq :neg v))) + +(defun row-variables (row &optional vars) + (setf vars (variables (row-wff row) nil vars)) + (setf vars (variables (row-constraints row) nil vars)) + (setf vars (variables (row-answer row) nil vars)) + vars) + +(defun row-supported-inheritably (row) + (let ((supported (row-supported row))) + (and supported + (neq :uninherited supported)))) + +(defun row-sequential-inheritably (row) + (let ((sequential (row-sequential row))) + (and sequential + (neq :uninherited sequential)))) + +(defun make-rowset (&optional (rowsets *rowsets*)) + (if rowsets + (let ((n (nonce))) + (values (setf (sparse-matrix-column rowsets n) t) n)) + (make-sparse-vector))) + +(defun rowset-size (rowset) + (sparse-vector-count rowset)) + +(defun rowset-insert (row rowset) + (let ((num (row-number row))) + (and (not (sparef rowset num)) + (setf (sparef rowset num) row)))) + +(defun rowset-delete (row rowset) + (when rowset + (let ((num (row-number row))) + (setf (sparef rowset num) nil)))) + +(defun rowsets-delete (row &optional (rowsets *rowsets*)) + ;; delete row from every rowset it is in + (when rowsets + (let ((num (row-number row))) + (setf (sparse-matrix-row rowsets num) nil)))) + +(defun rowsets-delete-column (rowset) + (when rowset + (let ((type (snark-sparse-array::sparse-vector-type rowset))) + (when (eq 'snark-sparse-array::column (first type)) + (setf (sparse-matrix-column (second type) (third type)) nil))))) + +(defun rowset-empty? (rowset) + (or (null rowset) (eql 0 (sparse-vector-count rowset)))) + +(defun map-rows-in-reason (fn x) + (cond + ((consp x) + (map-rows-in-reason fn (car x)) + (map-rows-in-reason fn (cdr x))) + ((row-p x) + (funcall fn x) + nil))) + +(defun rows-in-reason (x &optional rows) + (cond + ((consp x) + (rows-in-reason (cdr x) (rows-in-reason (car x) rows))) + ((row-p x) + (adjoin x rows)) + (t + rows))) + +(defun row-ancestry-rowset (rows) + (let ((rowset (make-rowset nil))) + (labels + ((row-ancestry-rowset* (x) + (when (and (row-p x) (rowset-insert x rowset)) + (dolist (x (rows-in-reason (row-rewrites-used x) (rows-in-reason (row-reason x)))) + (row-ancestry-rowset* x))))) + (dolist (row rows) + (row-ancestry-rowset* row)) + rowset))) + +(defun row-ancestry (row) + (let ((result nil) result-last) + (prog-> + (map-sparse-vector (row-ancestry-rowset (list row)) ->* row) + (collect row result)) + result)) + +(defun row (name-or-number &optional not-found-action) + ;; Return the row named or numbered by the argument. + ;; If error-p is true, it is an error if the row cannot be found; + ;; otherwise, nil is returned if the row cannot be found. + (cond + ((row-p name-or-number) ;also allow a row itself as argument + name-or-number) + ((numberp name-or-number) + (when (minusp name-or-number) + (setf name-or-number (+ *number-of-rows* name-or-number 1))) + (or (sparef *rows* name-or-number) + (and not-found-action (funcall not-found-action "There is no row numbered ~D." name-or-number)))) + (t + (let ((number (gethash name-or-number *row-names*))) + (or (and number (sparef *rows* number)) + (and not-found-action (funcall not-found-action "There is no row named ~S." name-or-number))))))) + +(defun mapnconc-rows (cc &key (rowset *rows*) min max reverse test) + (when rowset + (let ((result nil) result-last) + (prog-> + (map-sparse-vector rowset :min min :max max :reverse reverse ->* row) + (when (implies test (funcall test row)) + (cond + ((null cc) + (collect row result)) + (t + (ncollect (funcall cc row) result))))) + result))) + +(defun map-rows (cc &key (rowset *rows*) min max reverse test) + (when rowset + (if (null test) + (map-sparse-vector cc rowset :min min :max max :reverse reverse) + (prog-> + (map-sparse-vector rowset :min min :max max :reverse reverse ->* row) + (when (funcall test row) + (funcall cc row)))))) + +(defun rows (&key (rowset *rows*) min max reverse test collect) + (when rowset + (let ((result nil) result-last) + (prog-> + (map-sparse-vector rowset :min min :max max :reverse reverse ->* row) + (when (implies test (funcall test row)) + (collect (if collect (funcall collect row) row) result))) + result))) + +(defun last-row () + (last-sparef *rows*)) + +(defun set-row-number (row number) + (cl:assert (null (row-number row))) + (setf (row-number row) number) + (let (v) + (cond + ((setf v (row-name row)) + (setf (row-name row) nil) + (name-row row v)) + ((setf v (row-conc-name row)) + (name-row row (intern (to-string v number))))))) + +(defun name-row (row-id name) + (when (can-be-row-name name 'warn) + (let* ((row (if (row-p row-id) row-id (row row-id 'error))) + (number (row-number row))) + (cl:assert (integerp number)) + (let ((number2 (gethash name *row-names*))) + (when (and number2 (neql number number2)) + (warn "Naming row ~D ~A, but row ~D is already named ~A. Reusing the name." number name number2 name))) + (let ((name2 (row-name row))) + (when (and name2 (neql name name2)) + (warn "Naming row ~D ~A, but row ~D is already named ~A. Renaming the row." number name number name2))) + (setf (gethash name *row-names*) number) + (setf (row-name row) name)))) + +(defun print-ancestry (row &key more-rows format) + (prog-> + (map-rows :rowset (row-ancestry-rowset (cons row more-rows)) ->* row) + (terpri) + (when more-rows + (princ (if (member row more-rows) "*" " "))) + (print-row row :format format))) + +(defun print-rows (&key (rowset *rows*) min max reverse (test (print-rows-test?)) ancestry format) + (if ancestry + (print-rows :rowset (row-ancestry-rowset (rows :rowset rowset :min min :max max :test test)) :reverse reverse :format format) + (prog-> + (map-rows :rowset rowset :min min :max max :reverse reverse :test test ->* row) + (terpri) + (print-row row :format format)))) + +;;; rows.lisp EOF diff --git a/src/simplification-ordering.lisp b/src/simplification-ordering.lisp new file mode 100644 index 0000000..e8d9181 --- /dev/null +++ b/src/simplification-ordering.lisp @@ -0,0 +1,356 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: simplification-ordering.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim + (special + *manual-ordering-results* + *negative-hyperresolution*)) + +(defun manual-ordering-compare-terms (x y subst) + (setf x (renumber x subst)) + (setf y (renumber y subst)) + (let (v) + (cond + ((setf v (assoc (list x y) *manual-ordering-results* :test #'subsumed-p)) + (cdr v)) + ((setf v (assoc (list y x) *manual-ordering-results* :test #'subsumed-p)) + (opposite-order (cdr v))) + (t + (loop + (format t "~%You must answer the following simplification-ordering question:") + (format t "~%~S~% is < or > or ? to~%~S" x y) + (format t "~%Answer =") + (setf v (read)) + (cond + ((member v '(< > ?)) + (setf *manual-ordering-results* (acons (list x y) v *manual-ordering-results*)) + (return v)) + (t + (format t "~&You must answer < or > or ?.")))))))) + +(defun definition-p (x y) + (and (compound-p x) + (let ((args nil)) + (and (not (function-occurs-p (head x) y nil)) + (dolist (arg (args x) t) + (cond + ((and (variable-p arg) + (top-sort? (variable-sort arg)) + (not (member arg args :test #'eq))) + (push arg args)) + (t + (return nil)))) + (member (instantiating-direction1 args (variables y)) '(> <>)))))) + +(defun simplification-ordering-compare-terms0 (x y subst testval) + (let ((x x) (y y)) + (when (dereference2 + x y subst + :if-constant*constant (and (constant-boolean-valued-p x) (constant-boolean-valued-p y)) + :if-constant*compound (and (function-boolean-valued-p (setf y (head y))) (constant-boolean-valued-p x)) + :if-compound*constant (and (function-boolean-valued-p (setf x (head x))) (constant-boolean-valued-p y)) + :if-compound*compound (and (function-boolean-valued-p (setf x (head x))) (function-boolean-valued-p (setf y (head y))) (not (eq x y)))) + (return-from simplification-ordering-compare-terms0 + (symbol-ordering-compare x y)))) + (case (use-term-ordering?) + (:rpo + (rpo-compare-terms-top x y subst testval)) + (:kbo + (kbo-compare-terms x y subst testval)) + ((nil :manual) + (cond + ((equal-p x y subst) + '=) + ((occurs-p x y subst) + '<) + ((occurs-p y x subst) + '>) + ((use-term-ordering?) + (manual-ordering-compare-terms x y subst)) + (t + '?))) + (otherwise + (funcall (use-term-ordering?) x y subst testval)))) + +(defun simplification-ordering-compare-terms1 (x y &optional subst testval warn row) + (let ((dir (simplification-ordering-compare-terms0 x y subst testval))) + (when warn + (when (and (print-rewrite-orientation?) + (not (member (print-rows-when-derived?) '(nil :signal))) + (member dir '(< >)) + row (row-number row)) + (with-clock-on printing + (terpri-comment) + (format t "Oriented ~A ~A " + (row-name-or-number row) + (cond + ((eq '> dir) "left-to-right") + ((eq '< dir) "right-to-left"))))) + (when (and (print-unorientable-rows?) + (not (member (print-rows-when-derived?) '(nil :signal))) + (not (member dir '(< > =)))) + (with-clock-on printing + (terpri-comment) + (cond + ((and row (row-number row)) + (format t "Could not orient ~A " (row-name-or-number row))) + (t + (format t "Could not orient ~A=~A " x y)))))) + dir)) + +(defun simplification-ordering-compare-terms (x y &optional subst testval warn row) + (with-clock-on ordering + (simplification-ordering-compare-terms1 x y subst testval warn row))) + +(defvar *simplification-ordering-compare-equality-arguments-hash-table*) + +(defun initialize-simplification-ordering-compare-equality-arguments-hash-table () + (setf *simplification-ordering-compare-equality-arguments-hash-table* + (if (test-option2?) + (make-hash-table) + nil))) + +(defun simplification-ordering-compare-equality-arguments (equality subst &optional warn row) + (if (test-option2?) + (let* ((table *simplification-ordering-compare-equality-arguments-hash-table*) + (v (gethash equality table))) + (cond + ((null v) + (setf v (let ((args (args equality))) + (simplification-ordering-compare-terms + (first args) (second args) subst nil warn row))) + (cl:assert v) + (when (or (null subst) (eq '? v)) + (setf (gethash equality table) v)) + v) + ((or (null subst) (neq '? v)) + v) + (t + (let ((args (args equality))) + (simplification-ordering-compare-terms + (first args) (second args) subst nil warn row))))) + (let ((args (args equality))) + (simplification-ordering-compare-terms + (first args) (second args) subst nil warn row)))) + +(defun simplification-ordering-greaterp (x y subst) + (eq '> (simplification-ordering-compare-terms x y subst '>))) + +(defun instantiating-direction1 (xvars yvars) + (let ((x-has-var-not-in-y (dolist (xv xvars) + (when (dolist (yv yvars t) + (when (eql xv yv) + (return nil))) + (return t)))) + (y-has-var-not-in-x (dolist (yv yvars) + (when (dolist (xv xvars t) + (when (eql xv yv) + (return nil))) + (return t))))) + (cond + (x-has-var-not-in-y + (cond + (y-has-var-not-in-x + nil) + (t + '>))) + (y-has-var-not-in-x + '<) + (t + '<>)))) + +(defun instantiating-direction (x y subst) + ;; returns <> x and y have the same variables + ;; returns > if y's variables are proper subset of x's + ;; returns < if x's variables are proper subset of y's + ;; returns nil otherwise + (with-clock-on ordering + (instantiating-direction1 (variables x subst) (variables y subst)))) + + +(defun literal-ordering-a (atom1 polarity1 atom2 polarity2 &optional subst testval) + (declare (ignore polarity1 polarity2)) + (simplification-ordering-compare-terms atom1 atom2 subst testval)) + +(defun literal-ordering-p (atom1 polarity1 atom2 polarity2 &optional subst testval) + ;; positive literals are ordered; no ordering between negative literals + ;; negative literals are greater than positive literals + (case polarity1 + (:pos + (case polarity2 + (:pos + (simplification-ordering-compare-terms atom1 atom2 subst testval)) + (:neg + '<) + (otherwise + '?))) + (:neg + (case polarity2 + (:pos + '>) + (otherwise + '?))) + (otherwise + '?))) + +(defun literal-ordering-n (atom1 polarity1 atom2 polarity2 &optional subst testval) + ;; negative literals are ordered; no ordering between positive literals + ;; positive literals are greater than negative literals + (case polarity1 + (:neg + (case polarity2 + (:neg + (simplification-ordering-compare-terms atom1 atom2 subst testval)) + (:pos + '<) + (otherwise + '?))) + (:pos + (case polarity2 + (:neg + '>) + (otherwise + '?))) + (otherwise + '?))) + + +(defun literal-is-not-dominated-in-clause-p (orderfun atom polarity clause subst) + (prog-> + (map-atoms-in-clause clause ->* atom2 polarity2) + (when (and (neq atom atom2) + (not (do-not-resolve atom2)) + (eq '< (funcall orderfun atom polarity atom2 polarity2 subst '<))) + (return-from literal-is-not-dominated-in-clause-p nil))) + t) + +(defun literal-is-not-dominating-in-clause-p (orderfun atom polarity clause subst) + (prog-> + (map-atoms-in-clause clause ->* atom2 polarity2) + (when (and (neq atom atom2) + (not (do-not-resolve atom2)) + (eq '> (funcall orderfun atom polarity atom2 polarity2 subst '>))) + (return-from literal-is-not-dominating-in-clause-p nil))) + t) + +(defun literal-satisfies-ordering-restriction-p (orderfun atom polarity wff &optional subst n) + (implies (clause-p wff) + (literal-is-not-dominated-in-clause-p + orderfun + (if (and subst n) (instantiate atom n) atom) + polarity + (if (and subst n) (instantiate wff n) wff) + subst))) + + +(defun selected-atoms-in-row (row orderfun) + ;; which atoms in row are selected by orderfun before considering instantiation + (let* ((selections (row-selections-alist row)) + (v (assoc (or orderfun 'no-literal-ordering) selections))) + (cond + (v + (cdr v)) + (t + (let ((l nil)) + (cond + ((row-sequential row) ;if sequential, select only the first atom + (prog-> + (map-atoms-in-wff (row-wff row) ->* atom polarity) + (unless (do-not-resolve atom) + (setf l (list (list atom polarity))) + (return-from prog->)))) + ((or (null orderfun) ;else if no orderfun or row is nonclausal, + (not (clause-p (row-wff row)))) ;select all of the atoms + (setf l (remove-if #'do-not-resolve (atoms-in-wff2 (row-wff row)) :key #'first))) + (t ;else use orderfun on literals of clause and + (prog-> ;return eq subset of (selected-atoms-in-row row nil) + (dolist (selected-atoms-in-row row nil) ->* x) + (values-list x -> atom polarity) + (cond + ((null l) + (setf l (list x))) + ((dolist (y l t) ;select atom if it is not dominated by any atom2 + (mvlet (((list atom2 polarity2) y)) + (when (eq '> (funcall orderfun atom2 polarity2 atom polarity nil '>)) + (return nil)))) + (setf l (nconc + (delete-if (lambda (y) ;deselect every atom2 that is dominated by atom + (mvlet (((list atom2 polarity2) y)) + (eq '< (funcall orderfun atom2 polarity2 atom polarity nil '<)))) + l) + (list x)))))))) + (setf (row-selections-alist row) (acons (or orderfun 'no-literal-ordering) l selections)) + l))))) + +(defun selected-atom-in-row-p (atom polarity row orderfun &optional subst n atom*) + (selected-atom-p atom polarity (selected-atoms-in-row row orderfun) orderfun subst n atom*)) + +(defun selected-atom-p (atom polarity selected-atoms orderfun &optional subst n atom*) + ;; selected-atoms was computed by (selected-atoms-in-row row orderfun) + ;; to list which atoms are selected before considering instantiation + ;; both (p ?x ?y) and (p ?y ?x) might be in selected-atoms, + ;; but only one might be acceptable to selected-atom-p when ?x and ?y are instantiated + (let ((atom&polarity (literal-member-p atom polarity selected-atoms))) + (and atom&polarity ;is (atom polarity) in selected-atoms? + (implies (and orderfun subst) + (dolist (x selected-atoms t) ;is it still undominated after applying subst? + (unless (eq atom&polarity x) + (let ((atom2 (first x)) (polarity2 (second x))) + (when (eq '> (funcall orderfun + (instantiate atom2 n) + polarity2 + (setq-once atom* (instantiate atom n)) + polarity + subst + '>)) + (return nil))))))))) + +(defun selected-atoms-in-hyperresolution-electrons-p (electrons subst) + (prog-> + (hyperresolution-orderfun -> orderfun) + (hyperresolution-electron-polarity -> polarity) + (+ (length electrons) 1 -> k) + (dolist electrons t ->* x) + (values-list x -> rowk atomk atomk*) + (selected-atoms-in-row rowk orderfun -> selected-atoms-in-rowk) + (unless (selected-atom-p atomk polarity selected-atoms-in-rowk orderfun subst k atomk*) + (return nil)) + (decf k))) + + +(defmethod theory-rewrite (wff (theory (eql 'ordering))) + wff) + +(defmethod theory-simplify (wff (theory (eql 'ordering))) + ;; no decision procedure: + ;; only tests conjuncts singly + ;; only treats variables as universally quantified + (prog-> + (map-atoms-in-wff-and-compose-result wff :neg ->* atom polarity) + (declare (ignore polarity)) + (args atom -> args) + (ecase (function-name (head atom)) + (ordering> + (ecase (simplification-ordering-compare-terms (first args) (second args)) (? atom) (> true) (< false) (= false))) + (ordering>= + (ecase (simplification-ordering-compare-terms (first args) (second args)) (? atom) (> true) (< false) (= true)))))) + +;;; simplification-ordering.lisp EOF diff --git a/src/snark-pkg.lisp b/src/snark-pkg.lisp new file mode 100644 index 0000000..3e50807 --- /dev/null +++ b/src/snark-pkg.lisp @@ -0,0 +1,308 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: snark-pkg.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +;;; package definitions for snark system + +(defpackage :snark + (:use :common-lisp + :snark-lisp + :snark-deque + :snark-sparse-array + :snark-numbering + :snark-agenda + :snark-infix-reader + :snark-feature + :snark-dpll) + (:import-from :common-lisp-user #:*compile-me*) + (:shadow #:terpri) + #-gcl (:shadow #:assert #:substitute #:variable #:row #:rows) + (:export + #:*hash-dollar-package* #:*hash-dollar-readtable* #:hash-dollar-prin1 #:hash-dollar-print + #:*compile-me* + #:profile #:sprofile + #:can-be-constant-name + #:can-be-free-variable-name + #:declare-cancellation-law + #:declare-snark-option + #:derivation-subsort-forms + #:function-logical-symbol-p + #:function-symbol-p + #:input-constant-symbol + #:input-function-symbol + #:input-relation-symbol + #:input-proposition-symbol + #:input-term + #:input-wff + #:atom-with-keywords-inputter + #:set-options #:let-options + #:make-snark-system + #:map-rows + #:matches-compound ;rewrite-compiler + #:matches-constant ;rewrite-compiler + #:print-agendas + #:print-ancestry + #:print-options + #:print-rewrites + #:print-row + #:print-rows + #:print-feature-tree + #:print-row-term + #:print-sort-theory + #:print-summary + #:print-symbol-ordering + #:print-symbol-table + #:print-term + #:read-assertion-file + #:refute-file + #:do-tptp-problem #:do-tptp-problem0 #:do-tptp-problem1 + #:sort-name-p + #:sortal + #:temporal + #:term-to-lisp + #:var + + #:initialize #:assume #:prove #:hint #:closure #:proof #:proofs #:answer #:answers + #:new-prove + + #:give #:factor #:resolve #:hyperresolve #:negative-hyperresolve + #:paramodulate #:paramodulate-by #:ur-resolve #:rewrite #:condense + #:row #:rows #:name-row #:last-row #:it #:mark-as-given + #:delete-row #:delete-rows + #:assert-rewrite + + #:make-row-context #:delete-row-context #:in-row-context + #:push-row-context #:pop-row-context #:new-row-context + #:current-row-context #:root-row-context + + #:dereference + #:variable-p #:constant-p #:compound-p #:head #:args #:arg1 #:arg2 + #:make-compound #:make-compound* + #:equal-p #:unify + #:constant-sort #:variable-sort #:term-sort + #:constant-name + #:function-name #:function-arity + #:row-name #:row-number #:row-name-or-number #:row-wff #:row-answer #:row-constraints + #:row-constrained-p #:row-ancestry #:row-reason #:row-rewrites-used #:row-parents + + #:constant-documentation #:constant-author #:constant-source + #:function-documentation #:function-author #:function-source + #:sort-documentation #:sort-author #:sort-source + #:row-documentation #:row-author #:row-source #:row-input-wff + + #:answer-if + #:~ #:& + #:=> #:<=> + #:? #:?x #:?y #:?z #:?u #:?v #:?w #:_ + #:-- #:--- + + #:symbol-table-entries #:symbol-table-constant? #:symbol-table-function? #:symbol-table-relation? + + #:read-infix-term + #:initialize-operator-syntax #:declare-operator-syntax #:declare-tptp-operators + + #:assertion #:assumption #:conjecture #:negated_conjecture #:combine #:embed #:purify + + #:|cnf| #:|fof| #:|tff| ;for TPTP + #:|axiom| #:|conjecture| #:|negated_conjecture| #:|assumption| #:|hypothesis| + #:|question| #:|negated_question| + #:|type| + #:|$tType| #:|$i| #:|$o| #:|$int| #:|$rat| #:|$real| + #:|$true| #:|$false| + #:|file| + #:|include| + + #:declare-constant #:declare-proposition + #:declare-function #:declare-relation + #:declare-variable + + #:declare-ordering-greaterp + + #:declare-sort #:declare-subsort #:declare-sorts-incompatible + #:the-sort + #:sort-name + #:sort-intersection + #:subsort? #:sort-disjoint? + + #:top-sort #:top-sort-a + + #:declare-tptp-sort #:tptp-nonnumber + + #:literal-ordering-a #:literal-ordering-n #:literal-ordering-p + + #:checkpoint-theory #:uncheckpoint-theory #:restore-theory + #:suspend-snark #:resume-snark #:suspend-and-resume-snark + + #:fifo #:lifo + #:row-depth #:row-size #:row-weight #:row-level + #:row-size+depth #:row-weight+depth + #:row-size+depth+level #:row-weight+depth+level + #:row-weight-limit-exceeded #:row-weight-before-simplification-limit-exceeded + #:row-wff&answer-weight+depth #:row-neg-size+depth + #:row-priority + + #:in-language #:in-kb + #:when-system + #:has-author #:has-source #:my-source + #:has-documentation #:has-name + #:undefined + + #:declare-jepd-relations + #:declare-rcc8-relations + #:declare-time-relations + #:region #:time-interval #:time-point + #:$$date-point #:$$utime-point + #:$$date-interval #:$$utime-interval + + #:$$rcc8-dc #:$$rcc8-ec #:$$rcc8-po #:$$rcc8-tpp #:$$rcc8-ntpp #:$$rcc8-tppi #:$$rcc8-ntppi #:$$rcc8-eq + #:$$rcc8-dr #:$$rcc8-pp #:$$rcc8-p #:$$rcc8-ppi #:$$rcc8-pi #:$$rcc8-o #:$$rcc8-c + #:$$rcc8-tp #:$$rcc8-tpi + #:$$rcc8-not-tpp #:$$rcc8-not-ntpp #:$$rcc8-not-ec #:$$rcc8-not-po #:$$rcc8-not-eq #:$$rcc8-not-ntppi + #:$$rcc8-not-tppi #:$$rcc8-not-pp #:$$rcc8-not-p #:$$rcc8-not-ppi #:$$rcc8-not-pi #:$$rcc8-not-tp #:$$rcc8-not-tpi + + ;; 3 primitive temporal point-point relations + #:$$time-pp-before #:$$time-pp-equal #:$$time-pp-after + + ;; nonprimitive temporal point-point relations + #:$$time-pp-not-before #:$$time-pp-not-equal #:$$time-pp-not-after + + ;; 13 primitive temporal interval-interval relations + #:$$time-ii-before #:$$time-ii-during #:$$time-ii-overlaps #:$$time-ii-meets #:$$time-ii-starts + #:$$time-ii-finishes #:$$time-ii-equal #:$$time-ii-finished-by #:$$time-ii-started-by + #:$$time-ii-met-by #:$$time-ii-overlapped-by #:$$time-ii-contains #:$$time-ii-after + #:$$time-ii-contained-by ;alias of time-ii-during + + ;; nonprimitive temporal interval-interval relations + #:$$time-ii-starts-before #:$$time-ii-starts-equal #:$$time-ii-starts-after + #:$$time-ii-finishes-before #:$$time-ii-finishes-equal #:$$time-ii-finishes-after + #:$$time-ii-subsumes #:$$time-ii-subsumed-by + #:$$time-ii-disjoint #:$$time-ii-intersects + #:$$time-ii-not-before #:$$time-ii-not-during #:$$time-ii-not-overlaps #:$$time-ii-not-meets + #:$$time-ii-not-starts #:$$time-ii-not-finishes #:$$time-ii-not-equal + #:$$time-ii-not-finished-by #:$$time-ii-not-started-by + #:$$time-ii-not-met-by #:$$time-ii-not-overlapped-by #:$$time-ii-not-contains #:$$time-ii-not-after + #:$$time-ii-not-starts-before #:$$time-ii-not-starts-equal #:$$time-ii-not-starts-after + #:$$time-ii-not-finishes-before #:$$time-ii-not-finishes-equal #:$$time-ii-not-finishes-after + #:$$time-ii-not-subsumes #:$$time-ii-not-subsumed-by + + ;; 5 primitive temporal point-interval relations + #:$$time-pi-before #:$$time-pi-starts #:$$time-pi-during #:$$time-pi-finishes #:$$time-pi-after + #:$$time-ip-before #:$$time-ip-started-by #:$$time-ip-contains #:$$time-ip-finished-by #:$$time-ip-after + #:$$time-pi-contained-by ;alias of time-pi-during + + ;; nonprimitive temporal point-interval relations + #:$$time-pi-disjoint #:$$time-pi-intersects + #:$$time-pi-not-before #:$$time-pi-not-starts #:$$time-pi-not-during #:$$time-pi-not-finishes #:$$time-pi-not-after + #:$$time-ip-disjoint #:$$time-ip-intersects + #:$$time-ip-not-after #:$$time-ip-not-started-by #:$$time-ip-not-contains #:$$time-ip-not-finished-by #:$$time-ip-not-before + + #:$$numberp #:$$realp #:$$rationalp #:$$integerp #:$$naturalp #:$$complexp + + #:$$eq + #:$$less + #:$$lesseq + #:$$greater + #:$$greatereq + #:$$sum + #:$$product + #:$$difference + #:$$uminus + #:$$quotient + #:$$reciprocal + #:$$abs + #:$$realpart + #:$$imagpart + #:$$floor + #:$$ceiling + #:$$truncate + #:$$round + #:$$quotient_f #:$$quotient_c #:$$quotient_t #:$$quotient_r #:$$quotient_e + #:$$remainder_f #:$$remainder_c #:$$remainder_t #:$$remainder_r #:$$remainder_e + + #:$$$less #:$$$lesseq #:$$$greater #:$$$greatereq + + #:$$eqe + + #:$$quote + + #:$$cons #:$$list #:$$list* + #:$$listp +;; #:$$term-to-list #:$$list-to-term #:$$list-to-atom + + #:$$stringp #:$$string-to-list #:$$list-to-string + + #:$$bag #:$$bag* + #:$$bag-union + #:$$bagp + #:$$bag-to-list #:$$list-to-bag + + #:bag + + #:$$flat-bag #:$$flat-list #:$$empty-flat-bag #:$$empty-flat-list + + #:positive #:positive-real #:positive-rational #:positive-integer #:positive-number + #:negative #:negative-real #:negative-rational #:negative-integer #:negative-number + #:nonnegative #:nonnegative-real #:nonnegative-rational #:nonnegative-integer #:nonnegative-number + #:nonzero #:nonzero-real #:nonzero-rational #:nonzero-integer #:nonzero-number + #:nonpositive + #:zero + #:natural + + #:the-string + #:the-list + #:the-bag + #:the-number #:the-real #:the-complex + #:the-rational + #:the-integer + + #:the-positive + #:the-negative + #:the-nonpositive + #:the-nonnegative + #:the-nonzero + #:the-zero + + #:the-positive-integer + #:the-nonnegative-integer + #:the-natural + + #:*tptp-environment-variable* + #:*tptp-format* + #:*tptp-input-directory* + #:*tptp-input-directory-has-domain-subdirectories* + #:*tptp-input-file-type* + #:*tptp-output-directory* + #:*tptp-output-directory-has-domain-subdirectories* + #:*tptp-output-file-type* + + #:save-snark-system + #:with-no-output + )) + +(defpackage :snark-user + (:use :common-lisp + :snark-lisp + :snark-deque + :snark-sparse-array + :snark-dpll + :snark) + (:shadowing-import-from :snark #:assert)) + +;;; snark-pkg.lisp EOF diff --git a/src/solve-sum.lisp b/src/solve-sum.lisp new file mode 100644 index 0000000..e6e53b1 --- /dev/null +++ b/src/solve-sum.lisp @@ -0,0 +1,95 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: solve-sum.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun solve-sum (cc sum coefs &optional bounds) + ;; find xi such that 0 <= xi <= boundi and coef1*x1 + ... + coefn*xn = sum + ;; sum >= 0, each coefi > 0, each boundi >= 0, all integers + ;; |coefs| = |bounds| > 0 (bounds can also be nil) + ;; applies cc to each solution + ;; returns nil if unsolvable due to bounds + ;; (solve-sum #'print 29 '(1 5 10 25) '(4 3)) + ;; prints how to make 29 cents using at most 4 pennies and 3 nickels + (cond + ((eql 0 sum) + (funcall cc nil) ;use nil instead of final zeroes + t) + (t + (let ((c (pop coefs)) + (b (pop bounds))) + (cond + ((null coefs) + (mvlet (((values q r) (truncate sum c))) + (when (or (null b) (>= b q)) + (when (eql 0 r) + (funcall cc (list q))) + t))) + ((eql 0 b) + (solve-sum (lambda (sol) (funcall cc (cons 0 sol))) sum coefs bounds)) + (t + (let* ((k (if b (min b (truncate sum c)) (truncate sum c))) + (k1 k)) + (decf sum (* k1 c)) + (loop + (cond + ((solve-sum (lambda (sol) (funcall cc (cons k1 sol))) sum coefs bounds) + (cond + ((eql 0 k1) + (return t)) + (t + (decf k1) + (incf sum c)))) + (t + (return (neql k k1)))))))))))) + +(defun solve-sum-p (sum coefs &optional bounds) + (or (eql 0 sum) + (and (null bounds) + (member 1 coefs)) + (block it + (solve-sum (lambda (sol) + (declare (ignore sol)) + (return-from it t)) + sum coefs bounds) + nil))) + +(defun solve-sum-solutions (sum coefs &optional bounds) + (cond + ;; handle some frequent special cases first + ;; (solve-sum-solutions 1 '(1)) => ((1)) + ((and (eql 1 sum) + (null (rest coefs))) + (and (eql 1 (first coefs)) + (neql 0 (first bounds)) + '((1)))) + ;; (solve-sum-solutions 1 '(1 1)) => ((1) (0 1)) + ((and (eql 1 sum) + (null (rrest coefs)) + (eql 1 (first coefs)) + (neql 0 (first bounds)) + (eql 1 (second coefs)) + (neql 0 (second bounds))) + '((1) (0 1))) + (t + (let ((sols nil) sols-last) + (solve-sum (lambda (sol) (collect sol sols)) sum coefs bounds) + sols)))) + +;;; solve-sum.lisp EOF diff --git a/src/sorts-functions.lisp b/src/sorts-functions.lisp new file mode 100644 index 0000000..a421551 --- /dev/null +++ b/src/sorts-functions.lisp @@ -0,0 +1,81 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: sorts-functions.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; an argument-sort-alist (asa) is an alist of argument-ids and argument-sorts like +;;; ((2 . arg2-sort) (1 . arg1-sort) (t . default-arg-sort)) + +(defun asa-arg-sort (asa argid) + ;; find in asa the sort restriction for argument argid + ;; argid is an argument number or a key in the case of alist/plist functions/relations + (dolist (p asa (top-sort)) + (let ((key (car p))) + (when (or (eql argid key) (eq t key)) + (return (cdr p)))))) + +(defun input-argument-sort-alist (function l) + ;; input-argument-sort-alist inputs argument sort restrictions of the form + ;; ((2 arg2-sort) (1 arg1-sort) (t default-arg-sort)) + ;; that are recognized by can-be-argument-sort-alist-p1 + ;; + ;; it also converts old-style declarations of the form + ;; (arg1-sort arg2-sort) + ;; that are recognized by can-be-argument-sort-alist-p2 + (cond + ((null l) + nil) + ((can-be-argument-sort-alist-p1 function l) + (mapcar (lambda (p) (cons (first p) (the-sort (second p)))) l)) + ((can-be-argument-sort-alist-p2 function l) + (let ((i 0)) (mapcar (lambda (s) (cons (incf i) (the-sort s))) l))) + (t + (with-standard-io-syntax2 + (error "The sort of the argument list of ~A ~S cannot be ~S." ;not very informative + (function-kind function) (function-name function) l))))) + +(defun can-be-argument-sort-alist-p1 (function l) + (and (consp l) + (let* ((arity (function-arity function)) + (can-be-key-p (cond + ((naturalp arity) + (lambda (x) (and (integerp x) (<= 1 x arity)))) + (t + (ecase arity + (:any #'naturalp)))))) + (dotails (l l t) + (let ((p (first l))) + (unless (and (consp p) + (if (eq t (first p)) + (null (rest l)) + (funcall can-be-key-p (first p))) + (consp (rest p)) + (null (rrest p)) + (the-sort (second p))) + (return nil))))))) + +(defun can-be-argument-sort-alist-p2 (function l) + (and (consp l) + (let ((arity (function-arity function))) + (and (or (naturalp arity) (eq :any arity)) + (every (lambda (s) + (the-sort s)) + l))))) + +;;; sorts-functions.lisp EOF diff --git a/src/sorts-interface.lisp b/src/sorts-interface.lisp new file mode 100644 index 0000000..340c7bb --- /dev/null +++ b/src/sorts-interface.lisp @@ -0,0 +1,180 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: sorts-interface.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; this file implements SNARK's sort system based on snark-features +;;; interfacing to a different sort system in SNARK should be possible by replacing this file + +(defvar *top-sort*) + +(definline top-sort-name () + 'top-sort) + +(defun top-sort-name? (x) + (or (eq 'top-sort x) (eq :top-sort x) (eq t x) (eq 'true x) (eq true x))) + +(defun initialize-sort-theory () + (setf *top-sort* (declare-feature (top-sort-name))) + nil) + +(defun print-sort-theory () + (print-feature-tree :node (top-sort))) + +(definline top-sort () + *top-sort*) + +(definline same-sort? (x y) + (eq x y)) + +(definline top-sort? (x) + (same-sort? (top-sort) x)) + +(defun subsort0 (x y) + (with-clock-on sortal-reasoning + (feature-subsumes? y x))) + +(definline subsort? (x y) + ;; returns true for both identical sorts and strict subsorts + (or (same-sort? x y) + (top-sort? y) + (if (top-sort? x) nil (subsort0 x y)))) + +(definline subsort1? (x y) +;;(cl:assert (not (top-sort? y))) + (or (same-sort? x y) + (if (top-sort? x) nil (subsort0 x y)))) + +(defun sort-intersection0 (x y) + ;; returns canonical intersection of x and y, nil if x and y are incompatible + (with-clock-on sortal-reasoning + (feature-union x y))) + +(definline sort-intersection (x y) + (cond + ((or (same-sort? x y) (top-sort? x)) + y) + ((top-sort? y) + x) + (t + (sort-intersection0 x y)))) + +(definline sort-disjoint? (x y) + (null (sort-intersection x y))) + +(defun sort? (x) + (and (or (feature? x) (snark-feature::feature-combo? x)) + (feature-subsumes? (top-sort) x))) + +(defun sort-name (sort) + (let ((sort-name (snark-feature::feature-sym sort))) + (cl:assert (not (null sort-name)) () "There is no sort named ~S." sort) + sort-name)) + +(defun sort-name? (x &optional action) + ;; returns actual sort if x is a sort-name, nil otherwise + (or (and (top-sort-name? x) (top-sort)) + (let ((v (find-symbol-table-entry x :sort))) + (and (neq none v) v)) + (and action (funcall action "There is no sort named ~S." x)))) + +(defun sort-name-expression? (x &optional action) + ;; allows conjunction of sort names too + (cond + ((atom x) + (sort-name? x action)) + ((eq 'and (first x)) + (every #'(lambda (x) (sort-name-expression? x action)) (rest x))) + (t + (and action (funcall action "~S is not a sort expression." x))))) + +(defun fix-sort-name-expression (x) + (cond + ((atom x) + (sort-name? x 'error)) + ((eq 'and (first x)) + (cons 'and (mapcar #'fix-sort-name-expression (rest x)))))) + +(defun the-sort (sort-expr &optional (action 'error)) + (or (sort-name? sort-expr) + (let ((x (the-feature (fix-sort-name-expression sort-expr) nil 'error))) + (and x (feature-subsumes? (top-sort) x) x)) ;make sure the feature is specifically a sort + (and action (funcall action "~S has not been declared as a sort." sort-expr)))) + +;;; user operations for defining a sort theory: +;;; declare-sort +;;; declare-subsort +;;; declare-sorts-incompatible +;;; +;;; sorts can be declared only once +;;; sorts must be declared before they are used +;;; sort incompatibilities must be declared before incompatible sorts are used + +(defun declare-sort1 (sort-name sort) + (can-be-sort-name sort-name 'error) + (find-or-create-symbol-table-entry sort-name :sort nil sort) + (let ((sort-name* (intern (symbol-name sort-name) :snark-user))) + (unless (eq sort-name sort-name*) + ;; put the sort name into snark-user package so that sort-from-variable-name can find it + (find-or-create-symbol-table-entry sort-name* :sort nil sort))) + (when (test-option30?) + (declare-the-sort-function-symbol sort-name sort)) + sort) + +(defun declare-sort (sort-name &key iff subsorts-incompatible alias) + (cl:assert (not (and iff subsorts-incompatible))) + (let ((sort (sort-name? sort-name))) + (cond + (sort + (when (or iff subsorts-incompatible (null alias)) + (warn "Ignoring sort declaration; ~S has already been declared." sort-name))) + (t + (setf sort (declare-sort1 + sort-name + (cond + (iff + (with-clock-on sortal-reasoning + (declare-feature sort-name :iff (the-sort iff)))) + (t + (with-clock-on sortal-reasoning + (declare-feature sort-name :parent (the-sort (declare-root-sort?)) :children-incompatible subsorts-incompatible)))))))) + (when alias + (create-aliases-for-symbol sort alias)) + sort)) + +(defun declare-subsort (sort-name supersort-expr &key subsorts-incompatible alias) + (let ((sort (sort-name? sort-name))) + (cond + (sort + (when (or subsorts-incompatible (null alias)) + (warn "Ignoring sort declaration; ~S has already been declared." sort-name))) + (t + (setf sort (declare-sort1 + sort-name + (with-clock-on sortal-reasoning + (declare-feature sort-name :implies (the-sort supersort-expr) :children-incompatible subsorts-incompatible)))))) + (when alias + (create-aliases-for-symbol sort alias)) + sort)) + +(defun declare-sorts-incompatible (sort-name1 sort-name2 &rest more-sort-names) + (with-clock-on sortal-reasoning + (apply 'declare-features-incompatible sort-name1 sort-name2 more-sort-names))) + +;;; sorts-interface.lisp EOF diff --git a/src/sorts.lisp b/src/sorts.lisp new file mode 100644 index 0000000..a927dd1 --- /dev/null +++ b/src/sorts.lisp @@ -0,0 +1,284 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: sorts.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun declare-the-sort-function-symbol (name sort) + (declare-function + (intern (to-string :the- name) :snark-user) 1 + :sort name + :rewrite-code (lambda (term subst) + (let ((x (arg1 term))) + (if (subsort? (term-sort x subst) sort) x none))))) + +(defun declare-constant-sort (constant sort) + "assigns a sort to a constant" + (let* ((sort (the-sort sort)) + (old-sort (constant-sort constant)) + (new-sort (sort-intersection old-sort sort))) + (cond + ((same-sort? old-sort new-sort) + ) + ((null new-sort) + (error "Cannot declare ~A as constant of sort ~A; ~A is of incompatible sort ~A." constant sort constant old-sort)) + (t + (setf (constant-sort constant) new-sort)))) + constant) + +(defun declare-function-sort (function sort-spec) + (cond + ((function-boolean-valued-p function) + (setf (function-argument-sort-alist function) (input-argument-sort-alist function sort-spec))) + ((sort-name-expression? sort-spec nil) + (setf (function-sort function) (the-sort sort-spec))) + (t + (setf (function-sort function) (the-sort (first sort-spec))) + (setf (function-argument-sort-alist function) (input-argument-sort-alist function (rest sort-spec))))) + (when (function-associative function) + (check-associative-function-sort function)) + nil) + +(defvar *%check-for-well-sorted-atom%* t) + +(defun check-for-well-sorted-atom (atom &optional subst) + (when *%check-for-well-sorted-atom%* + (assert-atom-is-well-sorted atom subst)) + atom) + +(defun assert-atom-is-well-sorted (atom &optional subst) + (or (well-sorted-p atom subst) + (error "Atomic formula ~A is not well sorted." (term-to-lisp atom subst)))) + +(defun check-well-sorted (x &optional subst) + (unless (well-sorted-p x subst) + (error "~A is not well sorted." (term-to-lisp x subst))) + x) + +(defvar *%checking-well-sorted-p%* nil) + +(defun well-sorted-p (x &optional subst (sort (top-sort))) + ;; determines if expression is well sorted + ;; it does this by doing well-sorting on the expression + ;; with the restriction that no instantiation be done + (prog-> + (quote t -> *%checking-well-sorted-p%*) + (well-sort x subst sort ->* subst) + (declare (ignore subst)) + (return-from prog-> t))) + +(defun well-sorted-args-p (args subst fsd &optional (argcount 0)) + (prog-> + (quote t -> *%checking-well-sorted-p%*) + (well-sort-args args subst fsd argcount ->* subst) + (declare (ignore subst)) + (return-from prog-> t))) + +(defun term-sort (term &optional subst) + ;; return sort of well-sorted term + (dereference + term subst + :if-variable (variable-sort term) + :if-constant (constant-sort term) + :if-compound (compound-sort term subst))) + +(defun compound-sort (term &optional subst) + (let ((head (head term))) + (dolist (fun (function-sort-code head) (function-sort head)) + (let ((v (funcall fun term subst))) + (unless (or (null v) (eq none v)) + (return v)))))) + +(defun well-sort (cc x &optional subst (sort (top-sort))) + (dereference + x subst + :if-variable (cond + ((variable-sort-p x sort) + (funcall cc subst)) + (*%checking-well-sorted-p%* + ) + ((subsort? sort (variable-sort x)) + (funcall cc (bind-variable-to-term x (make-variable sort) subst))) + (t + (let ((sort (sort-intersection sort (variable-sort x)))) + (unless (null sort) + (funcall cc (bind-variable-to-term x (make-variable sort) subst)))))) + :if-constant (when (constant-sort-p x sort) + (funcall cc subst)) + :if-compound (prog-> + (well-sort-args (args x) subst (function-argument-sort-alist (head x)) ->* subst) + (when (subsort? (term-sort x subst) sort) + (funcall cc subst)))) + nil) + +(defun well-sort-args (cc args subst asa &optional (argcount 0)) + (dereference + args subst + :if-constant (funcall cc subst) + :if-variable (funcall cc subst) + :if-compound-appl (funcall cc subst) + :if-compound-cons (prog-> + (well-sort (carc args) subst (asa-arg-sort asa (incf argcount)) ->* subst) + (well-sort-args (cdrc args) subst asa argcount ->* subst) + (funcall cc subst))) + nil) + +(defun well-sort-atoms (cc atoms subst) + (cond + ((null atoms) + (funcall cc subst)) + (t + (prog-> + (well-sort (first atoms) subst ->* subst) + (well-sort-atoms (rest atoms) subst ->* subst) + (funcall cc subst))))) + +(defun well-sort-atoms1 (cc atoms subst) + (prog-> + (quote t -> first) + (well-sort-which-atoms atoms subst -> atoms) + (replace-skolem-terms-by-variables-in-atoms atoms subst -> atoms2 sksubst) + (well-sort-atoms atoms2 subst ->* subst) + (unless (fix-skolem-term-sorts sksubst first subst) + (cerror "Use only first instance." + "Input wff has more than well-sorted instance of existentially quantifed variable.") + (return-from prog->)) + (setf first nil) + (funcall cc subst))) + +(defun well-sort-which-atoms (atoms &optional subst) + (prog-> + (delete-if atoms ->* atom) + (cond + ((well-sorted-p atom subst) + t) + ((eq :terms (use-well-sorting?)) + (cond + ((well-sorted-p (args atom) subst) + (warn "Atomic formula ~A is not well sorted.~%Its arguments are well sorted, so will continue." (term-to-lisp atom subst)) + t) + (t + (warn "Atomic formula ~A is not well sorted.~%Will try to make its arguments well sorted and continue." (term-to-lisp atom subst)) + nil))) + (t + (warn "Atomic formula ~A is not well sorted." (term-to-lisp atom subst)) + nil)))) + +(defun well-sort-wff (cc wff &optional subst) + (cond + ((use-well-sorting?) + (well-sort-atoms1 cc (atoms-in-wff wff subst) subst)) + (t + (funcall cc subst)))) + +(defun well-sort-wffs (cc wffs &optional subst) + (cond + ((use-well-sorting?) + (well-sort-atoms1 cc (atoms-in-wffs wffs subst) subst)) + (t + (funcall cc subst)))) + +(defun replace-skolem-terms-by-variables-in-atoms (atoms &optional subst) + ;; this garbage is for HPKB and is needed for + ;; automatic well-sorting of unsorted wffs with existential quantifiers, + ;; which shouldn't even be allowed + ;; intended for freshly skolemized formulas; no skolem terms embedded in skolem terms + (let ((sksubst nil)) + (values + (prog-> + (mapcar atoms ->* atom) + (map-terms-in-atom-and-compose-result atom subst ->* term polarity) + (declare (ignore polarity)) + (dereference + term subst + :if-variable term + :if-constant (if (constant-skolem-p term) + (let ((v (lookup-value-in-substitution term sksubst))) + (when (eq none v) + (setf v (make-variable (constant-sort term))) + (setf sksubst (bind-variable-to-term v term sksubst))) + v) + term) + :if-compound (let ((fn (head term))) + (if (function-skolem-p fn) + (let ((v (lookup-value-in-substitution2 term sksubst subst))) + (when (eq none v) + (setf v (make-variable (function-sort fn))) + (setf sksubst (bind-variable-to-term v term sksubst))) + v) + term)))) + sksubst))) + +(defun fix-skolem-term-sorts (sksubst first subst) + (dobindings (binding sksubst t) + (let ((sort (let ((var (binding-var binding))) + (dereference var subst) + (variable-sort var))) + (val (binding-value binding))) + (dereference + val nil + :if-constant (unless (same-sort? sort (constant-sort val)) + (if first + (setf (constant-sort val) sort) + (return nil))) + :if-compound (let ((head (head val))) + (unless (same-sort? sort (function-sort head))) + (if first + (setf (function-sort head) sort) + (return nil))))))) + + +(definline constant-sort-p (constant sort) + (or (top-sort? sort) + (subsort1? (constant-sort constant) sort))) + +(definline variable-sort-p (variable sort) + (or (top-sort? sort) + (subsort1? (variable-sort variable) sort))) + +(defun term-sort-p (term sort &optional subst) + (or (top-sort? sort) + (subsort1? (term-sort term subst) sort))) + +(defun term-subsort-p (term1 term2 &optional subst) + (or (dereference ;allows wffs for rewriting + term2 subst + :if-constant (constant-boolean-valued-p term2) + :if-compound-appl (function-boolean-valued-p (heada term2)) + :if-variable (dereference + term1 subst + :if-constant (constant-boolean-valued-p term1) + :if-compound-appl (function-boolean-valued-p (head term1)))) + (term-sort-p term1 (term-sort term2 subst) subst))) + +(defun sort-compatible-p (term1 term2 &optional subst) + (let ((sort2 (term-sort term2 subst))) + (or (top-sort? sort2) (not (sort-disjoint? (term-sort term1 subst) sort2))))) + + +(defun check-associative-function-sort (fn) + ;; force sort specification to be of form (sort (t sort)) + (let ((sort (function-sort fn)) + (asa (function-argument-sort-alist fn))) + (unless (and (eq t (car (first asa))) (same-sort? sort (cdr (first asa)))) + (setf (function-argument-sort-alist fn) (list (cons t sort))) + (unless (and (same-sort? sort (asa-arg-sort asa 1)) (same-sort? sort (asa-arg-sort asa 2))) + (warn "The associative function ~A is required to have arguments of sort ~A." fn sort))) + sort)) + +;;; sorts.lisp EOF diff --git a/src/sparse-array-system.lisp b/src/sparse-array-system.lisp new file mode 100644 index 0000000..e9a2504 --- /dev/null +++ b/src/sparse-array-system.lisp @@ -0,0 +1,49 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*- +;;; File: sparse-array-system.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :common-lisp-user) + +(defpackage :snark-sparse-array + (:use :common-lisp :snark-lisp) + (:export + #:sparef + #:sparse-vector #:make-sparse-vector #:sparse-vector-p + #:sparse-vector-boolean #:sparse-vector-default-value + #:sparse-vector-count + #:map-sparse-vector #:map-sparse-vector-with-indexes #:map-sparse-vector-indexes-only + #:with-sparse-vector-iterator + #:first-sparef #:last-sparef #:pop-first-sparef #:pop-last-sparef + #:copy-sparse-vector #:spacons + #:sparse-matrix #:make-sparse-matrix #:sparse-matrix-p + #:sparse-matrix-boolean #:sparse-matrix-default-value + #:sparse-matrix-count + #:sparse-matrix-row #:sparse-matrix-column #:sparse-matrix-rows #:sparse-matrix-columns + #:map-sparse-matrix #:map-sparse-matrix-with-indexes #:map-sparse-matrix-indexes-only + + #:sparse-vector-expression-p + #:map-sparse-vector-expression + #:map-sparse-vector-expression-with-indexes + #:map-sparse-vector-expression-indexes-only + #:optimize-sparse-vector-expression + #:uniond + )) + +(loads "sparse-vector5" "sparse-array" "sparse-vector-expression") + +;;; sparse-array-system.lisp EOF diff --git a/src/sparse-array.lisp b/src/sparse-array.lisp new file mode 100644 index 0000000..e26668e --- /dev/null +++ b/src/sparse-array.lisp @@ -0,0 +1,465 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-sparse-array -*- +;;; File: sparse-array.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2006. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-sparse-array) + +;;; functions in this file should not depend on implementation details of sparse-vectors + +#+cormanlisp +(defun (setf sparef1) (value sparse-vector index) + (declare (ignore value sparse-vector index)) + (unimplemented)) + +#+cormanlisp +(defun (setf sparse-matrix-row) (value sparse-matrix index) + (declare (ignore value sparse-matrix index)) + (unimplemented)) + +#+cormanlisp +(defun (setf sparse-matrix-column) (value sparse-matrix index) + (declare (ignore value sparse-matrix index)) + (unimplemented)) + +;;; ****s* snark-sparse-array/sparse-matrix +;;; NAME +;;; sparse-matrix structure +;;; sparse-matrix type +;;; SOURCE + +(defstruct (sparse-matrix + (:constructor make-sparse-matrix0 (default-value boolean rows columns)) + (:print-function print-sparse-matrix3) + (:copier nil)) + (default-value nil :read-only t) + (boolean nil :read-only t) + (rows nil :read-only t) + (columns nil :read-only t)) +;;; *** + +;;; ****f* snark-sparse-array/make-sparse-matrix +;;; USAGE +;;; (make-sparse-matrix &key boolean default-value rows columns) +;;; RETURN VALUE +;;; sparse-matrix +;;; SOURCE + +(defun make-sparse-matrix (&key boolean default-value (rows t rows-supplied) (columns t columns-supplied)) + (when boolean + (unless (null default-value) + (error "Default-value must be NIL for Boolean sparse-arrays."))) + (let ((rows (and (or (not columns) (if rows-supplied rows (not columns-supplied))) + (make-sparse-vector))) + (columns (and (or (not rows) (if columns-supplied columns (not rows-supplied))) + (make-sparse-vector)))) + (let ((sparse-matrix (make-sparse-matrix0 default-value boolean rows columns))) + (when rows + (setf (sparse-vector-type rows) `(rows ,sparse-matrix))) + (when columns + (setf (sparse-vector-type columns) `(columns ,sparse-matrix))) + sparse-matrix))) +;;; *** + +;;; ****f* snark-sparse-array/sparse-matrix-p +;;; USAGE +;;; (sparse-matrix-p x) +;;; RETURN VALUE +;;; true if x if a sparse-matrix, false otherwise +;;; SOURCE + + ;;sparse-matrix-p is defined by the sparse-matrix defstruct +;;; *** + +;;; ****f* snark-sparse-array/sparse-matrix-boolean +;;; USAGE +;;; (sparse-matrix-boolean sparse-matrix) +;;; RETURN VALUE +;;; true if x is a boolean sparse-matrix, false otherwise +;;; SOURCE + ;;sparse-matrix-boolean is defined as a slot in the sparse-matrix structure +;;; *** + +;;; ****f* snark-sparse-array/sparse-matrix-default-value +;;; USAGE +;;; (sparse-matrix-boolean sparse-matrix) +;;; RETURN VALUE +;;; the default-value for unstored entries of sparse-matrix +;;; SOURCE + ;;sparse-matrix-default-value is defined as a slot in the sparse-matrix structure +;;; *** + +;;; ****f* snark-sparse-array/sparse-matrix-rows +;;; USAGE +;;; (sparse-matrix-rows sparse-matrix) +;;; RETURN VALUE +;;; sparse-vector of rows indexed by row-numbers or +;;; nil if sparse-matrix is stored only by columns +;;; SOURCE + + ;;sparse-matrix-rows is defined as a slot in the sparse-matrix structure +;;; *** + +;;; ****f* snark-sparse-array/sparse-matrix-columns +;;; USAGE +;;; (sparse-matrix-columns sparse-matrix) +;;; RETURN VALUE +;;; sparse-vector of columns indexed by column-numbers or +;;; nil if sparse-matrix is stored only by rows +;;; SOURCE + + ;;sparse-matrix-columns is defined as a slot in the sparse-matrix structure +;;; *** + +;;; ****f* snark-sparse-array/sparse-matrix-count +;;; USAGE +;;; (sparse-matrix-count sparse-matrix) +;;; RETURN VALUE +;;; integer number of entries in sparse-matrix +;;; SOURCE + +(defun sparse-matrix-count (sparse-matrix) + (let ((n 0)) + (prog-> + (map-sparse-vector + (or (sparse-matrix-rows sparse-matrix) (sparse-matrix-columns sparse-matrix)) ->* v) + (incf n (sparse-vector-count v))) + n)) +;;; *** + +;;; ****if* snark-sparse-array/sparef2 +;;; USAGE +;;; (sparef2 sparse-matrix row-index col-index) +;;; NOTES +;;; (sparef sparse-matrix row-index col-index) macroexpands to this +;;; SOURCE + +(defun sparef2 (sparse-matrix row-index col-index) + (let ((rows (sparse-matrix-rows sparse-matrix))) + (if rows + (let ((row (sparef rows row-index))) + (if row (sparef row col-index) (sparse-matrix-default-value sparse-matrix))) + (let ((col (sparef (sparse-matrix-columns sparse-matrix) col-index))) + (if col (sparef col row-index) (sparse-matrix-default-value sparse-matrix)))))) +;;; *** + +;;; ****f* snark-sparse-array/sparse-matrix-row +;;; USAGE +;;; (sparse-matrix-row sparse-matrix index) +;;; (setf (sparse-matrix-row sparse-matrix index) sparse-vector) +;;; (setf (sparse-matrix-row sparse-matrix index) nil) +;;; (setf (sparse-matrix-row sparse-matrix index) t) +;;; RETURN VALUE +;;; sparse-vector or nil +;;; DESCRIPTION +;;; (sparse-matrix-row sparse-matrix index) returns +;;; the index-th row of sparse-matrix if it exists, nil otherwise. +;;; +;;; (setf (sparse-matrix-row sparse-matrix index) sparse-vector) replaces +;;; the index-th row of sparse-matrix by sparse-vector. +;;; +;;; (setf (sparse-matrix-row sparse-matrix index) nil) deletes +;;; the index-th row of sparse-matrix. +;;; +;;; (setf (sparse-matrix-row sparse-matrix index) t) returns +;;; the index-th row of sparse-matrix if it exists +;;; or adds and returns a new one otherwise. +;;; It is equivalent to +;;; (or (sparse-matrix-row sparse-matrix index) +;;; (setf (sparse-matrix-row sparse-matrix index) +;;; (make-sparse-vector :boolean (sparse-matrix-boolean sparse-matrix) +;;; :default-value (sparse-matrix-default-value sparse-matrix)))) +;;; SOURCE + +(defun sparse-matrix-row (sparse-matrix index) + (let ((rows (sparse-matrix-rows sparse-matrix))) + (and rows (sparef rows index)))) + +(defun (setf sparse-matrix-row) (value sparse-matrix index) + (let ((rows (sparse-matrix-rows sparse-matrix))) + (if rows + (setf (sparef rows index) value) + (error "No row vectors for sparse-matrix ~A." sparse-matrix)))) +;;; *** + +;;; ****f* snark-sparse-array/sparse-matrix-column +;;; USAGE +;;; (setf (sparse-matrix-column sparse-matrix index) sparse-vector) +;;; (setf (sparse-matrix-column sparse-matrix index) nil) +;;; (setf (sparse-matrix-column sparse-matrix index) t) +;;; RETURN VALUE +;;; sparse-vector or nil +;;; DESCRIPTION +;;; Defined analogously to sparse-matrix-row. +;;; SOURCE + +(defun sparse-matrix-column (sparse-matrix index) + (let ((cols (sparse-matrix-columns sparse-matrix))) + (and cols (sparef cols index)))) + +(defun (setf sparse-matrix-column) (value sparse-matrix index) + (let ((cols (sparse-matrix-columns sparse-matrix))) + (if cols + (setf (sparef cols index) value) + (error "No column vectors for sparse-matrix ~A." sparse-matrix)))) +;;; *** + +;;; ****if* snark-sparse-array/add-sparse-matrix-row-or-column +;;; USAGE +;;; (add-sparse-matrix-row-or-column rows-or-cols index new-row-or-col) +;;; SOURCE + +(defun add-sparse-matrix-row-or-column (rows-or-cols index new-row-or-col) + (let ((type (sparse-vector-type rows-or-cols)) + sparse-matrix cols-or-rows) + (ecase (first type) + (rows + (setf sparse-matrix (second type)) + (setf cols-or-rows (sparse-matrix-columns sparse-matrix)) + (setf type `(row ,sparse-matrix ,index))) + (columns + (setf sparse-matrix (second type)) + (setf cols-or-rows (sparse-matrix-rows sparse-matrix)) + (setf type `(column ,sparse-matrix ,index)))) + (unless (eql 0 (sparse-vector-count new-row-or-col)) + (when cols-or-rows + (prog-> + (map-sparse-vector-with-indexes new-row-or-col ->* value index2) + (sparse-vector-setter + value (or (sparef cols-or-rows index2) (setf (sparef cols-or-rows index2) t)) index)))) + (setf (sparse-vector-type new-row-or-col) type) + (sparse-vector-setter new-row-or-col rows-or-cols index))) +;;; *** + +;;; ****if* snark-sparse-array/delete-sparse-matrix-row-or-column +;;; USAGE +;;; (delete-sparse-matrix-row-or-column rows-or-cols index &optional keep) +;;; SOURCE + +(defun delete-sparse-matrix-row-or-column (rows-or-cols index &optional keep) + ;; removes indexth sparse-vector from rows-or-cols + ;; and deletes its entries from cols-or-rows + ;; but leaves contents of removed sparse-vector intact + (let ((sparse-vector (sparef rows-or-cols index))) + (when sparse-vector + (unless (eql 0 (sparse-vector-count sparse-vector)) + (let ((cols-or-rows (let ((type (sparse-vector-type rows-or-cols))) + (ecase (first type) + (rows (sparse-matrix-columns (second type))) + (columns (sparse-matrix-rows (second type)))))) + (default-value (sparse-vector-default-value sparse-vector))) + (prog-> + (map-sparse-vector-indexes-only sparse-vector ->* index2) + (sparse-vector-setter default-value (sparef cols-or-rows index2) index)))) + (setf (sparse-vector-type sparse-vector) nil) + (unless keep + (sparse-vector-setter nil rows-or-cols index))))) +;;; *** + +;;; ****if* snark-sparse-array/(setf_sparef1) +;;; USAGE +;;; (setf (sparef1 sparse-vector index) value) +;;; SOURCE + +(defun (setf sparef1) (value sparse-vector index) + (let ((type (sparse-vector-type sparse-vector))) + (if (null type) + (sparse-vector-setter value sparse-vector index) + (ecase (first type) + (row + (let ((matrix (second type)) + (row-index (third type))) + (if (eql value (sparse-vector-default-value sparse-vector)) + (let ((col (sparse-matrix-column matrix index))) + (when col + (sparse-vector-setter value col row-index))) + (when (sparse-matrix-columns matrix) + (sparse-vector-setter value (setf (sparse-matrix-column matrix index) t) row-index)))) + (sparse-vector-setter value sparse-vector index)) + (column + (let ((matrix (second type)) + (col-index (third type))) + (if (eql value (sparse-vector-default-value sparse-vector)) + (let ((row (sparse-matrix-row matrix index))) + (when row + (sparse-vector-setter value row col-index))) + (when (sparse-matrix-rows matrix) + (sparse-vector-setter value (setf (sparse-matrix-row matrix index) t) col-index)))) + (sparse-vector-setter value sparse-vector index)) + ((rows columns) + (cond + ((null value) + (delete-sparse-matrix-row-or-column sparse-vector index nil)) + ((eq t value) + (or (sparef sparse-vector index) + (progn + (let ((matrix (second type))) + (setf value (make-sparse-vector + :default-value (sparse-matrix-default-value matrix) + :boolean (sparse-matrix-boolean matrix)))) + (delete-sparse-matrix-row-or-column sparse-vector index t) + (add-sparse-matrix-row-or-column sparse-vector index value)))) + (t + (let ((matrix (second type))) + (cl:assert (and (sparse-vector-p value) + (null (sparse-vector-type value)) + (if (sparse-vector-boolean value) + (sparse-vector-boolean matrix) + (and (not (sparse-vector-boolean matrix)) + (eql (sparse-vector-default-value value) + (sparse-vector-default-value matrix))))))) + (delete-sparse-matrix-row-or-column sparse-vector index t) + (add-sparse-matrix-row-or-column sparse-vector index value)))))))) +;;; *** + +;;; ****if* snark-sparse-array/(setf_sparef2) +;;; USAGE +;;; (setf (sparef2 sparse-matrix row-index col-index) value) +;;; SOURCE + +(defun (setf sparef2) (value sparse-matrix row-index col-index) + (let ((rows (sparse-matrix-rows sparse-matrix)) + (cols (sparse-matrix-columns sparse-matrix))) + (cond + ((eql value (sparse-matrix-default-value sparse-matrix)) + (let ((col (and cols (sparef cols col-index)))) + (when col + (sparse-vector-setter value col row-index))) + (let ((row (and rows (sparef rows row-index)))) + (if row + (sparse-vector-setter value row col-index) + value))) + (t + (when cols + (sparse-vector-setter value (setf (sparse-matrix-column sparse-matrix col-index) t) row-index)) + (if rows + (sparse-vector-setter value (setf (sparse-matrix-row sparse-matrix row-index) t) col-index) + value))))) +;;; *** + +;;; ****f* snark-sparse-array/map-sparse-matrix +;;; USAGE +;;; (map-sparse-matrix function sparse-matrix) +;;; RETURN VALUE +;;; nil +;;; DESCRIPTION +;;; The map-sparse-matrix function applies its unary-function argument +;;; to each value in sparse-matrix. +;;; SEE ALSO +;;; map-sparse-matrix-with-indexes +;;; map-sparse-matrix-indexes-only +;;; SOURCE + +(defun map-sparse-matrix (function sparse-matrix) + (let ((rows (sparse-matrix-rows sparse-matrix))) + (if rows + (prog-> + (map-sparse-vector rows ->* row) + (map-sparse-vector row ->* value) + (funcall function value)) + (prog-> + (map-sparse-vector (sparse-matrix-columns sparse-matrix) ->* col) + (map-sparse-vector col ->* value) + (funcall function value))))) +;;; *** + +;;; ****f* snark-sparse-array/map-sparse-matrix-with-indexes +;;; USAGE +;;; (map-sparse-matrix-with-indexes function sparse-matrix) +;;; RETURN VALUE +;;; nil +;;; DESCRIPTION +;;; The map-sparse-matrix-with-indexes function applies its ternary-function argument +;;; to each value, row-index, and column-index in sparse-matrix. +;;; SEE ALSO +;;; map-sparse-matrix +;;; map-sparse-matrix-indexes-only +;;; SOURCE + +(defun map-sparse-matrix-with-indexes (function sparse-matrix) + (let ((rows (sparse-matrix-rows sparse-matrix))) + (if rows + (prog-> + (map-sparse-vector-with-indexes rows ->* row row-index) + (map-sparse-vector-with-indexes row ->* value col-index) + (funcall function value row-index col-index)) + (prog-> + (map-sparse-vector-with-indexes (sparse-matrix-columns sparse-matrix) ->* col col-index) + (map-sparse-vector-with-indexes col ->* value row-index) + (funcall function value row-index col-index))))) +;;; *** + +;;; ****f* snark-sparse-array/map-sparse-matrix-indexes-only +;;; USAGE +;;; (map-sparse-matrix-indexes-only function sparse-matrix) +;;; RETURN VALUE +;;; nil +;;; DESCRIPTION +;;; The map-sparse-matrix-indexes-only function applies its binary-function argument +;;; to each row-index and column-index in sparse-matrix. +;;; SEE ALSO +;;; map-sparse-matrix +;;; map-sparse-matrix-with-indexes +;;; SOURCE + +(defun map-sparse-matrix-indexes-only (function sparse-matrix) + (let ((rows (sparse-matrix-rows sparse-matrix))) + (if rows + (prog-> + (map-sparse-vector-with-indexes rows ->* row row-index) + (map-sparse-vector-indexes-only row ->* col-index) + (funcall function row-index col-index)) + (prog-> + (map-sparse-vector-with-indexes (sparse-matrix-columns sparse-matrix) ->* col col-index) + (map-sparse-vector-indexes-only col ->* row-index) + (funcall function row-index col-index))))) +;;; *** + +;;; ****if* snark-sparse-array/print-sparse-vector3 +;;; USAGE +;;; (print-sparse-vector3 sparse-vector stream depth) +;;; NOTES +;;; specified as print-function in the sparse-vector defstruct +;;; SOURCE + +(defun print-sparse-vector3 (sparse-vector stream depth) + (declare (ignore depth)) + (print-unreadable-object (sparse-vector stream :type t :identity t) + (princ "count " stream) + (princ (sparse-vector-count sparse-vector) stream))) +;;; *** + +;;; ****if* snark-sparse-array/print-sparse-matrix3 +;;; USAGE +;;; (print-sparse-matrix3 sparse-matrix stream depth) +;;; NOTES +;;; specified as print-function in the sparse-matrix defstruct +;;; SOURCE + +(defun print-sparse-matrix3 (sparse-matrix stream depth) + (declare (ignore depth)) + (print-unreadable-object (sparse-matrix stream :type t :identity t) + (let ((rows (sparse-matrix-rows sparse-matrix))) + (princ (if rows (sparse-vector-count rows) "?") stream)) + (princ " rows" stream) + (princ " * " stream) + (let ((cols (sparse-matrix-columns sparse-matrix))) + (princ (if cols (sparse-vector-count cols) "?") stream)) + (princ " cols" stream))) +;;; *** + +;;; sparse-array.lisp EOF diff --git a/src/sparse-vector-expression.lisp b/src/sparse-vector-expression.lisp new file mode 100644 index 0000000..f211788 --- /dev/null +++ b/src/sparse-vector-expression.lisp @@ -0,0 +1,343 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-sparse-array -*- +;;; File: sparse-vector-expression.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2005. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-sparse-array) + +;;; compute intersection and union of sparse-vectors +;;; ::= +;;; | +;;; (intersection +) | +;;; (union +) | +;;; (uniond +) +;;; assumes that default-value for sparse-vectors is nil +;;; elements of unions are not mapped in order + +(defun sparse-vector-expression-p (x) + (cond + ((atom x) + (and (sparse-vector-p x) (null (sparse-vector-default-value x)))) + (t + (let ((fn (first x)) + (args (rest x))) + (and (or (eq 'intersection fn) (eq 'union fn) (eq 'uniond fn)) + args + (dolist (arg args t) + (unless (sparse-vector-expression-p arg) + (return nil)))))))) + +(definline mem-sparse-vector-expression (index expr) + (if (atom expr) (sparef expr index) (mem-sparse-vector-expression1 index expr))) + +(defun mem-sparse-vector-expression1 (index expr) + (declare (type cons expr)) + (cond + ((eq 'intersection (first expr)) + (dolist (e (rest expr) t) + (unless (mem-sparse-vector-expression index e) + (return nil)))) + (t ;union, uniond + (dolist (e (rest expr) nil) + (when (mem-sparse-vector-expression index e) + (return t)))))) + +;;; (intersection sve1 sve2 ... sven) is mapped by generating elements of +;;; sve1 and testing them for membership in sve2 ... sven +;;; +;;; (union sve1 sve2 ... sven) is mapped by generating elements of each svei +;;; and testing them for membership in sve1 ... svei-1 to omit duplicates +;;; +;;; (uniond sve1 sve2 ... sven) is mapped by generating elements of each svei; +;;; either the union of sets is assumed to be disjoint or we don't care about duplicates, +;;; so there is no duplicate elimination during mapping for uniond + +(defmacro map-sparse-vector-expression-macro (mapexp2 mapexp funcallexp) + `(cond + ((atom expr) + ,mapexp2) + (t + (ecase (pop expr) + (intersection + (prog-> + (first expr -> e1) + (rest expr -> l2) + (if l2 (cons 'intersection l2) nil -> exprest) + (if exprest (sparse-vector-expression-index-bounds exprest) nil -> min max) + (when (implies exprest (and (<= min max) + (prog-> + (sparse-vector-expression-index-bounds e1 -> min1 max1) + (and (<= min1 max1) (<= min max1) (>= max min1))))) + (if exprest (sparse-vector-expression-generates-in-order-p e1) nil -> inorder) + ,mapexp + ;; avoid membership tests if index k is out of range + ;; return quickly if generating indexes in order and beyond range + (when (implies exprest (if reverse + (and (>= max k) (or (<= min k) (if inorder (return-from prog->) nil))) + (and (<= min k) (or (>= max k) (if inorder (return-from prog->) nil))))) + (dolist l2 ,funcallexp ->* e2) + (unless (mem-sparse-vector-expression k e2) + (return)))))) + (uniond + (prog-> + (dolist expr ->* e1) + ,mapexp + (declare (ignorable k)) + ,funcallexp)) + (union + (prog-> + (dolist expr ->* e1) + ,mapexp + (dolist expr ->* e2) + (cond + ((eq e1 e2) + ,funcallexp + (return)) + ((mem-sparse-vector-expression k e2) + (return))))))))) + +;;; if it is provided, the predicate 'filter' is applied to elements immediately +;;; when mapped (e.g., before checking membership in rest of intersection) +;;; in order to ignore unwanted elements quickly + +(defun map-sparse-vector-expression-with-indexes0 (function expr reverse filter) + (map-sparse-vector-expression-macro + (if (null filter) + (map-sparse-vector-with-indexes function expr :reverse reverse) + (prog-> + (map-sparse-vector-with-indexes expr :reverse reverse ->* v k) + (when (funcall filter v k) + (funcall function v k)))) + (map-sparse-vector-expression-with-indexes0 e1 reverse filter ->* v k) + (funcall function v k))) + +(defun map-sparse-vector-expression-indexes-only0 (function expr reverse filter) + (map-sparse-vector-expression-macro + (if (null filter) + (map-sparse-vector-indexes-only function expr :reverse reverse) + (prog-> + (map-sparse-vector-indexes-only expr :reverse reverse ->* k) + (when (funcall filter k) + (funcall function k)))) + (map-sparse-vector-expression-indexes-only0 e1 reverse filter ->* k) + (funcall function k))) + +(defun map-sparse-vector-expression0 (function expr reverse filter) + (map-sparse-vector-expression-macro + (if (null filter) + (map-sparse-vector function expr :reverse reverse) + (prog-> + (map-sparse-vector expr :reverse reverse ->* v) + (when (funcall filter v) + (funcall function v)))) + (map-sparse-vector-expression-values2 e1 reverse filter ->* v k) + (funcall function v))) + +(defun map-sparse-vector-expression-values2 (function expr reverse filter) + (map-sparse-vector-expression-macro + (if (null filter) + (map-sparse-vector-with-indexes function expr :reverse reverse) + (prog-> + (map-sparse-vector-with-indexes expr :reverse reverse ->* v k) + (when (funcall filter v) + (funcall function v k)))) + (map-sparse-vector-expression-values2 e1 reverse filter ->* v k) + (funcall function v k))) + +(definline map-sparse-vector-expression (function expr &key reverse filter) + (map-sparse-vector-expression0 function expr reverse filter)) + +(definline map-sparse-vector-expression-with-indexes (function expr &key reverse filter) + (map-sparse-vector-expression-with-indexes0 function expr reverse filter)) + +(definline map-sparse-vector-expression-indexes-only (function expr &key reverse filter) + (map-sparse-vector-expression-indexes-only0 function expr reverse filter)) + +(defun sparse-vector-expression-size (expr) + ;; number of sparse-vectors in expression + (cond + ((atom expr) + 1) + (t + (setf expr (rest expr)) + (let ((size (sparse-vector-expression-size (first expr)))) + (dolist (e (rest expr) size) + (incf size (sparse-vector-expression-size e))))))) + +(defun sparse-vector-expression-maxcount (expr) + ;; upper bound on count for expression + (cond + ((atom expr) + (sparse-vector-count expr)) + ((eq 'intersection (pop expr)) + (let ((count (sparse-vector-expression-maxcount (first expr)))) + (dolist (e (rest expr) count) + (let ((n (sparse-vector-expression-maxcount e))) + (when (< n count) + (setf count n)))))) + (t ;union, uniond + (let ((count (sparse-vector-expression-maxcount (first expr)))) + (dolist (e (rest expr) count) + (incf count (sparse-vector-expression-maxcount e))))))) + +(defun optimized-sparse-vector-expression-maxcount (expr) + ;; upper bound on count for expression + ;; assumes that intersections are ordered in ascending value + (cond + ((atom expr) + (sparse-vector-count expr)) + ((eq 'intersection (pop expr)) + (optimized-sparse-vector-expression-maxcount (first expr))) + (t ;union, uniond + (let ((count (optimized-sparse-vector-expression-maxcount (first expr)))) + (dolist (e (rest expr) count) + (incf count (optimized-sparse-vector-expression-maxcount e))))))) + +(defun sparse-vector-expression-index-bounds (expr) + ;; returns smallest and largest indexes that might be expr + (cond + ((atom expr) + (values (nth-value 1 (first-sparef expr)) (nth-value 1 (last-sparef expr)))) + ((eq 'intersection (pop expr)) + (prog-> + (sparse-vector-expression-index-bounds (first expr) -> min max) + (dolist (rest expr) (values min max) ->* e) + (sparse-vector-expression-index-bounds e -> m n) + ;; narrow bounds of intersections + (when (< min m) + (setf min m)) + (when (> max n) + (setf max n)))) + (t ;union, uniond + (prog-> + (sparse-vector-expression-index-bounds (first expr) -> min max) + (dolist (rest expr) (values min max) ->* e) + (sparse-vector-expression-index-bounds e -> m n) + ;; widen bounds of unions + (when (> min m) + (setf min m)) + (when (< max n) + (setf max n)))))) + +(defun sparse-vector-expression-generates-in-order-p (expr) + (or (atom expr) + (and (eq 'intersection (first expr)) + (sparse-vector-expression-generates-in-order-p (second expr))))) + +(defun equal-sparse-vector-expression-p (x y) + (or (eq x y) + (and (consp x) + (consp y) + (eq (pop x) (pop y)) + (subsetp x y :test #'equal-sparse-vector-expression-p) + (subsetp y x :test #'equal-sparse-vector-expression-p)))) + +(defun equal-optimized-sparse-vector-expression-p (x y) + (or (eq x y) + (and (consp x) + (consp y) + (eq (pop x) (pop y)) + (length= x y) + (subsetp x y :test #'equal-optimized-sparse-vector-expression-p)))) + +(definline optimize-sparse-vector-expression (expr) + (cond + ((atom expr) + expr) + ((eq 'intersection (first expr)) + (optimize-sparse-vector-expression1 expr #'<)) ;intersection ordered by increasing maxcount + (t + (optimize-sparse-vector-expression1 expr #'>)))) ;union, uniond ordered by decreasing maxcount + +(definline optimize-and-sort-short-lists-of-sparse-vector-expressions (l1 predicate) + ;; returns t and destructively stably sorts l1 if length is <= 3, returns nil otherwise + (if (null l1) + t + (let ((l2 (rest l1))) + (if (null l2) + t + (let ((l3 (rest l2))) + (if (null l3) + (let* ((v1 (optimize-sparse-vector-expression (first l1))) + (v2 (optimize-sparse-vector-expression (first l2))) + (n1 (optimized-sparse-vector-expression-maxcount v1)) + (n2 (optimized-sparse-vector-expression-maxcount v2))) + (cond + ((funcall predicate n2 n1) + (setf (first l1) v2 (first l2) v1))) + t) + (if (null (rest l3)) + (let* ((v1 (optimize-sparse-vector-expression (first l1))) + (v2 (optimize-sparse-vector-expression (first l2))) + (v3 (optimize-sparse-vector-expression (first l3))) + (n1 (optimized-sparse-vector-expression-maxcount v1)) + (n2 (optimized-sparse-vector-expression-maxcount v2)) + (n3 (optimized-sparse-vector-expression-maxcount v3))) + (cond + ((funcall predicate n2 n1) + (cond + ((funcall predicate n3 n2) + (setf (first l1) v3 (first l2) v2 (first l3) v1)) + ((funcall predicate n3 n1) + (setf (first l1) v2 (first l2) v3 (first l3) v1)) + (t + (setf (first l1) v2 (first l2) v1)))) + ((funcall predicate n3 n2) + (cond + ((funcall predicate n3 n1) + (setf (first l1) v3 (first l2) v1 (first l3) v2)) + (t + (setf (first l2) v3 (first l3) v2))))) + t) + nil))))))) + +(defun optimize-sparse-vector-expression1 (expr predicate) + ;; destructive + (let ((fn (first expr)) + (args (rest expr))) +;; (cl:assert args) + (cond + ((null (rest args)) + (optimize-sparse-vector-expression (first args))) + (t + ;; optimize and sort arguments + (or (optimize-and-sort-short-lists-of-sparse-vector-expressions args predicate) + (progn + (dotails (l args) + (let ((x (optimize-sparse-vector-expression (car l)))) + (setf (car l) (cons (optimized-sparse-vector-expression-maxcount x) x)))) + (setf args (stable-sort args predicate :key #'car)) + (dotails (l args) + (setf (car l) (cdar l))))) + ;; eliminate duplicate arguments + (setf args (delete-duplicates args :test #'equal-optimized-sparse-vector-expression-p :from-end t)) + ;; apply absorption laws + ;; (union a (intersection a b) c) -> (union a c) + ;; (intersection a (union a b) c) -> (intersection a c) + (setf args (delete-if (lambda (arg) + (and (consp arg) + (not (iff (eq 'intersection fn) (eq 'intersection (first arg)))) + (dolist (x args) + (cond + ((eq arg x) + (return nil)) + ((member x (rest arg) :test #'equal-optimized-sparse-vector-expression-p) + (return t)))))) + args)) + (if (null (rest args)) (first args) (rplacd expr args)))))) + +;;; sparse-vector-expression.lisp EOF diff --git a/src/sparse-vector5.lisp b/src/sparse-vector5.lisp new file mode 100644 index 0000000..6f6ca6b --- /dev/null +++ b/src/sparse-vector5.lisp @@ -0,0 +1,982 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-sparse-array -*- +;;; File: sparse-vector5.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-sparse-array) + +;;; ****if* snark-sparse-array/sparse-vector-types +;;; SOURCE + +(deftype sparse-vector-index () 'integer) ;indexes are integers +(deftype sparse-vector-count () 'fixnum) ;number of entries is a fixnum +;;; *** + +;;; more implementation independent sparse-vector functions are defined in sparse-array.lisp + +;;; ****s* snark-sparse-array/sparse-vector +;;; NAME +;;; sparse-vector structure +;;; sparse-vector type +;;; SOURCE + +(defstruct (sparse-vector + (:constructor make-sparse-vector0 (default-value0)) + (:print-function print-sparse-vector3) + (:copier nil)) + (default-value0 nil :read-only t) ;default value, or 'bool (unexported symbol denotes boolean sparse-vector) + (type nil) + (count0 0 :type sparse-vector-count) + (cached-key 0 :type sparse-vector-index) + cached-value ;initialize in make-sparse-vector + (b-tree-root-node nil)) +;;; *** + +;;; ****f* snark-sparse-array/make-sparse-vector +;;; USAGE +;;; (make-sparse-vector &key boolean default-value) +;;; RETURN VALUE +;;; sparse-vector +;;; SOURCE + +(defun make-sparse-vector (&key boolean default-value) + (when boolean + (unless (null default-value) + (error "Default-value must be NIL for Boolean sparse-arrays."))) + (let ((sparse-vector (make-sparse-vector0 (if boolean 'bool default-value)))) + (setf (sparse-vector-cached-value sparse-vector) default-value) + sparse-vector)) +;;; *** + +;;; ****f* snark-sparse-array/sparse-vector-p +;;; USAGE +;;; (sparse-vector-p x) +;;; RETURN VALUE +;;; true if x if a sparse-vector, false otherwise +;;; SOURCE + + ;;sparse-vector-p is defined by the sparse-vector defstruct +;;; *** + +;;; ****f* snark-sparse-array/sparse-vector-boolean +;;; USAGE +;;; (sparse-vector-boolean sparse-vector) +;;; RETURN VALUE +;;; true if x is a boolean sparse-vector, false otherwise +;;; SOURCE + +(definline sparse-vector-boolean (sparse-vector) + (eq 'bool (sparse-vector-default-value0 sparse-vector))) +;;; *** + +;;; ****f* snark-sparse-array/sparse-vector-default-value +;;; USAGE +;;; (sparse-vector-boolean sparse-vector) +;;; RETURN VALUE +;;; the default-value for unstored entries of sparse-vector +;;; SOURCE + +(definline sparse-vector-default-value (sparse-vector) + (let ((v (sparse-vector-default-value0 sparse-vector))) + (if (eq 'bool v) nil v))) +;;; *** + +;;; ****f* snark-sparse-array/sparse-vector-count +;;; USAGE +;;; (sparse-vector-count sparse-vector) +;;; RETURN VALUE +;;; integer number of entries in sparse-vector +;;; NOTES +;;; returns 0 if sparse-vector is nil +;;; SOURCE + +(definline sparse-vector-count (sparse-vector) + (if (null sparse-vector) 0 (sparse-vector-count0 sparse-vector))) +;;; *** + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant b-tree-node-size 16) ;must be even + (defconstant b-tree-node-size-1 (- b-tree-node-size 1)) + (defconstant b-tree-node-size/2 (floor b-tree-node-size 2)) + (defconstant b-tree-node-size/2+1 (+ b-tree-node-size/2 1)) + (defconstant b-tree-node-size/2-1 (- b-tree-node-size/2 1))) + +#+ignore +(defstruct (b-tree-node + (:constructor make-b-tree-node (alist nonleaf-last-value)) + ) + ;; b-tree nodes must be nonempty + ;; leaf nodes have at least one key and the same number of values + ;; nonleaf nodes have at one key and one more value + (alist nil :read-only t) ;alist of keys and values (or just list of keys for leaf nodes of boolean sparse vectors) + (nonleaf-last-value nil :read-only t)) ;nonleaf nodes have one more value than keys, nil for leaf nodes + +(defmacro make-b-tree-node (alist nonleaf-last-value) + `(cons ,alist ,nonleaf-last-value)) + +(defmacro b-tree-node-alist (n) + `(carc ,n)) + +(defmacro b-tree-node-nonleaf-last-value (n) + `(cdrc ,n)) + +(definline b-tree-nonleaf-node-alist-search (alist index) + ;; each node has one or more keys in descending order + (declare (type sparse-vector-index index)) + (loop + (when (or (>= index (the sparse-vector-index (carc (carc alist)))) (null (setf alist (cdrc alist)))) + (return alist)))) + +(definline lastc (list) + (let (rest) + (loop + (if (null (setf rest (cdrc list))) + (return (carc list)) + (setf list rest))))) + +(definline smallest-key (x) + (let ((p (lastc x))) + (if (atom p) p (carc p)))) + +(definline largest-key (x) + (let ((p (carc x))) + (if (atom p) p (carc p)))) + +(definline b-tree-node-smallest-key* (n) + (loop + (let ((last-value (b-tree-node-nonleaf-last-value n))) + (cond + ((null last-value) + ;; leaf node + (let ((v (lastc (b-tree-node-alist n)))) + (if (atom v) ;boolean sparse vector? + (return (values v v)) + (return (values (carc v) (cdrc v)))))) + (t + (setf n last-value)))))) + +(definline b-tree-node-largest-key* (n) + (loop + (let ((last-value (b-tree-node-nonleaf-last-value n))) + (cond + ((null last-value) + ;; leaf node + (let ((v (carc (b-tree-node-alist n)))) + (if (atom v) ;boolean sparse vector? + (return (values v v)) + (return (values (carc v) (cdrc v)))))) + (t + (setf n (cdrc (carc (b-tree-node-alist n))))))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun nestn (x y n) + (dotimes (i n) + (setf y (subst y '*** x))) + y)) + +(defmacro unroll-sparef1-leaf () + `(let ((p (carc alist))) + (if (atom p) + ;; boolean sparse-vector leaf node, alist is nonempty list of indexes in descending order + ,(let ((l nil)) + (dotimes (i b-tree-node-size) + (cond + ((= 0 i) + (push `((or (null (setf alist (cdrc alist))) (>= index k)) (= index k)) l)) + ((> b-tree-node-size-1 i) + (push `((progn (setf k (carc alist)) (or (null (setf alist (cdrc alist))) (>= index k))) (= index k)) l)) + (t + (push `(t (= index (the sparse-vector-index (carc alist)))) l)))) + `(let ((k p)) + (declare (type sparse-vector-index k)) + (if (cond ,@(reverse l)) index nil))) + ;; nonboolean sparse-vector leaf node, alist is nonempty alist of keys (in descending order) and values + ,(let ((l nil)) + (dotimes (i b-tree-node-size) + (cond + ((= 0 i) + (push `((or (null (setf alist (cdrc alist))) (>= index k)) (= index k)) l)) + ((> b-tree-node-size-1 i) + (push `((progn (setf k (carc (setf p (carc alist)))) (or (null (setf alist (cdrc alist))) (>= index k))) (= index k)) l)) + (t + (push `(t (= index (the sparse-vector-index (carc (setf p (carc alist)))))) l)))) + `(let ((k (carc p))) + (declare (type sparse-vector-index k)) + (if (cond ,@(reverse l)) (cdrc p) (sparse-vector-default-value sparse-vector))))))) + +(defmacro unroll-sparef1-nonleaf () + ;; nonleaf node, alist is nonempty alist of keys (in descending order) and values + (let ((l nil)) + (dotimes (i b-tree-node-size) + (cond + ((= 0 i) + (push `((>= index (the sparse-vector-index (carc p))) (cdrc p)) l)) + (t + (push `((null (setf alist (cdrc alist))) nil) l) + (push `((>= index (the sparse-vector-index (carc (setf p (carc alist))))) (cdrc p)) l)))) + `(let* ((p (carc alist))) + (cond ,@(reverse l))))) + +(defmacro unroll-full-alist () + (let ((l nil)) + (dotimes (i b-tree-node-size-1) + (push `(setf l (cdrc l)) l)) + `(and ,@l))) + +(definline full-alist (l) + (unroll-full-alist)) + +;;; ****if* snark-sparse-array/sparef1 +;;; USAGE +;;; (sparef1 sparse-vector index) +;;; NOTES +;;; (sparef sparse-vector index) macroexpands to this +;;; SOURCE + +(defun sparef1 (sparse-vector index) + (declare (type sparse-vector sparse-vector) (type sparse-vector-index index)) + (let ((n (sparse-vector-b-tree-root-node sparse-vector))) + (cond + ((null n) + (sparse-vector-default-value sparse-vector)) + ((= (sparse-vector-cached-key sparse-vector) index) + (sparse-vector-cached-value sparse-vector)) + (t + (loop + (let ((alist (b-tree-node-alist n)) + (last-value (b-tree-node-nonleaf-last-value n))) + (cond + ((null last-value) + ;; leaf node + (setf (sparse-vector-cached-key sparse-vector) index) + (return (setf (sparse-vector-cached-value sparse-vector) (unroll-sparef1-leaf)))) + (t + (setf n (or (unroll-sparef1-nonleaf) last-value)))))))))) +;;; *** + +;;; ****f* snark-sparse-array/sparef +;;; USAGE +;;; (sparef sparse-vector index) +;;; (setf (sparef sparse-vector index) value) +;;; +;;; (sparef sparse-matrix row-index column-index) +;;; (setf (sparef sparse-matrix row-index column-index) value) +;;; SOURCE + +(defmacro sparef (sparse-array index1 &optional index2) + (if (null index2) + `(sparef1 ,sparse-array ,index1) + `(sparef2 ,sparse-array ,index1 ,index2))) +;;; *** + +;;; ****if* snark-sparse-array/sparse-vector-setter +;;; USAGE +;;; (sparse-vector-setter value sparse-vector index) +;;; SOURCE + +(defun sparse-vector-setter (value sparse-vector index &optional copy) + ;; sparse-vector-setter destructively modifies slots of sparse-vector + ;; it will make a copy of sparse-vector and modify it instead if copy is true + ;; this is used by spacons that returns a new sparse-vector and leaves the original unmodified + ;; the b-tree structure nodes themselves are not destructively modified + ;; so that map-sparse-vector traversals are unaltered by + ;; additions, deletions, and modifications done during the traversal + (declare (type sparse-vector sparse-vector) (type sparse-vector-index index)) + (when (and (= (sparse-vector-cached-key sparse-vector) index) + (if (sparse-vector-boolean sparse-vector) + (iff (sparse-vector-cached-value sparse-vector) value) + (eql (sparse-vector-cached-value sparse-vector) value))) + (return-from sparse-vector-setter (if copy sparse-vector value))) + (let ((n (sparse-vector-b-tree-root-node sparse-vector))) + (cond + ((null n) + ;; sparse-vector is empty + (unless (eql (sparse-vector-default-value sparse-vector) value) + ;; add single element + (when copy + (setf sparse-vector (copy-sparse-vector sparse-vector))) + (setf (sparse-vector-count0 sparse-vector) 1) + (setf (sparse-vector-b-tree-root-node sparse-vector) (make-b-tree-node (if (sparse-vector-boolean sparse-vector) (list index) (list (cons index value))) nil)))) + (t + (labels + ((split-leaf-alist (list num) + (declare (type fixnum num)) + (let (rest) + (labels + ((spl () + (cond + ((= 0 num) + (setf rest list) + nil) + (t + (cons (carc list) (progn (setf list (cdrc list)) (setf num (- num 1)) (spl))))))) + (values (spl) rest)))) + (split-nonleaf-alist (list num) + (declare (type fixnum num)) + (let (k v rest) + (labels + ((spl () + (cond + ((= 0 num) + (let ((p (carc list))) + (setf k (carc p)) + (setf v (cdrc p)) + (setf rest (cdrc list))) + nil) + (t + (cons (carc list) (progn (setf list (cdrc list)) (setf num (- num 1)) (spl))))))) + (values (spl) k v rest)))) + (list-update (list index value) + (declare (type sparse-vector-index index)) + (let ((diff 0)) + (labels + ((update (list) + (cond + ((null list) + (cond + ((null value) + nil) + (t + (setf diff +1) + (cons index nil)))) + (t + (let ((k (carc list))) + (declare (type sparse-vector-index k)) + (cond + ((>= index k) + (if (= index k) + (cond + ((null value) + (setf diff -1) + (cdrc list)) + (t + list)) + (cond + ((null value) + list) + (t + (setf diff +1) + (cons index list))))) + (t + (let* ((l (cdrc list)) + (l* (update l))) + (if (eq l l*) list (cons k l*)))))))))) + (values (update list) diff)))) + (alist-update (alist index value default-value) + (declare (type sparse-vector-index index)) + (let ((diff 0)) + (labels + ((update (alist) + (cond + ((null alist) + (cond + ((eql default-value value) + nil) + (t + (setf diff +1) + (cons (cons index value) nil)))) + (t + (let* ((p (carc alist)) + (k (carc p))) + (declare (type sparse-vector-index k)) + (cond + ((>= index k) + (if (= index k) + (cond + ((eql default-value value) + (setf diff -1) + (cdrc alist)) + ((eql value (cdrc p)) + alist) + (t + (cons (cons index value) (cdrc alist)))) + (cond + ((eql default-value value) + alist) + (t + (setf diff +1) + (cons (cons index value) alist))))) + (t + (let* ((l (cdrc alist)) + (l* (update l))) + (if (eq l l*) alist (cons p l*)))))))))) + (values (update alist) diff)))) + (sparse-vector-setter1 (n) + (let ((alist (b-tree-node-alist n)) + (last-value (b-tree-node-nonleaf-last-value n))) + (cond + ((null last-value) + ;; leaf node of b-tree index + (mvlet (((values alist1 diff) + (if (atom (carc alist)) ;boolean sparse vector? + (list-update alist index value) + (alist-update alist index value (sparse-vector-default-value sparse-vector))))) + (declare (type fixnum diff)) + (cond + ((eq alist alist1) + n) + (t + (when copy + (setf sparse-vector (copy-sparse-vector sparse-vector))) + (unless (= 0 diff) + (incf (sparse-vector-count0 sparse-vector) diff)) + (cond + ((null alist1) + :delete) + ((and (= 1 diff) (full-alist alist)) + (mvlet (((values alist2 alist1) (split-leaf-alist alist1 b-tree-node-size/2))) + (values + (make-b-tree-node alist1 nil) ;replacement for this node + (make-b-tree-node alist2 nil) ;new node to go before it + (floor (+ (smallest-key alist2) (+ (largest-key alist1) 1)) 2)))) + (t + (make-b-tree-node alist1 nil))))))) + (t + ;; descend toward correct leaf node of b-tree index + (let ((tail (b-tree-nonleaf-node-alist-search alist index))) + (if tail + (mvlet* ((p (carc tail)) + (k (carc p)) + (v (cdrc p)) + ((values v1 n2 k2) (sparse-vector-setter1 v))) + (cond + ((eq v v1) + n) + ((eq :delete v1) + (cond + ((null (cdrc alist)) ;if only one value remains + last-value) ;move it up in b-tree + (t + (make-b-tree-node (alist-update alist k nil nil) last-value)))) + (n2 + (let ((alist1 (alist-update (alist-update alist k v1 nil) k2 n2 nil))) + (cond + ((full-alist alist) + (mvlet (((values alist2 k v alist1) (split-nonleaf-alist alist1 b-tree-node-size/2))) + (values + (make-b-tree-node alist1 last-value) + (make-b-tree-node alist2 v) + k))) + (t + (make-b-tree-node alist1 last-value))))) + (t + (make-b-tree-node (alist-update alist k v1 nil) last-value)))) + (mvlet* ((v last-value) + ((values v1 n2 k2) (sparse-vector-setter1 v))) + (cond + ((eq v v1) + n) + ((eq :delete v1) + (cond + ((null (cdrc alist)) ;if only one value remains + (cdrc (carc alist))) ;move it up in b-tree + (t + (make-b-tree-node (butlast alist) (cdrc (lastc alist)))))) + (n2 + (let ((alist1 (alist-update alist k2 n2 nil))) + (cond + ((full-alist alist) + (mvlet (((values alist2 k v alist1) (split-nonleaf-alist alist1 b-tree-node-size/2))) + (values + (make-b-tree-node alist1 v1) + (make-b-tree-node alist2 v) + k))) + (t + (make-b-tree-node alist1 v1))))) + (t + (make-b-tree-node alist v1))))))))))) + (mvlet (((values n1 n2 k2) (sparse-vector-setter1 n))) + (cond + ((eq n n1) + ) + ((eq :delete n1) + (setf (sparse-vector-b-tree-root-node sparse-vector) nil)) + (n2 + (setf (sparse-vector-b-tree-root-node sparse-vector) (make-b-tree-node (list (cons k2 n2)) n1))) + (t + (setf (sparse-vector-b-tree-root-node sparse-vector) n1)))))))) + (setf (sparse-vector-cached-key sparse-vector) index) + (setf (sparse-vector-cached-value sparse-vector) (if value (if (sparse-vector-boolean sparse-vector) index value) nil)) + (if copy sparse-vector value)) +;;; *** + +(defun copy-sparse-vector (sparse-vector) + (declare (type sparse-vector sparse-vector)) + (cond + ((null (sparse-vector-type sparse-vector)) + (copy-structure sparse-vector)) + (t + (error "Type ~A sparse-vector cannot be copied." (sparse-vector-type sparse-vector))))) + +(definline spacons (index value sparse-vector) + ;; does the following, except does not copy sparse-vector if it is not changed by the assignment + ;; (let ((sv (copy-sparse-vector sparse-vector))) + ;; (setf (sparef sv index) value) + ;; sv) + (sparse-vector-setter value sparse-vector index t)) + +(defmacro do-map-sparse-vector-backward (min max boolean map) + ;; always returns nil + (let ((p (and (not boolean) (not (eq :indexes-only map)))) + (k (or boolean map min max))) + `(labels + ((map1 (n) + (let ((alist (b-tree-node-alist n)) + (last-value (b-tree-node-nonleaf-last-value n))) + (cond + ((null last-value) + ;; leaf node + (let (,@(when p (list `p)) ,@(when k (list `(k 0)))) + ,@(when (and k (or min max)) (list `(declare (type sparse-vector-index k)))) + (loop + ,@(cond + (boolean + (list + `(setf k (carc alist)))) + ((and p k) + (list + `(setf k (carc (setf p (carc alist)))))) + (p + (list + `(setf p (carc alist)))) + (k + (list + `(setf k (carc (carc alist)))))) + (cond + ,@(when max (list + `((and max (or (< (the sparse-vector-index max) k) (setf max nil))) + ))) + ,@(when min (list + `((and min (> (the sparse-vector-index min) k)) + (return-from map-sparse-vector-backward nil)))) + (t + ,(cond + ((null map) + `(funcall function ,(if boolean `k `(cdrc p)))) + ((eq :with-indexes map) + `(funcall function ,(if boolean `k `(cdrc p)) k)) + (t ;(eq :indexes-only map) + `(funcall function k))))) + (when (null (setf alist (cdrc alist))) + (return nil))))) + (t + ;; nonleaf node + (let (p) + (loop + (setf p (carc alist)) + (cond + ,@(when max (list + `((and max (< (the sparse-vector-index max) (the sparse-vector-index (carc p)))) + ))) + (t + (map1 (cdrc p)))) + (when (null (setf alist (cdrc alist))) + (return nil)))) + (cond + ,@(when max (list + `((and max (< (the sparse-vector-index max) (the sparse-vector-index (b-tree-node-smallest-key* last-value)))) + ))) + (t + (map1 last-value)))))))) + (map1 n)))) + +(defmacro do-map-sparse-vector-forward (min max boolean map) + ;; always returns nil + (let ((p (and (not boolean) (not (eq :indexes-only map)))) + (k (or boolean map min max))) + `(labels + ((map1 (n) + (let ((alist (b-tree-node-alist n)) + (last-value (b-tree-node-nonleaf-last-value n))) + (cond + ((null last-value) + ;; leaf node + (macrolet + ((domap1 () + (nestn '(progn + (let ((alist (cdrc alist))) + (when alist + ***)) + ,@(cond + (boolean + (list + `(setf k (carc alist)))) + ((and p k) + (list + `(setf k (carc (setf p (carc alist)))))) + (p + (list + `(setf p (carc alist)))) + (k + (list + `(setf k (carc (carc alist)))))) + (cond + ,@(when min (list + `((and min (or (> (the sparse-vector-index min) k) (setf min nil))) + ))) + ,@(when max (list + `((and max (< (the sparse-vector-index max) k)) + (return-from map-sparse-vector-forward nil)))) + (t + ,(cond + ((null map) + `(funcall function ,(if boolean `k `(cdrc p)))) + ((eq :with-indexes map) + `(funcall function ,(if boolean `k `(cdrc p)) k)) + (t ;(eq :indexes-only map) + `(funcall function k)))))) + nil + b-tree-node-size))) + (let (,@(when p (list `p)) ,@(when k (list `(k 0)))) + ,@(when (and k (or min max)) (list `(declare (type sparse-vector-index k)))) + (domap1)))) + (t + ;; nonleaf node + (cond + ,@(when min (list + `((and min (> (the sparse-vector-index min) (the sparse-vector-index (b-tree-node-largest-key* last-value)))) + ))) + (t + (map1 last-value))) + (macrolet + ((domap1 () + (nestn '(progn + (let ((alist (cdrc alist))) + (when alist + ***)) + (setf v (cdrc (carc alist))) + (cond + ,@(when min (list + `((and min (> (the sparse-vector-index min) (the sparse-vector-index (b-tree-node-largest-key* v)))) + ))) + (t + (map1 v)))) + nil + b-tree-node-size))) + (let (v) + (domap1)))))))) + (map1 n) + nil))) + +(defun map-sparse-vector-backward (function n) + (do-map-sparse-vector-backward nil nil nil nil)) + +(defun map-sparse-vector-backward-with-indexes (function n) + (do-map-sparse-vector-backward nil nil nil :with-indexes)) + +(defun map-sparse-vector-backward-indexes-only (function n) + (do-map-sparse-vector-backward nil nil nil :indexes-only)) + +(defun map-sparse-vector-forward (function n) + (do-map-sparse-vector-forward nil nil nil nil)) + +(defun map-sparse-vector-forward-with-indexes (function n) + (do-map-sparse-vector-forward nil nil nil :with-indexes)) + +(defun map-sparse-vector-forward-indexes-only (function n) + (do-map-sparse-vector-forward nil nil nil :indexes-only)) + +(defun map-sparse-vector-backward-bounded (function n min max) + (block map-sparse-vector-backward + (do-map-sparse-vector-backward t t nil nil))) + +(defun map-sparse-vector-backward-bounded-with-indexes (function n min max) + (block map-sparse-vector-backward + (do-map-sparse-vector-backward t t nil :with-indexes))) + +(defun map-sparse-vector-backward-bounded-indexes-only (function n min max) + (block map-sparse-vector-backward + (do-map-sparse-vector-backward t t nil :indexes-only))) + +(defun map-sparse-vector-forward-bounded (function n min max) + (block map-sparse-vector-forward + (do-map-sparse-vector-forward t t nil nil))) + +(defun map-sparse-vector-forward-bounded-with-indexes (function n min max) + (block map-sparse-vector-forward + (do-map-sparse-vector-forward t t nil :with-indexes))) + +(defun map-sparse-vector-forward-bounded-indexes-only (function n min max) + (block map-sparse-vector-forward + (do-map-sparse-vector-forward t t nil :indexes-only))) + +(defun map-boolean-sparse-vector-backward (function n) + (do-map-sparse-vector-backward nil nil t nil)) + +(defun map-boolean-sparse-vector-backward-with-indexes (function n) + (do-map-sparse-vector-backward nil nil t :with-indexes)) + +(defun map-boolean-sparse-vector-forward (function n) + (do-map-sparse-vector-forward nil nil t nil)) + +(defun map-boolean-sparse-vector-forward-with-indexes (function n) + (do-map-sparse-vector-forward nil nil t :with-indexes)) + +(defun map-boolean-sparse-vector-backward-bounded (function n min max) + (block map-sparse-vector-backward + (do-map-sparse-vector-backward t t t nil))) + +(defun map-boolean-sparse-vector-backward-bounded-with-indexes (function n min max) + (block map-sparse-vector-backward + (do-map-sparse-vector-backward t t t :with-indexes))) + +(defun map-boolean-sparse-vector-forward-bounded (function n min max) + (block map-sparse-vector-forward + (do-map-sparse-vector-forward t t t nil))) + +(defun map-boolean-sparse-vector-forward-bounded-with-indexes (function n min max) + (block map-sparse-vector-forward + (do-map-sparse-vector-forward t t t :with-indexes))) + +;;; ****if* snark-sparse-array/map-sparse-vector0 +;;; USAGE +;;; (map-sparse-vector0 function sparse-vector reverse min max map) +;;; SOURCE + +(defun map-sparse-vector0 (function sparse-vector reverse min max map) + (declare (type sparse-vector sparse-vector)) + ;; always returns nil + (let ((n (sparse-vector-b-tree-root-node sparse-vector))) + (unless (null n) + (let ((boolean (sparse-vector-boolean sparse-vector))) + (cond + ((and (null min) (null max)) + (let ((alist (b-tree-node-alist n))) + (when (and (null (cdrc alist)) (null (b-tree-node-nonleaf-last-value n))) + (let ((p (carc alist))) ;(= 1 (sparse-vector-count sparse-vector)) special case + (if boolean + (cond + ((null map) + (funcall function p)) + ((eq :with-indexes map) + (funcall function p p)) + (t ;(eq :indexes-only map) + (funcall function p))) + (cond + ((null map) + (funcall function (cdrc p))) + ((eq :with-indexes map) + (funcall function (cdrc p) (carc p))) + (t ;(eq :indexes-only map) + (funcall function (carc p)))))) + (return-from map-sparse-vector0 nil))) + (if reverse + (cond + ((null map) + (if boolean + (map-boolean-sparse-vector-backward function n) + (map-sparse-vector-backward function n))) + ((eq :with-indexes map) + (if boolean + (map-boolean-sparse-vector-backward-with-indexes function n) + (map-sparse-vector-backward-with-indexes function n))) + (t ;(eq :indexes-only map) + (if boolean + (map-boolean-sparse-vector-backward function n) + (map-sparse-vector-backward-indexes-only function n)))) + (cond + ((null map) + (if boolean + (map-boolean-sparse-vector-forward function n) + (map-sparse-vector-forward function n))) + ((eq :with-indexes map) + (if boolean + (map-boolean-sparse-vector-forward-with-indexes function n) + (map-sparse-vector-forward-with-indexes function n))) + (t ;(eq :indexes-only map) + (if boolean + (map-boolean-sparse-vector-forward function n) + (map-sparse-vector-forward-indexes-only function n)))))) + (t + (if reverse + (cond + ((null map) + (if boolean + (map-boolean-sparse-vector-backward-bounded function n min max) + (map-sparse-vector-backward-bounded function n min max))) + ((eq :with-indexes map) + (if boolean + (map-boolean-sparse-vector-backward-bounded-with-indexes function n min max) + (map-sparse-vector-backward-bounded-with-indexes function n min max))) + (t ;(eq :indexes-only map) + (if boolean + (map-boolean-sparse-vector-backward-bounded function n min max) + (map-sparse-vector-backward-bounded-indexes-only function n min max)))) + (cond + ((null map) + (if boolean + (map-boolean-sparse-vector-forward-bounded function n min max) + (map-sparse-vector-forward-bounded function n min max))) + ((eq :with-indexes map) + (if boolean + (map-boolean-sparse-vector-forward-bounded-with-indexes function n min max) + (map-sparse-vector-forward-bounded-with-indexes function n min max))) + (t ;(eq :indexes-only map) + (if boolean + (map-boolean-sparse-vector-forward-bounded function n min max) + (map-sparse-vector-forward-bounded-indexes-only function n min max))))))))))) +;;; *** + +;;; ****f* snark-sparse-array/map-sparse-vector +;;; USAGE +;;; (map-sparse-vector function sparse-vector &key reverse min max) +;;; RETURN VALUE +;;; nil +;;; DESCRIPTION +;;; The map-sparse-vector function applies its unary-function argument to +;;; each value (or index, if sparse-vector is boolean) in sparse-vector. +;;; It does nothing if sparse-vector is nil. +;;; +;;; The function is applied only to values whose index is >= min +;;; and <= max if they are specified. If reverse is nil, the +;;; function is applied to values in ascending order by index; +;;; otherwise, the order is reversed. +;;; SEE ALSO +;;; map-sparse-vector-with-indexes +;;; map-sparse-vector-indexes-only +;;; SOURCE + +(definline map-sparse-vector (function sparse-vector &key reverse min max) + (when sparse-vector + (map-sparse-vector0 function sparse-vector reverse min max nil))) +;;; *** + +;;; ****f* snark-sparse-array/map-sparse-vector-with-indexes +;;; USAGE +;;; (map-sparse-vector-with-indexes function sparse-vector &key reverse min max) +;;; RETURN VALUE +;;; nil +;;; DESCRIPTION +;;; The map-sparse-vector-with-indexes function is like map-sparse-vector, +;;; but applies its binary-function argument to each value and index in sparse-vector. +;;; SEE ALSO +;;; map-sparse-vector +;;; map-sparse-vector-indexes-only +;;; SOURCE + +(definline map-sparse-vector-with-indexes (function sparse-vector &key reverse min max) + (when sparse-vector + (map-sparse-vector0 function sparse-vector reverse min max :with-indexes))) +;;; *** + +;;; ****f* snark-sparse-array/map-sparse-vector-indexes-only +;;; USAGE +;;; (map-sparse-vector-indexes-only function sparse-vector &key reverse min max) +;;; RETURN VALUE +;;; nil +;;; DESCRIPTION +;;; The map-sparse-vector-indexes-only function is like map-sparse-vector, +;;; but applies its unary-function argument to each index in sparse-vector. +;;; map-sparse-vector and map-sparse-vector-indexes-only operate identically +;;; on boolean sparse-vectors. +;;; SEE ALSO +;;; map-sparse-vector +;;; map-sparse-vector-with-indexes +;;; SOURCE + +(definline map-sparse-vector-indexes-only (function sparse-vector &key reverse min max) + (when sparse-vector + (map-sparse-vector0 function sparse-vector reverse min max :indexes-only))) +;;; *** + +;;; ****f* snark-sparse-array/first-sparef +;;; USAGE +;;; (first-sparef sparse-vector) +;;; RETURN VALUE +;;; (values (sparef sparse-vector first-index) first-index) or +;;; (values default-value nil) if sparse-vector is empty +;;; SEE ALSO +;;; pop-first-sparef +;;; SOURCE + +(defun first-sparef (sparse-vector) + (declare (type sparse-vector sparse-vector)) + (let ((n (sparse-vector-b-tree-root-node sparse-vector))) + (cond + ((null n) + (values (sparse-vector-default-value sparse-vector) nil)) + (t + (mvlet (((values index value) (b-tree-node-smallest-key* n))) + (values + (setf (sparse-vector-cached-value sparse-vector) value) + (setf (sparse-vector-cached-key sparse-vector) index))))))) +;;; *** + +;;; ****f* snark-sparse-array/last-sparef +;;; USAGE +;;; (last-sparef sparse-vector) +;;; RETURN VALUE +;;; (values (sparef sparse-vector last-index) last-index) or +;;; (values default-value nil) if sparse-vector is empty +;;; SEE ALSO +;;; pop-last-sparef +;;; SOURCE + +(defun last-sparef (sparse-vector) + (declare (type sparse-vector sparse-vector)) + (let ((n (sparse-vector-b-tree-root-node sparse-vector))) + (cond + ((null n) + (values (sparse-vector-default-value sparse-vector) nil)) + (t + (mvlet (((values index value) (b-tree-node-largest-key* n))) + (values + (setf (sparse-vector-cached-value sparse-vector) value) + (setf (sparse-vector-cached-key sparse-vector) index))))))) +;;; *** + +;;; ****f* snark-sparse-array/pop-first-sparef +;;; USAGE +;;; (pop-first-sparef sparse-vector) +;;; RETURN VALUE +;;; (values (sparef sparse-vector first-index) first-index) or +;;; (values default-value nil) if sparse-vector is empty +;;; SIDE EFFECTS +;;; removes it from sparse-vector +;;; SEE ALSO +;;; first-sparef +;;; SOURCE + +(defun pop-first-sparef (sparse-vector) + (declare (type sparse-vector sparse-vector)) + (mvlet (((values value index) (first-sparef sparse-vector))) + (when index + (sparse-vector-setter (sparse-vector-default-value sparse-vector) sparse-vector index)) + (values value index))) +;;; *** + +;;; ****f* snark-sparse-array/pop-last-sparef +;;; USAGE +;;; (pop-last-sparef sparse-vector) +;;; RETURN VALUE +;;; (values (sparef sparse-vector last-index) last-index) or +;;; (values default-value nil) if sparse-vector is empty +;;; SIDE EFFECTS +;;; removes it from sparse-vector +;;; SEE ALSO +;;; last-sparef +;;; SOURCE + +(defun pop-last-sparef (sparse-vector) + (declare (type sparse-vector sparse-vector)) + (mvlet (((values value index) (last-sparef sparse-vector))) + (when index + (sparse-vector-setter (sparse-vector-default-value sparse-vector) sparse-vector index)) + (values value index))) +;;; *** + +;;; sparse-vector5.lisp EOF diff --git a/src/subst.lisp b/src/subst.lisp new file mode 100644 index 0000000..109404e --- /dev/null +++ b/src/subst.lisp @@ -0,0 +1,611 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: subst.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; a substitution is a list of bindings and an alist of variables and values +;;; substitutions can be manipulated as SNARK terms if this ever becomes useful + +(defmacro make-binding (var value) + `(cons ,var ,value)) + +(defmacro binding-var (binding) + `(car ,binding)) + +(defmacro binding-value (binding) + `(cdr ,binding)) + +(defmacro add-binding-to-substitution (binding subst) + `(cons ,binding ,subst)) + +(defmacro dobindings ((binding subst &optional resultform) &body body) + `(dolist (,binding ,subst ,resultform) + ,@body)) + +(definline bind-variable-to-term (var term subst) + (add-binding-to-substitution (make-binding var term) subst)) + +(defun lookup-variable-in-substitution (var subst) + (let ((v (assoc var subst :test #'eq))) + (if v (binding-value v) none))) + +(defun lookup-value-in-substitution (value subst) + (let ((v (rassoc value subst))) + (if v (binding-var v) none))) + +(defun lookup-value-in-substitution2 (value subst subst2) + (let ((v (rassoc value subst :test (lambda (x y) (equal-p x y subst2))))) + (if v (binding-var v) none))) + +(defun substitution-equal-p (subst1 subst2) + (and (length= subst1 subst2) + (substitution-subset-p1 subst1 subst2))) + +(defun substitution-subset-p (subst1 subst2) + (and (length<= subst1 subst2) + (substitution-subset-p1 subst1 subst2))) + +(defun substitution-diff (subst1 subst2) + (if subst2 (ldiff subst1 subst2) subst1)) + +(defun substitution-diff2 (subst1 subst2) + (labels + ((subst-diff (subst1) + (if (null subst1) + nil + (let* ((b1 (first subst1)) + (var (binding-var b1)) + (val1 (binding-value b1)) + (val2 (lookup-variable-in-substitution var subst2))) + (cond + ((eq none val2) ;var is unbound in subst2 + (let* ((l (rest subst1)) + (l* (subst-diff l))) + (cond + ((eq none l*) + none) + ((eq l l*) + subst1) + (t + (cons b1 l*))))) + ((equal-p val1 val2) ;var is bound equally in subst1 and subst2 + (subst-diff (rest subst1))) + (t ;var is bound unequally in subst1 and subst2 + none)))))) ;return none to signal incompatibility + (if (null subst2) + subst1 + (subst-diff subst1)))) + +(defun substitution-subset-p1 (subst1 subst2) + (loop + (if (null subst1) + (return t) + (let ((v (lookup-variable-in-substitution (binding-var (first subst1)) subst2))) + (if (and (neq none v) (equal-p (binding-value (first subst1)) v)) + (setf subst1 (rest subst1)) + (return nil)))))) + +(defun remove-irrelevant-bindings (subst term) + (cond + ((null subst) + nil) + ((not (variable-occurs-p (binding-var (first subst)) term nil)) + (remove-irrelevant-bindings (rest subst) term)) + (t + (let* ((l (rest subst)) + (l* (remove-irrelevant-bindings l term))) + (if (eq l l*) + subst + (add-binding-to-substitution (first subst) l*)))))) + +(defun print-substitution (subst) + (format t "{ ") + (let ((first t)) + (dobindings (binding subst) + (if first + (setf first nil) + (princ " , ")) + (format t "~S -> ~S" (binding-var binding) (binding-value binding)))) + (format t " }") + subst) + +(defun make-idempotent-substitution (subst) + ;; create an idempotent substitution from subst + ;; by instantiating the variable values + (cond + ((null subst) + nil) + ((null (rest subst)) + subst) + (t + (setf subst (copy-alist subst)) + (dolist (binding subst) + (setf (binding-value binding) (instantiate (binding-value binding) subst))) + subst))) + +(defun variables (x &optional subst vars) + "return a list of all the variables that occur in x" + (dereference + x subst + :if-constant vars + :if-compound-cons (variables (cdrc x) subst (variables (carc x) subst vars)) + :if-compound-appl (dolist (x1 (argsa x) vars) + (setf vars (variables x1 subst vars))) + :if-variable (adjoin x vars))) + +(defun nontheory-variables (x &optional subst theory vars) + (dereference + x subst + :if-constant vars + :if-compound-cons (nontheory-variables (cdrc x) subst theory (nontheory-variables (carc x) subst theory vars)) + :if-compound-appl (let ((head (heada x))) + (unless (function-constructor head) ;constructor symbols are transparent wrt theory + (setf theory (function-constraint-theory head))) + (dolist (x1 (argsa x) vars) + (setf vars (nontheory-variables x1 subst theory vars)))) + :if-variable (if (null theory) (adjoin x vars) vars))) ;only variables under nontheory symbols are returned + +(defun variablesl (l &optional subst vars) + (dolist (x l vars) + (setf vars (variables x subst vars)))) + +(defun first-nonvariable-term (terms &optional subst) + (dolist (term terms none) + (dereference + term subst + :if-constant (return term) + :if-compound (return term)))) + +(defun first-nonvariable-subterm (terms &optional subst) + (dolist (term terms none) + (dereference + term subst + :if-compound (let ((v (first-nonvariable-term (args term)))) + (unless (eq none v) + (return v)))))) + +(defun variable-counts (x &optional subst counts) + "return a list of all the variables that occur in x with their frequency, in dotted pairs" + (dereference + x subst + :if-constant counts + :if-compound-cons (variable-counts (cdrc x) subst (variable-counts (carc x) subst counts)) + :if-compound-appl (dolist (x1 (argsa x) counts) + (setf counts (variable-counts x1 subst counts))) + :if-variable (let ((v (assoc/eq x counts))) + (if v (progn (incf (cdrc v)) counts) (cons (cons x 1) counts))))) + +(defun variable-disjoint-partition (l &optional subst) + (let ((l* nil)) + (dolist (x l) + ;; bind all variables in x to first variable in x + (let ((firstvar nil)) + (labels + ((unify-variables (x) + (dereference + x subst + :if-variable (cond + ((null firstvar) + (setf firstvar x)) + ((neq firstvar x) + (setf subst (bind-variable-to-term x firstvar subst)))) + :if-compound-cons (progn (unify-variables (carc x)) (unify-variables (cdrc x))) + :if-compound-appl (dolist (x (argsa x)) (unify-variables x))))) + (unify-variables x)) + (push (cons firstvar x) l*))) ;record firstvar with expression + (let ((partition nil) (ground nil)) + (dolist (x l*) + (let ((p (car x))) + (cond + ((null p) + (push (cdr x) ground)) + (t + (dereference p subst) ;use each dereferenced firstvar as key for partition + (let ((v (assoc p partition))) + (if v + (push (cdr x) (cdr v)) + (push (list p (cdr x)) partition))))))) + (dolist (v partition) ;remove keys, leaving only expressions + (setf (car v) (cadr v)) + (setf (cdr v) (cddr v))) + (if ground + (values (cons ground partition) t) ;if any expressions are ground, put them first in partition, and return 2nd value t + partition)))) + +(defun new-variables (x &optional subst vars) + "return a list of all the variables that occur in x but are not in vars" + ;; ldiff could be done destructively + (ldiff (variables x subst vars) vars)) + +(defun instantiate (x n &optional subst) + "applies substitution to x, optionally first renumbering block-0 variables to block-n" + (cond + ((constant-p x) + x) + (t + (when (or (consp n) (numberp subst)) ;accept n and subst arguments in either order + (psetq subst n n subst)) + (if (or (null n) (zerop n)) + (if (null subst) + x ;nop + (labels ;just substitute + ((instantiate* (x) + (dereference + x subst + :if-variable x + :if-constant x + :if-compound-cons (lcons (instantiate* (car x)) (instantiate* (cdr x)) x) + :if-compound-appl (let* ((args (argsa x)) (args* (instantiatel args))) + (if (eq args args*) x (make-compound* (heada x) args*))))) + (instantiatel (l) + (lcons (instantiate* (first l)) (instantiatel (rest l)) l))) + (instantiate* x))) + (let ((incr (variable-block n))) + (if (null subst) + (labels ;just renumber + ((instantiate* (x) + (dereference + x nil + :if-variable (let ((n (variable-number x))) + (if (variable-block-0-p n) + (make-variable (variable-sort x) (+ n incr)) + x)) + :if-constant x + :if-compound-cons (lcons (instantiate* (car x)) (instantiate* (cdr x)) x) + :if-compound-appl (let* ((args (argsa x)) (args* (instantiatel args))) + (if (eq args args*) x (make-compound* (heada x) args*))))) + (instantiatel (l) + (lcons (instantiate* (first l)) (instantiatel (rest l)) l))) + (instantiate* x)) + (labels ;renumber and substitute + ((instantiate* (x) + (when (variable-p x) + (let ((n (variable-number x))) + (when (variable-block-0-p n) + (setf x (make-variable (variable-sort x) (+ n incr)))))) + (dereference + x subst + :if-variable x + :if-constant x + :if-compound-cons (lcons (instantiate* (car x)) (instantiate* (cdr x)) x) + :if-compound-appl (let* ((args (argsa x)) (args* (instantiatel args))) + (if (eq args args*) x (make-compound* (heada x) args*))))) + (instantiatel (l) + (lcons (instantiate* (first l)) (instantiatel (rest l)) l))) + (instantiate* x)))))))) + +(defun renumber (x &optional subst rsubst) + "applies substitution to x and renumbers variables (normally to block 0)" + (dereference + x subst + :if-constant (values x rsubst) + :if-compound-cons (values (let (u v) + (setf (values u rsubst) (renumber (carc x) subst rsubst)) + (setf (values v rsubst) (renumber (cdrc x) subst rsubst)) + (lcons u v x)) + rsubst) + :if-compound-appl (values (let* ((args (argsa x)) + (args* (let (dummy) + (declare (ignorable dummy)) + (setf (values dummy rsubst) + (renumberl args subst rsubst))))) + (if (eq args args*) + x + (make-compound* (head x) args*))) + rsubst) + :if-variable (let ((v (lookup-variable-in-substitution x rsubst))) + (cond + ((neq none v) + (values v rsubst)) + (t + (let ((var (renumberv x rsubst))) +;; (values var (bind-variable-to-term x var rsubst)) ;maybe x=var + (values var (cons (cons x var) rsubst)))))))) + +(defun renumberl (l subst rsubst) + (let (dummy) + (declare (ignorable dummy)) + (values (lcons (setf (values dummy rsubst) (renumber (first l) subst rsubst)) + (setf (values dummy rsubst) (renumberl (rest l) subst rsubst)) + l) + rsubst))) + +(defvar *renumber-first-number* 0) +(defvar *renumber-by-sort* nil) +(defvar *renumber-ignore-sort* nil) + +(defun renumberv (var rsubst) + (let ((sort (if *renumber-ignore-sort* (top-sort) (variable-sort var)))) + (if (null *renumber-first-number*) + (make-variable sort) + (loop + (cond + ((null rsubst) + (return (make-variable sort *renumber-first-number*))) + (t + (let ((binding (first rsubst))) + (when (implies *renumber-by-sort* (same-sort? sort (variable-sort (binding-value binding)))) + (return (make-variable sort (+ (variable-number (binding-value binding)) 1))))) + (setf rsubst (rest rsubst)))))))) + +(defun renumber-new (x &optional subst rsubst) + "applies substitution to x and renumbers variables to all new variables" + (let ((*renumber-first-number* nil)) + (renumber x subst rsubst))) + +(defun renumberer () + (let ((variable-substitution nil) + (compound-substitution nil)) + #'(lambda (x &optional subst) + (labels + ((renumber (x) + (dereference + x subst + :if-constant x + :if-variable (let ((v (lookup-variable-in-substitution x variable-substitution))) + (if (neq none v) + v + (let ((x* (make-variable (variable-sort x)))) + (setf variable-substitution (bind-variable-to-term x x* variable-substitution)) + x*))) + :if-compound-appl (let ((v (assoc x compound-substitution :test #'eq))) + (if v + (cdrc v) + (let* ((args (argsa x)) + (args* (renumberl args)) + (x* (if (eq args args*) x (make-compound* (heada x) args*)))) + (setf compound-substitution (acons x x* compound-substitution)) + x*))) + :if-compound-cons (lcons (renumber (carc x)) (renumber (cdrc x)) x))) + (renumberl (l) + (lcons (renumber (carc l)) (renumberl (cdrc l)) l))) + (renumber x))))) + +(defun ground-p (x &optional subst) + "return t if x is ground, nil otherwise" + (dereference + x subst + :if-constant t + :if-compound-cons (and (ground-p (carc x) subst) (ground-p (cdrc x) subst)) + :if-compound-appl (loop for x1 in (argsa x) + always (ground-p x1 subst)) + :if-variable nil)) + +(defun frozen-p (x subst) + "return t if all variables of x are frozen, nil otherwise" + (dereference + x subst + :if-constant t + :if-compound-cons (and (frozen-p (carc x) subst) (frozen-p (cdrc x) subst)) + :if-compound-appl (loop for x1 in (argsa x) + always (frozen-p x1 subst)) + :if-variable (variable-frozen-p x))) + +(defun constructor-term-p (x subst) + ;; returns t if x is built entirely from constructors + ;; treat nil as second argument of cons as a constructor even if not declared as such + (dereference + x subst + :if-constant (constant-constructor x) + :if-compound-cons (and (constructor-term-p (carc x) subst) (constructor-term-p (cdrc x) subst)) + :if-compound-appl (and (function-constructor (heada x)) + (loop for x1 in (argsa x) + always (constructor-term-p x1 subst))) + :if-variable nil)) + +(defun unsorted-p (x &optional subst) + ;; check whether all symbols in x are unsorted + ;; except $$cons and nil + ;; and numbers and strings? + (dereference + x subst + :if-variable (top-sort? (variable-sort x)) + :if-constant (or (null x) (top-sort? (constant-sort x))) + :if-compound-cons (and (unsorted-p (carc x) subst) (unsorted-p (cdrc x) subst)) + :if-compound-appl (and (top-sort? (function-sort (heada x))) + (loop for x1 in (argsa x) + always (unsorted-p x1 subst))))) + +(defun all-variables-p (terms &optional subst) + (dolist (term terms t) + (dereference + term subst + :if-constant (return nil) + :if-compound (return nil)))) + +(defun occurs-p (x y &optional subst) + "return t if x occurs in y, nil otherwise" + (dereference + x subst + :if-constant (if (function-symbol-p x) + (function-occurs-p x y subst) + (constant-occurs-p x y subst)) + :if-compound (compound-occurs-p x y subst) + :if-variable (variable-occurs-p x y subst))) + +(defun function-occurs-p (x y subst) + (dereference + y subst + :if-compound (or (eq x (head y)) + (loop for y1 in (args y) + thereis (function-occurs-p x y1 subst))))) + +(defun constant-occurs-p (x y subst) + "return t if atom x occurs in y, nil otherwise" + (dereference + y subst + :if-constant (eql x y) + :if-compound (loop for y1 in (args y) + thereis (constant-occurs-p x y1 subst)))) + +(defun compound-occurs-p (x y subst) + "return t if compound x occurs in y, nil otherwise" + (dereference + y subst + :if-compound (or (equal-p x y subst) + (loop for y1 in (args y) + thereis (compound-occurs-p x y1 subst))))) + +(defun no-new-variable-occurs-p (x subst vars) + ;; returns t if every variable in x.subst is a member of vars, nil otherwise + (labels ((no-new-variable (x) + (dereference + x subst + :if-variable (member x vars :test #'eq) + :if-constant t + :if-compound-cons (and (no-new-variable (carc x)) (no-new-variable (cdrc x))) + :if-compound-appl (dolist (x1 (argsa x) t) + (unless (no-new-variable x1) + (return nil)))))) + (not (null (no-new-variable x))))) + +(defun constant-occurs-below-constructor-p (x y subst) + (labels + ((occ (y) + (dereference + y subst + :if-constant (eql x y) + :if-compound-cons (or (occ (carc y)) (occ (cdrc y))) + :if-compound-appl (and (function-constructor (heada y)) + (loop for y1 in (argsa y) thereis (occ y1)))))) + (dereference + y subst + :if-compound-cons (or (occ (carc y)) (occ (cdrc y))) + :if-compound-appl (and (function-constructor (heada y)) + (loop for y1 in (argsa y) thereis (occ y1)))))) + +(defun variable-occurs-below-constructor-p (x y subst) + (labels + ((occ (y) + (dereference + y subst + :if-variable (eq x y) + :if-compound-cons (or (occ (carc y)) (occ (cdrc y))) + :if-compound-appl (and (function-constructor (heada y)) + (loop for y1 in (args y) thereis (occ y1)))))) + (dereference + y subst + :if-compound-cons (or (occ (carc y)) (occ (cdrc y))) + :if-compound-appl (and (function-constructor (heada y)) + (loop for y1 in (argsa y) thereis (occ y1)))))) + +(defun compound-occurs-below-constructor-p (x y subst) + (labels + ((occ (y) + (dereference + y subst + :if-compound-cons (or (if (consp x) (equal-p x y subst) nil) + (or (occ (carc y)) (occ (cdrc y)))) + :if-compound-appl (or (if (consp x) nil (equal-p x y subst)) + (and (function-constructor (heada y)) + (loop for y1 in (argsa y) thereis (occ y1))))))) + (dereference + y subst + :if-compound-cons (or (occ (carc y)) (occ (cdrc y))) + :if-compound-appl (and (function-constructor (heada y)) + (loop for y1 in (argsa y) thereis (occ y1)))))) + +(defmacro variable-occurs-p1-macro () + `(dereference + y nil + :if-compound-cons (or (variable-occurs-p1 x (carc y)) (variable-occurs-p1 x (cdrc y))) + :if-compound-appl (dolist (y (argsa y) nil) + (when (variable-occurs-p1 x y) + (return t))) + :if-variable (eq x y))) + +(defmacro variable-occurs-p2-macro () + `(dereference + y subst + :if-compound-cons (or (variable-occurs-p2 x (carc y) subst) (variable-occurs-p2 x (cdrc y) subst)) + :if-compound-appl (dolist (y (argsa y) nil) + (when (variable-occurs-p2 x y subst) + (return t))) + :if-variable (eq x y))) + +(defun variable-occurs-p1l (x l) + (dolist (y l nil) + (when (variable-occurs-p1-macro) + (return t)))) + +(defun variable-occurs-p2l (x l subst) + (dolist (y l nil) + (when (variable-occurs-p2-macro) + (return t)))) + +(defun variable-occurs-p1 (x y) + (variable-occurs-p1-macro)) + +(defun variable-occurs-p2 (x y subst) + (variable-occurs-p2-macro)) + +(defun variable-occurs-p (x y subst) + "return t if variable x occurs in y, nil otherwise" + (if (null subst) + (variable-occurs-p1-macro) + (variable-occurs-p2-macro))) + +(defun special-unify-p (x subst) + (dereference + x subst + :if-compound (or (function-unify-code (head x)) + (loop for x1 in (args x) + thereis (special-unify-p x1 subst))))) + +(defun skolem-occurs-p (x subst) + (dereference + x subst + :if-constant (constant-skolem-p x) + :if-compound (or (function-skolem-p (head x)) + (loop for x1 in (args x) + thereis (skolem-occurs-p x1 subst))))) + +(defun disallowed-symbol-occurs-in-answer-p (x subst) + (dereference + x subst + :if-constant (not (constant-allowed-in-answer x)) + :if-compound (or (not (function-allowed-in-answer (head x))) + (loop for x1 in (args x) + thereis (disallowed-symbol-occurs-in-answer-p x1 subst))))) + +(defun embedding-variable-occurs-p (x subst) + (dereference + x subst + :if-compound (loop for x1 in (args x) + thereis (embedding-variable-occurs-p x1 subst)) + :if-variable (embedding-variable-p x))) + +(defun split-if (test list &optional subst) + ;; split list into lists of dereferenced items that satisfy and don't satisfy test + (if (dereference list subst :if-compound-cons t) + (let ((l (rest list))) + (multiple-value-bind (l1 l2) (split-if test l subst) + (let ((x (first list))) + (let ((x* x)) + (dereference x* subst) + (if (funcall test x*) + (if (and (eq l l1) (eq x x*)) + (values list l2) + (values (cons x* l1) l2)) + (if (and (eq l l2) (eq x x*)) + (values l1 list) + (values l1 (cons x* l2)))))))) + (values nil list))) + +;;; subst.lisp EOF diff --git a/src/substitute.lisp b/src/substitute.lisp new file mode 100644 index 0000000..5c17818 --- /dev/null +++ b/src/substitute.lisp @@ -0,0 +1,201 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: substitute.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2008. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun substitute (new old x &optional subst) + "substitute new for old in x" + (dereference + old subst + :if-constant (if (function-symbol-p old) + (unimplemented) + (substitute-for-constant new old x subst)) + :if-compound (substitute-for-compound new old x subst) + :if-variable (substitute-for-variable new old x subst))) + +(defun substitutel (new old l &optional subst) + (dereference + old subst + :if-constant (if (function-symbol-p old) + (unimplemented) + (substitute-for-constantl new old l subst)) + :if-compound (substitute-for-compoundl new old l subst) + :if-variable (substitute-for-variablel new old l subst))) + +(defun substitute-for-constant (new old x subst) + "substitute new for constant old in x" + ;; if old = nil, replace it in conses, but not at end of argument lists + (dereference + x subst + :if-constant (if (eql old x) new x) + :if-compound-cons (let* ((u (carc x)) (u* (substitute-for-constant new old u subst)) + (v (cdrc x)) (v* (substitute-for-constant new old v subst))) + (if (and (eql u u*) (eql v v*)) x (cons u* v*))) + :if-compound-appl (let* ((args (argsa x)) (args* (substitute-for-constantl new old args subst))) + (if (eq args args*) x (make-compound* (heada x) args*))) + :if-variable x)) + +(defun substitute-for-compound (new old x subst) + "substitute new for compound old in x" + (dereference + x subst + :if-constant x + :if-compound-cons (cond + ((equal-p old x subst) + new) + (t + (lcons (substitute-for-compound new old (car x) subst) + (substitute-for-compound new old (cdr x) subst) + x))) + :if-compound-appl (cond + ((equal-p old x subst) + new) + (t + (let* ((args (argsa x)) (args* (substitute-for-compoundl new old args subst))) + (if (eq args args*) x (make-compound* (heada x) args*))))) + :if-variable x)) + +(defun substitute-for-variable (new old x subst) + "substitute new for variable old in x" + (dereference + x subst + :if-constant x + :if-compound-appl (let* ((args (argsa x)) (args* (substitute-for-variablel new old args subst))) + (if (eq args args*) x (make-compound* (heada x) args*))) + :if-compound-cons (lcons (substitute-for-variable new old (carc x) subst) + (substitute-for-variable new old (cdrc x) subst) + x) + :if-variable (if (eq old x) new x))) + +(defun substitute-once (cc new old x &optional subst) + (dereference + old subst + :if-constant (if (function-symbol-p old) + (unimplemented) + (substitute-for-constant-once cc new old x subst)) + :if-compound (substitute-for-compound-once cc new old x subst) + :if-variable (substitute-for-variable-once cc new old x subst))) + +(defun substitute-for-constant-once (cc new old x subst) + ;; if old = nil, replace it in conses, but not at end of argument lists + (dereference + x subst + :if-constant (when (eql old x) + (funcall cc new)) + :if-compound-cons (let ((u (carc x)) (v (cdrc x))) + (prog-> + (substitute-for-constant-once new old u subst ->* u*) + (funcall cc (cons u* v))) + (prog-> + (substitute-for-constant-once new old v subst ->* v*) + (funcall cc (cons u v*)))) + :if-compound-appl (prog-> + (argsa x ->nonnil args) + (heada x -> head) + (substitute-for-constant-oncel new old args subst ->* args*) + (funcall cc (make-compound* head args*))))) + +(defun substitute-for-compound-once (cc new old x subst) + (dereference + x subst + :if-compound-cons (cond + ((equal-p old x subst) + (funcall cc new)) + (t + (let ((u (carc x)) (v (cdrc x))) + (prog-> + (substitute-for-compound-once new old u subst ->* u*) + (funcall cc (cons u* v))) + (prog-> + (substitute-for-compound-once new old v subst ->* v*) + (funcall cc (cons u v*)))))) + :if-compound-appl (cond + ((equal-p old x subst) + (funcall cc new)) + (t + (prog-> + (argsa x ->nonnil args) + (heada x -> head) + (substitute-for-compound-oncel new old args subst ->* args*) + (funcall cc (make-compound* head args*))))))) + +(defun substitute-for-variable-once (cc new old x subst) + (dereference + x subst + :if-compound-cons (let ((u (carc x)) (v (cdrc x))) + (prog-> + (substitute-for-variable-once new old u subst ->* u*) + (funcall cc (cons u* v))) + (prog-> + (substitute-for-variable-once new old v subst ->* v*) + (funcall cc (cons u v*)))) + :if-compound-appl (prog-> + (argsa x ->nonnil args) + (heada x -> head) + (substitute-for-variable-oncel new old args subst ->* args*) + (funcall cc (make-compound* head args*))) + :if-variable (when (eq old x) + (funcall cc new)))) + +(defun substitute-for-constantl (new old l subst) + (lcons (substitute-for-constant new old (first l) subst) + (substitute-for-constantl new old (rest l) subst) + l)) + +(defun substitute-for-compoundl (new old l subst) + (lcons (substitute-for-compound new old (first l) subst) + (substitute-for-compoundl new old (rest l) subst) + l)) + +(defun substitute-for-variablel (new old l subst) + (lcons (substitute-for-variable new old (first l) subst) + (substitute-for-variablel new old (rest l) subst) + l)) + +(defun substitute-for-constant-oncel (cc new old l subst) + (let ((a (first l)) (d (rest l))) + (prog-> + (substitute-for-constant-once new old a subst ->* a*) + (funcall cc (cons a* d))) + (when d + (prog-> + (substitute-for-constant-oncel new old d subst ->* d*) + (funcall cc (cons a d*)))))) + +(defun substitute-for-compound-oncel (cc new old l subst) + (let ((a (first l)) (d (rest l))) + (prog-> + (substitute-for-compound-once new old a subst ->* a*) + (funcall cc (cons a* d))) + (when d + (prog-> + (substitute-for-compound-oncel new old d subst ->* d*) + (funcall cc (cons a d*)))))) + +(defun substitute-for-variable-oncel (cc new old l subst) + (let ((a (first l)) (d (rest l))) + (prog-> + (substitute-for-variable-once new old a subst ->* a*) + (funcall cc (cons a* d))) + (when d + (prog-> + (substitute-for-variable-oncel new old d subst ->* d*) + (funcall cc (cons a d*)))))) + +;;; substitute.lisp EOF diff --git a/src/subsume-bag.lisp b/src/subsume-bag.lisp new file mode 100644 index 0000000..db53cff --- /dev/null +++ b/src/subsume-bag.lisp @@ -0,0 +1,192 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: subsume-bag.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; notes: +;;; should check sort compatibility of variable and (fn ...) earlier +;;; incomplete identity handling +;;; variables in terms1 can be bound to identity +;;; count-arguments, recount-arguments don't eliminate identity +;;; using recount-arguments is somewhat inefficient +;;; it recompares terms in terms2 +;;; it could check whether terms in terms1 are frozen +;;; use solve-sum instead of solve-sum-solutions? + +(defun subsume-bag (cc terms1 terms2 subst fn) + ;; assume variables of terms2 are already frozen + ;; eliminate terms in common, find multiplicities + (subsume-bag0 cc (count-arguments fn terms2 subst (count-arguments fn terms1 subst) -1) subst fn)) + +(defun subsume-bag0 (cc terms-and-counts subst fn) + ;; ensure length constraint is satisfiable + (let ((len1 0) (len2 0) (vars nil) (varc 0)) + (dolist (tc terms-and-counts) + (let ((c (tc-count tc))) + (cond + ((plusp c) + (if (unfrozen-variable-p (tc-term tc)) + (progn + (push c vars) + (incf varc c)) + (incf len1 c))) + ((minusp c) + (decf len2 c))))) + (cond + ((null vars) + (when (eql len1 len2) + (if (eql 0 len1) + (funcall cc subst) + (subsume-bag1 cc terms-and-counts subst fn)))) + ((if (eq none (function-identity2 fn)) + (and (<= (+ len1 varc) len2) (solve-sum-p (- len2 len1 varc) vars)) + (and (<= len1 len2) (solve-sum-p (- len2 len1) vars))) + (if (eql 0 len1) + (subsume-bag2 cc terms-and-counts subst fn) + (subsume-bag1 cc terms-and-counts subst fn)))))) + +(defun subsume-bag1 (cc terms-and-counts subst fn) + ;; eliminate highest multiplicity nonvariable term in terms1 + ;; by matching it with terms in terms2 + (prog-> + (maxtc1 terms-and-counts subst -> tc1) +;; (cl:assert tc1) + (unless (eq 'quit tc1) ;unmatched frozen term in terms1 + (dolist terms-and-counts ->* tc2) + (when (<= (tc-count tc1) (- (tc-count tc2))) + (unify (tc-term tc1) (tc-term tc2) subst ->* subst) + (subsume-bag0 cc (recount-arguments fn terms-and-counts subst) subst fn))))) + +(defun subsume-bag2 (cc terms-and-counts subst fn) + ;; only variables left in terms1 + ;; generate equations to apportion terms in terms2 to variables + (let ((vars nil) (terms nil) (coefs nil) (boundss nil) (sums nil)) + (dolist (tc terms-and-counts) + (let ((c (tc-count tc))) + (when (plusp c) + (push (tc-term tc) vars) + (push c coefs)))) + (dolist (tc terms-and-counts) + (let ((c (tc-count tc))) + (when (minusp c) + (setf c (- c)) + (let* ((term (tc-term tc)) + (bounds (compute-bounds c coefs vars term subst fn))) + (when (and bounds (loop for b in bounds always (eql 0 b))) + (return-from subsume-bag2)) ;can't match term + (push term terms) + (push bounds boundss) + (push c sums))))) + (subsume-bag3 cc vars terms coefs boundss sums subst fn))) + +(defun subsume-bag3 (cc vars terms coefs boundss sums subst fn) + ;; solve equations that apportion all occurrences of each term among variables + (subsume-bag4 + cc + vars + (consn nil nil (length vars)) + terms + (loop for bounds in boundss + as sum in sums + collect (or (solve-sum-solutions sum coefs bounds) + (return-from subsume-bag3))) + subst + fn)) + +(defun subsume-bag4 (cc vars vals terms solss subst fn) + ;; generate substitutions from equation solutions + (cond + ((null terms) + (let ((identity (function-identity2 fn)) + (fn-sort (function-sort fn))) + (unless (and (eq none identity) (member nil vals)) + (do ((vars vars (rest vars)) + (vals vals (rest vals))) + ((null vars) + (funcall cc subst)) + (let ((var (first vars)) + (val (first vals))) + (cond + ((null val) + (if (term-sort-p identity (variable-sort var)) + (setf subst (bind-variable-to-term var identity subst)) + (return))) + ((null (rest val)) + ;; already checked sort compatibility in compute-bounds + (setf subst (bind-variable-to-term var (first val) subst))) + (t + ;; it would be more efficient to check sort compatibility earlier + (if (subsort? fn-sort (variable-sort var)) + (setf subst (bind-variable-to-term var (make-compound* fn val) subst)) + (return))))))))) + (t + (let ((term (pop terms))) + (dolist (sol (pop solss)) + (subsume-bag4 + cc + vars + (mapcar (lambda (val) + (let ((k (pop sol))) + (if (or (null k) (eql 0 k)) + val + (consn term val k)))) + vals) + terms + solss + subst + fn)))))) + +(defun maxtc1 (terms-and-counts subst) + ;; find term-and-count for nonvariable term with maximum positive count + (let ((maxtc1 nil)) + (dolist (tc terms-and-counts) + (let ((c (tc-count tc))) + (when (plusp c) + (let ((term (tc-term tc))) + (cond + ((unfrozen-variable-p term) + ) + ((frozen-p term subst) + (return-from maxtc1 'quit)) + ((or (null maxtc1) (> c (tc-count maxtc1))) + (setf maxtc1 tc))))))) + maxtc1)) + +(defun compute-bounds (sum coefs vars term subst fn) + ;; set bound of zero for variables of too high multiplicity or that occur in term + (prog-> + (mapcar coefs vars ->* coef var) + (cond + ((or (> coef sum) (variable-occurs-p var term subst)) + 0) + ((function-boolean-valued-p fn) + nil) + (t + (variable-sort var -> sort) + (cond + ((top-sort? sort) + nil) + ((not (subsort? (term-sort term subst) sort)) + 0) + ((not (subsort? (function-sort fn) sort)) + 1) + (t + nil)))))) + +;;; subsume-bag.lisp EOF diff --git a/src/subsume-clause.lisp b/src/subsume-clause.lisp new file mode 100644 index 0000000..73755cb --- /dev/null +++ b/src/subsume-clause.lisp @@ -0,0 +1,349 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: subsume-clause.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2007. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun clause-subsumes-p (clause1 clause2) + ;; does clause1 subsume clause2? + (clause-subsumes-p1 + (atoms-in-clause2 clause1) + (atoms-in-clause2 clause2) + (variables clause2 nil *frozen-variables*))) + +(defun clause-subsumes-p1 (l1 l2 frozen-variables) + (prog-> + (clause-subsumes1 l1 l2 frozen-variables ->* subst) + (declare (ignore subst)) + (return-from prog-> t))) + +(defun clause-subsumes1 (cc l1 l2 frozen-variables) + ;; returns nil + (cond + ((null l1) ;clause1 is the empty clause + (funcall cc nil) + nil) + ((null l2) ;clause2 is the empty clause + nil) + (t + (with-clock-on clause-clause-subsumption + (clause-subsumes2 cc l1 l2 frozen-variables))))) + +(defun clause-subsumes2 (cc l1 l2 frozen-variables) + ;; returns nil + (cond + ((null (rest l1)) ;clause1 is a unit clause + (prog-> + (quote t -> *subsuming*) + (identity frozen-variables -> *frozen-variables*) + (first l1 -> lit1) + (first lit1 -> atom1) + (second lit1 -> polarity1) + (dolist l2 ->* lit2) + (when (eq polarity1 (second lit2)) + (unify atom1 (first lit2) nil ->* subst) + (funcall cc subst)))) + (t + ;; new DPLL-based approach 2004-10 + (prog-> + (make-subsumption-test-dp-clause-set l1 l2 frozen-variables -> clause-set subst0) + (case clause-set + (:unsatisfiable + nil) + (:empty-set-of-clauses + (funcall cc subst0) + nil) + (otherwise + (when (trace-dpll-subsumption?) + (format t "~2%Does ~S" (atoms-to-clause2 l1)) + (format t "~1%subsume ~S" (atoms-to-clause2 l2)) + (when subst0 + (format t "~%Matching substitution must include ") + (print-substitution subst0)) + (when (eq :clauses (trace-dpll-subsumption?)) + (format t "~%Matching substitution must satisfy") + (dp-clauses 'print clause-set))) + (dp-satisfiable-p + clause-set + :find-all-models -1 + :model-test-function (lambda (model) + (let ((subst subst0)) + (dolist (atom model) + (when (and (consp atom) (eq 'bind (first atom))) + (setf subst (add-binding-to-substitution (second atom) subst)))) + (when (trace-dpll-subsumption?) + (format t "~&Found matching substitution ") + (print-substitution subst)) + (funcall cc subst) + t)) + :more-units-function (and (use-lookahead-in-dpll-for-subsumption?) #'lookahead-true) + :pure-literal-check nil + :print-warnings (trace-dpll-subsumption?) + :print-summary (trace-dpll-subsumption?) + :trace nil + :trace-choices nil) + nil)))))) + +(defun make-subsumption-test-dp-clause-set (l1 l2 frozen-variables) + (prog-> + (make-subsumption-test-clauses l1 l2 frozen-variables -> clauses subst) + (cond + ((eq :unsatisfiable clauses) + :unsatisfiable) + ((null clauses) + (values :empty-set-of-clauses subst)) + (t + (values (make-subsumption-test-dp-clause-set1 clauses subst) subst))))) + +(defun reorder-atoms2 (l1 l2) + ;; reorder l1 to increase likelihood that determinate matches appear first + ;; count number of occurrences of polarity-relation pairs in l2 + ;; (count '=' doubly because it is symmetric and often matches twice) + ;; reorder l1 in ascending order of count in l2 + (let ((counts nil)) + ;; count polarity-relation pairs in l2 + (prog-> + (dolist l2 ->* x) + (second x -> polarity) + (first x -> atom) + (if (compound-p atom) (head atom) atom -> head) + (dolist counts (push (list* head polarity (if (eq *=* head) 2 1)) counts) ->* y) + (when (and (eq head (first y)) (eq polarity (second y))) + (incf (cddr y) (if (eq *=* head) 2 1)) + (return))) + (when (prog-> ;only annotate (and sort) if counts are not uniform + (cddr (first counts) -> n) + (dolist (rest counts) nil ->* y) + (when (not (eql n (cddr y))) + (return t))) + ;; annotate l1 with counts in l2 + (let ((l1* (prog-> + (mapcar l1 ->* x) + (second x -> polarity) + (first x -> atom) + (if (compound-p atom) (head atom) atom -> head) + (dolist counts (return-from reorder-atoms2 :unsatisfiable) ->* y) + (when (and (eq head (first y)) (eq polarity (second y))) + (return (cons (cddr y) x)))))) + (when (prog-> ;only sort if counts in l1 are not uniform + (first (first l1*) -> n) + (dolist (rest l1*) nil ->* x) + (when (not (eql n (first x))) + (return t))) + (setf l1* (stable-sort l1* #'< :key #'car)) + ;; remove annotation + (prog-> + (dotails l1* ->* l) + (setf (first l) (cdr (first l)))) + (setf l1 l1*)))) + l1)) + +(defun refine-substs (clauses subst) + ;; eliminate matches in clauses that are incompatible with subst + ;; return :unsatisfiable if a clause becomes empty after eliminating all its matches + ;; trim away bindings that are already in subst + (dotails (l clauses) + (let* ((shortened nil) + (clause (delete-if (lambda (x) + (let* ((subst1 (cdr x)) + (subst1* (substitution-diff2 subst1 subst))) + (cond + ((eq none subst1*) ;incompatible with subst + (setf shortened t)) ;delete it + (t + (unless (eq subst subst1*) + (setf (cdr x) subst1*)) ;subst1 duplicated bindings in subst + nil)))) + (first l)))) + (when shortened + (if (null clause) + (return-from refine-substs :unsatisfiable) + (setf (first l) clause))))) + (values clauses subst)) + +(defun make-subsumption-test-clauses (l1 l2 *frozen-variables*) + ;; reorder l1 to increase likelihood that determinate matches appear first + (setf l1 (reorder-atoms2 l1 l2)) + (when (eq :unsatisfiable l1) + (return-from make-subsumption-test-clauses :unsatisfiable)) + (let ((clauses nil) + (subst nil) + (*subsuming* t)) + (prog-> + (quote nil -> subst1) + (quote 0 -> i) + (dolist l1 ->* lit1) + (incf i) + (first lit1 -> atom1) + (second lit1 -> polarity1) + (quote nil -> clause) ;list of possible matches for atom1 in l2 + (prog-> + (quote 0 -> j) + (dolist l2 ->* lit2) + (incf j) + (first lit2 -> atom2) + (second lit2 -> polarity2) + (when (eq polarity1 polarity2) + (quote 0 -> k) + (block unify + (unify atom1 atom2 subst ->* subst*) + (incf k) + (cond + ((eq subst subst*) ;atom1 matches atom2 with no (further) instantiation + (setf clause none) ;no clause or further search for atom1 matches is needed + (return-from prog->)) + (t + (setf subst1 subst*) ;save subst* in case this is the only match for atom1 + (push (cons (list 'match i j k) + (substitution-diff subst* subst)) + clause))) ;clause is list of (match-atom . subst) pairs for later processing + (when (and (test-option36?) (<= (test-option36?) k)) + (return-from unify))))) + (cond + ((null clause) ;there is no match for atom1, quit + (return-from make-subsumption-test-clauses :unsatisfiable)) + ((neq none clause) + (if (null (rest clause)) ;if there is only one match for atom1 + (setf subst subst1) ;force other matches to extend it + (push clause clauses))))) + (if (and subst clauses) (refine-substs clauses subst) (values clauses subst)))) + +(defun make-subsumption-test-dp-clause-set1 (clauses subst) + (let ((clause-set (make-dp-clause-set)) + (empty :empty-set-of-clauses) + (dp-binding-atoms nil)) + (labels + ((dp-binding-atom (binding &optional tv) + ;; wrapper around dp-atom-named to ensure that there are no two binding atoms + ;; for same variable whose values are equal-p + ;; dp-binding-atoms is nested alists for mapping var -> val -> binding-atom + (let* ((var (binding-var binding)) + (val (binding-value binding)) + (v (assoc var dp-binding-atoms :test #'eq)) + (v1 (if v (rest v) (progn (push (setf v (cons var nil)) dp-binding-atoms) nil)))) + (let ((v2 (and v1 (assoc-p val v1)))) + (if (null v2) + (let ((atom (or tv (snark-dpll::dp-atom-named (list 'bind binding) clause-set :if-does-not-exist :create)))) + (setf (rest v) (cons (cons val atom) v1)) + atom) + (cdr v2)))))) + (dobindings (binding subst) + (dp-binding-atom binding true)) + (prog-> + (dolist clauses ->* clause) + (cl:assert clause) ;no empty clauses + (prog-> + (dotails clause ->* l) + (cdr (first l) -> subst) + (snark-dpll::dp-atom-named (car (first l)) clause-set :if-does-not-exist :create -> match-atom) + (setf (first l) match-atom) ;replace (match-atom . subst) by dp-match-atom in clause + (quote nil -> binding-atoms) + (dobindings (binding subst) + (prog-> + (dp-binding-atom binding -> atom) + (unless (eq true atom) + (push atom binding-atoms)))) + (cond + ((null binding-atoms) + (setf clause none) ;atom is aleady matched, ignore this clause + (return-from prog->)) + (t + ;; add clauses for (iff match (and binding1 ... bindingn)) + (setf empty nil) + (dp-insert (cons match-atom (and binding-atoms (mapcar (lambda (x) (list 'not x)) binding-atoms))) clause-set :print-warnings :safe) + (list (list 'not match-atom) -> match-lit-list) + (dolist (atom binding-atoms) + (dp-insert (cons atom match-lit-list) clause-set :print-warnings :safe))))) + ;; add (or (match m) ... (match n)) clause for all the ways one literal can match + (unless (eq none clause) + (dp-insert clause clause-set :print-warnings :safe))) + (when empty + (return-from make-subsumption-test-dp-clause-set1 empty)) + ;; add clauses for unsatisfiability of var=val1, var=val2 bindings + (prog-> + (dolist dp-binding-atoms ->* v) ;v=(var ((val_1 . dp-binding-atom_1)) ... (val_n . dp-binding-atom_n)) + (dotails (cdr v) ->* v1) + (first v1 -> p1) ;p1=(val_i . dp-binding-atom_i) + (cdr p1 -> atom_i) + (if (eq true atom_i) nil (list (list 'not atom_i)) -> lit_i-list) + (dolist (rest v1) ->* p2) ;p2=(val_j . dp-binding-atom_j) + (cdr p2 -> atom_j) + (cond + ((neq true atom_j) + (list 'not atom_j -> lit_j) + (dp-insert (cons lit_j lit_i-list) clause-set :print-warnings :safe)) + (lit_i-list + (dp-insert lit_i-list clause-set :print-warnings :safe)) + (t + (return-from make-subsumption-test-dp-clause-set1 :unsatisfiable)))) ;never happens (requires subst to be inconsistent) + clause-set))) + +(defun condenser (clause) + ;; new approach 2004-10 + ;; enumerate matching substitutions of clause (renumbered) to itself + ;; there is at least one but we search for one that matches all literals + ;; in clause to a subset of its literals + ;; remove any literals in the clause that are left over after the match + ;; + ;; for example, when condensing (or (p ?x) (p a)), + ;; (or (p ?x') (p a)) subsumes (or (p ?x) (p a)) with {x' -> a} + ;; but (p ?x) does not occur in (or (p ?x') (p a)).{x' -> a} + ;; so (p ?x) can be removed to yield (p a) by condensing + ;; + ;; efficiency issue: how often will there be too many matching substitutions of clause to itself? + ;; + ;; should be improved by dynamically adding dp-clauses to force models to extend condensing one + ;; also could stop early if condensed to unit or ground clause + (let ((l2 (atoms-in-clause2 clause)) + (condensed nil)) + (cond + ((null (rest l2)) ;no condensing of unit clauses + clause) + (t + (let ((vars (variables l2))) + (cond + ((null vars) ;no condensing of ground clauses + clause) + (t + (prog-> + (renumber-new l2 -> l1) + (clause-subsumes2 l1 l2 vars ->* subst) ;does l2 subsume itself? + (identity condensed -> new-condensed) + (block mapc + (mapc l1 l2 ->* y1 x) + (cond + ((and ;is x unmatched by l1.subst? + (not (equal-p (first x) (first y1) subst)) ;try this likely match first + (not (member x l1 :test (lambda (x y) ;then the others + (and (and (neq y1 y)) + (eq (second x) (second y)) + (equal-p (first x) (first y) subst)))))) + (unless (and condensed (member x condensed :test #'eq)) + (push x new-condensed))) + ((and condensed (member x condensed :test #'eq)) + (setf new-condensed nil) + (return-from mapc)))) + (when (and new-condensed (neq condensed new-condensed)) + (setf condensed new-condensed) + (when (trace-dpll-subsumption?) + (format t "~%Can remove ~A by condensing" (atoms-to-clause2 condensed))))) + (if condensed + (atoms-to-clause2 (delete-if (lambda (x) (member x condensed :test #'eq)) l2)) + clause)))))))) + +;;; subsume-clause.lisp EOF diff --git a/src/subsume.lisp b/src/subsume.lisp new file mode 100644 index 0000000..8b44136 --- /dev/null +++ b/src/subsume.lisp @@ -0,0 +1,503 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: subsume.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim + (special + *false-rows* + *constraint-rows*)) + +(defvar *subsuming* nil) + +(defun make-and-freeze-variable (&optional sort number) + (let ((v (make-variable sort number))) + (push v *frozen-variables*) + v)) + +(defun subsume (cc x y &optional subst) + (prog-> + (identity *subsuming* -> sb) + (quote t -> *subsuming*) + (identity *frozen-variables* -> fv) ;save list of frozen variables + (variables y subst fv -> *frozen-variables*) ;add y's variables to frozen variables + (unify x y subst ->* subst) + (identity sb -> *subsuming*) + (identity fv -> *frozen-variables*) ;restore list of frozen variables + (funcall cc subst))) + +(defun subsumes-p (x y &optional subst) + ;; x subsumes y? + (subsumes-p1 x y (variables y subst *frozen-variables*) subst)) + +(defun subsumes-p1 (x y *frozen-variables* &optional subst) + (let ((*subsuming* t)) + (unify-p x y subst))) + +(defun subsumed-p (x y &optional subst) + ;; x is subsumed by y? + (subsumed-p1 x y (variables x subst *frozen-variables*) subst)) + +(defun subsumed-p1 (x y *frozen-variables* &optional subst) + (let ((*subsuming* t)) + (unify-p y x subst))) + +(defun subsumers (x y &optional subst) + (subsumers1 x y (variables y subst *frozen-variables*) subst)) + +(defun subsumers1 (x y *frozen-variables* &optional subst) + (let ((*subsuming* t)) + (unifiers x y subst))) + +;;; use-subsumption = nil don't use subsumption +;;; use-subsumption = :forward use only forward subsumption +;;; use-subsumption = t use forward and backward subsumption +;;; +;;; use-subsumption-by-false further specifies the behavior of use-subsumption in the case of +;;; "false rows" (those for which row-wff is false, kept in *false-rows* and *constraint-rows*) +;;; +;;; use-subsumption-by-false = nil don't use subsumption +;;; use-subsumption-by-false = :false use only forward subsumption on other false rows +;;; use-subsumption-by-false = :forward use just forward subsumption generally +;;; use-subsumption-by-false = t use forward and backward subsumption + +(defvar clause-subsumption t) + +(defvar subsumption-mark) + +(defun forward-subsumed (row) + (prog-> + (forward-subsumption row ->* subsuming-row) + (return-from forward-subsumed subsuming-row)) + nil) + +(defun forward-subsumption (cc row) + (when (row-hint-p row) + (return-from forward-subsumption nil)) ;no forward subsumption of hints + (with-clock-on forward-subsumption + (prog-> + (row-context-live? row ->nonnil row-context) + (flet ((fsubsume (row2 test) + (when (row-hint-p row2) + (return-from fsubsume nil)) ;no forward subsumption by hints + (prog-> + (row-context-live? row2 ->nonnil row2-context) + (context-subsumes? row2-context row-context ->nonnil new-row-context) + (cond + ((eq t new-row-context) + (when (implies test (wff-subsumption nil row2 row)) + (funcall cc row2))) + (t + (when (implies test (wff-subsumption nil row2 row)) + (setf (row-context row) (setf row-context new-row-context)))))))) + (prog-> + (row-wff row -> wff) + (when (let ((u (use-subsumption-by-false?))) (if (eq :false u) (eq false wff) u)) + (prog-> + (map-rows :rowset *false-rows* :reverse t ->* row2) + (fsubsume row2 t)) + (prog-> + (map-rows :rowset *constraint-rows* :reverse t ->* row2) + (fsubsume row2 t))) + (cond + ((eq false wff) + ) + ((and clause-subsumption (or (clause-p wff) (setf clause-subsumption nil))) + (forward-clause-subsumption row ->* row2) + (fsubsume row2 nil)) + (t + (forward-or-backward-wff-subsumption wff :pos :only nil (incf subsumption-mark) nil row ->* row2) + (fsubsume row2 nil)))))))) + +(defun backward-subsumption (cc row) + (when (row-hint-p row) + (return-from backward-subsumption nil)) ;no backward subsumption by hints + (with-clock-on backward-subsumption + (prog-> + (row-context-live? row ->nonnil row-context) + (flet ((bsubsume (row2 test) + (prog-> + (row-context-live? row2 ->nonnil row2-context) + (context-subsumes? row-context row2-context ->nonnil new-row2-context) + (cond + ((eq t new-row2-context) + (when (implies test (wff-subsumption nil row row2)) + (cond + ((row-hint-p row2) + (pushnew row2 *hints-subsumed*)) ;row2 is a hint backward subsumed by row + (t + (funcall cc row2))))) + ((row-hint-p row2) + ) + (t + (when (implies test (wff-subsumption nil row row2)) + (setf (row-context row2) new-row2-context))))))) + (prog-> + (row-wff row -> wff) + (cond + ((eq false wff) + (when (let ((u (use-subsumption-by-false?))) (and u (neq :forward u) (neq :false u))) + (map-rows :reverse t ->* row2) + (bsubsume row2 t))) + ((and clause-subsumption (or (clause-p wff) (setf clause-subsumption nil))) + (backward-clause-subsumption row ->* row2) + (bsubsume row2 nil)) + (t + (forward-or-backward-wff-subsumption wff :pos :only nil (incf subsumption-mark) t row ->* row2) + (bsubsume row2 nil)))))))) + +(defun forward-clause-subsumption (cc row2) + ;; for safey, do funcall cc outside of map-feature-vector-row-index + (let ((candidates nil)) + (prog-> + (map-feature-vector-row-index-forward-subsumption-candidates row2 ->* row) + ;; (format t "~%Feature-vector-row-index possibly forward subsuming row: ~D" (row-number row)) + (push row candidates)) + (dolist (row candidates) + (when (if (use-dp-subsumption?) (dp-subsume+ row row2) (clause-subsumption row row2)) + (funcall cc row))))) + +(defun backward-clause-subsumption (cc row2) + ;; for safey, do funcall cc outside of map-feature-vector-row-index + (let ((candidates nil)) + (prog-> + (map-feature-vector-row-index-backward-subsumption-candidates row2 ->* row) + ;; (format t "~%Feature-vector-row-index possibly backward subsumed row: ~D" (row-number row)) + (push row candidates)) + (dolist (row candidates) + (when (if (use-dp-subsumption?) (dp-subsume+ row2 row) (clause-subsumption row2 row)) + (funcall cc row))))) + +(defun clause-subsumption (subsuming-row subsumed-row) + (when (wff-symbol-counts-not-greaterp (row-wff-symbol-counts subsuming-row) (row-wff-symbol-counts subsumed-row)) + (catch 'subsumed + (prog-> + (atoms-in-clause2 (row-wff subsuming-row) -> l1) + (atoms-in-clause2 (row-wff subsumed-row) -> l2) + (row-constraints subsuming-row -> subsuming-constraint-alist) + (row-constraints subsumed-row -> subsumed-constraint-alist) + (row-answer subsuming-row -> subsuming-answer) + (row-answer subsumed-row -> subsumed-answer) + (quote t -> *subsuming*) + (row-variables subsumed-row *frozen-variables* -> *frozen-variables*) + (clause-subsumption1 l1 l2 subsuming-answer subsumed-answer ->* subst) + (cond + #+ignore + ((use-constraint-solver-in-subsumption?) + (when (eq false + (funcall (constraint-simplification-function?) + (conjoin subsuming-constraint (negate subsumed-constraint subst) subst))) + (throw 'subsumed t))) + (t + (dp-subsume-constraint-alists* subsuming-constraint-alist subsumed-constraint-alist subst ->* subst) + (declare (ignore subst)) + (throw 'subsumed t)))) + nil))) + +(defun clause-subsumption1 (cc l1 l2 subsuming-answer subsumed-answer) + (prog-> + (cond + ((eq false subsuming-answer) + (clause-subsumes1 l1 l2 *frozen-variables* ->* subst) + (funcall cc subst)) + ((eq false subsumed-answer) + ) + ((and #+ignore (test-option37?) #-ignore nil (clause-p subsuming-answer) (clause-p subsumed-answer)) + (atoms-in-clause2 subsuming-answer -> ans1) + (atoms-in-clause2 subsumed-answer -> ans2) + (cl:assert (disjoint-answer-relations-p l1 l2 ans1 ans2)) + (clause-subsumes1 (append ans1 l1) (append ans2 l2) *frozen-variables* ->* subst) + (funcall cc subst)) + (t + (clause-subsumes1 l1 l2 *frozen-variables* ->* subst) + (subsume-answers subsuming-answer subsumed-answer subst ->* subst) + (funcall cc subst))))) + +(defun disjoint-answer-relations-p (l1 l2 ans1 ans2) + (and (notany (lambda (x) + (or (member (head-or-term (car x)) l2 :key (lambda (y) (head-or-term (car y)))) + (member (head-or-term (car x)) l1 :key (lambda (y) (head-or-term (car y)))))) + ans1) + (notany (lambda (x) + (or (member (head-or-term (car x)) l2 :key (lambda (y) (head-or-term (car y)))) + (member (head-or-term (car x)) l1 :key (lambda (y) (head-or-term (car y)))))) + ans2))) + +(defun forward-or-backward-wff-subsumption (cc subwff polarity phase old-mark new-mark backward-p row) + (dereference + subwff nil + :if-variable (error "Can't use variable wff in subsumption.") + :if-constant (cond + ((or (eq true subwff) (eq false subwff)) + (error "Can't use truth values in subsumption.")) + (t + (forward-or-backward-atom-subsumption cc subwff polarity phase old-mark new-mark backward-p row))) + :if-compound (let* ((head (head subwff)) + (kind (function-logical-symbol-p head)) + (args (args subwff))) + (when (and kind (null args)) + (error "Can't use connectives with no arguments in subsumption.")) + (ecase kind + (not + (forward-or-backward-wff-subsumption + cc (first args) (opposite-polarity polarity) phase old-mark new-mark backward-p row)) + ((and or) + (cond + ((if backward-p (eq 'or kind) (eq 'and kind)) + (do ((args args (rest args)) + (first t nil) + (m old-mark) + n) + ((null (rest args)) + (forward-or-backward-wff-subsumption + cc (first args) polarity + (ecase phase + (:only (if first :only :last)) + (:first (if first :first :middle)) + (:middle :middle) + (:last :last)) + m new-mark + backward-p row)) + (setf n (incf subsumption-mark)) + (forward-or-backward-wff-subsumption + cc (first args) polarity + (ecase phase + (:only (if first :first :middle)) + (:first (if first :first :middle)) + (:middle :middle) + (:last :middle)) + m n + backward-p row) + (setf m n))) + (t + (do ((args args (rest args))) + ((null args)) + (forward-or-backward-wff-subsumption + cc + (first args) polarity phase old-mark new-mark + backward-p row))))) + (implies + (forward-or-backward-wff-subsumption + cc + (make-compound *or* + (make-compound *not* (first args)) + (second args)) + polarity phase old-mark new-mark + backward-p row)) + (implied-by + (forward-or-backward-wff-subsumption + cc + (make-compound *or* + (make-compound *not* (second args)) + (first args)) + polarity phase old-mark new-mark + backward-p row)) + ((iff xor) ;should be more efficient + (cond + ((null (rest args)) + (forward-or-backward-wff-subsumption + cc (first args) polarity phase old-mark new-mark backward-p row)) + (t + (let ((x (first args)) + (y (if (null (cddr args)) (second args) (make-compound head (rest args))))) + (forward-or-backward-wff-subsumption + cc + (if (eq 'iff kind) + (make-compound *or* + (make-compound *and* + x + y) + (make-compound *and* + (make-compound *not* x) + (make-compound *not* y))) + (make-compound *or* + (make-compound *and* + x + (make-compound *not* y)) + (make-compound *and* + (make-compound *not* x) + y))) + polarity phase old-mark new-mark + backward-p row))))) + (if ;should be more efficient + (forward-or-backward-wff-subsumption + cc + (make-compound *and* + (make-compound *or* + (make-compound *not* (first args)) + (second args)) + (make-compound *and* + (first args) + (third args))) + polarity phase old-mark new-mark + backward-p row)) + ((nil) + (forward-or-backward-atom-subsumption + cc subwff polarity phase old-mark new-mark backward-p row)))))) + +(defun forward-or-backward-atom-subsumption (cc atom polarity phase old-mark new-mark backward-p row) + (funcall (if backward-p #'retrieve-instance-entries #'retrieve-generalization-entries) + (lambda (e row2s) + (declare (ignore e)) + (prog-> + (map-rows :rowset row2s ->* row2) + (ecase phase + (:only + (when (if backward-p + (if (use-dp-subsumption?) + (dp-subsume+ row row2) + (wff-subsumption nil row row2)) + (if (use-dp-subsumption?) + (dp-subsume+ row2 row) + (wff-subsumption nil row2 row))) + (funcall cc row2))) + (:first + (setf (row-subsumption-mark row2) new-mark)) + (:middle + (when (eql (row-subsumption-mark row2) old-mark) + (setf (row-subsumption-mark row2) new-mark))) + (:last + (when (eql (row-subsumption-mark row2) old-mark) + (when (if backward-p + (if (use-dp-subsumption?) + (dp-subsume+ row row2) + (wff-subsumption nil row row2)) + (if (use-dp-subsumption?) + (dp-subsume+ row2 row) + (wff-subsumption nil row2 row))) + (funcall cc row2))))))) + atom + nil + (if (eq polarity :pos) + #'tme-rows-containing-atom-positively + #'tme-rows-containing-atom-negatively))) + +(defun wff-subsumption (matches subsuming-row subsumed-row) + (declare (ignore matches)) + (catch 'subsumed + (prog-> + (row-wff subsuming-row -> subsuming-wff) + (row-wff subsumed-row -> subsumed-wff) + (row-constraints subsuming-row -> subsuming-constraint-alist) + (row-constraints subsumed-row -> subsumed-constraint-alist) + (row-answer subsuming-row -> subsuming-answer) + (row-answer subsumed-row -> subsumed-answer) + + (quote t -> *subsuming*) + (row-variables subsumed-row *frozen-variables* -> *frozen-variables*) + + (quote nil -> subst) + (wff-subsumption* subsuming-wff subsumed-wff subst ->* subst) + (subsume-answers subsuming-answer subsumed-answer subst ->* subst) + (cond + #+ignore + ((use-constraint-solver-in-subsumption?) + (when (eq false + (funcall (constraint-simplification-function?) + (conjoin subsuming-constraint (negate subsumed-constraint subst) subst))) + (throw 'subsumed t))) + (t + (dp-subsume-constraint-alists* subsuming-constraint-alist subsumed-constraint-alist subst ->* subst) +;; (wff-subsumption* subsuming-wff subsumed-wff subst ->* subst) + (declare (ignore subst)) + (throw 'subsumed t)))))) + +(defun wff-subsumption* (cc subsuming-wff subsumed-wff subst) + ;; assume variables of subsumed-wff are already frozen so that + ;; unification really does subsumption + (let (interpretations) + ;; find every interpretation in which subsuming-wff is true and subsumed-wff is false + #| + (salsify t subsuming-wff nil + (lambda (interp1) + (salsify nil subsumed-wff interp1 + (lambda (interp2) + (push (cons interp1 (ldiff interp2 interp1)) interpretations))))) + |# + (let (u v) + (salsify t subsuming-wff nil (lambda (interp1) (push interp1 u))) + (salsify nil subsumed-wff nil (lambda (interp2) (push interp2 v))) + (dolist (interp1 u) + (dolist (interp2 v) + (push (cons interp1 interp2) interpretations)))) + (let (w) + (dolist (interp interpretations) + (let ((n (nmatches interp subst))) + (when (eql 0 n) + (return-from wff-subsumption* nil)) + (push (cons n interp) w))) + (setf w (sort w #'< :key #'car)) + (setf interpretations nil) + (dolist (x w) + (push (cdr x) interpretations))) + (wff-subsumption*1 cc interpretations subst))) + +(defun wff-subsumption*1 (cc interpretations subst) + (cond + ((null interpretations) + (funcall cc subst)) + (t + (dolist (x (car (first interpretations))) + (dolist (y (cdr (first interpretations))) + (unless (eq (cdr x) (cdr y)) + (when (equal-p (car x) (car y) subst) + (wff-subsumption*1 cc (rest interpretations) subst) + (return-from wff-subsumption*1 nil))))) + (dolist (x (car (first interpretations))) + (dolist (y (cdr (first interpretations))) + (unless (eq (cdr x) (cdr y)) + (prog-> + (unify (car x) (car y) subst ->* subst) + (wff-subsumption*1 cc (rest interpretations) subst)))))))) + +(defun nmatches (interpretation subst) + (let ((n 0)) + (dolist (x (car interpretation)) + (dolist (y (cdr interpretation)) + (unless (eq (cdr x) (cdr y)) + (when (unify-p (car x) (car y) subst) + (incf n))))) + n)) + +(defun subsume-answers (cc subsuming-answer subsumed-answer subst) + (cond + ((eq false subsuming-answer) + (funcall cc subst)) + ((eq false subsumed-answer) + ) + ((and (literal-p subsuming-answer) (literal-p subsumed-answer)) + (unify cc subsuming-answer subsumed-answer subst)) + ((and (clause-p subsuming-answer) (clause-p subsumed-answer)) + (prog-> + (instantiate subsuming-answer subst -> subsuming-answer) + (atoms-in-clause2 subsuming-answer -> l1) + (atoms-in-clause2 subsumed-answer -> l2) + (clause-subsumes1 cc l1 l2 *frozen-variables*))) + (t + (wff-subsumption* cc subsuming-answer subsumed-answer subst)))) + +;;; wff-subsumption* allows wffs to subsume their own factors + +;;; when subsuming one atom in an interpretation by +;;; another, make sure one is from the subsuming wff +;;; and the other is from the subsumed wff??? +;;; split these lists to do M*N comparisons +;;; instead of (M+N)*(M+N) + +;;; subsume.lisp EOF diff --git a/src/symbol-definitions.lisp b/src/symbol-definitions.lisp new file mode 100644 index 0000000..27ee0e4 --- /dev/null +++ b/src/symbol-definitions.lisp @@ -0,0 +1,184 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: symbol-definitions.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim (special *skolem-function-alist*)) + +(defvar *all-both-polarity*) + +(eval-when (:load-toplevel :execute) + (setf *all-both-polarity* (cons (constantly :both) nil)) + (rplacd *all-both-polarity* *all-both-polarity*) + nil) + +(defun initialize-symbol-table () + (setf *skolem-function-alist* nil) + (make-symbol-table)) + +(defun initialize-symbol-table2 () + (declare-proposition 'true :locked t) + (declare-proposition 'false :locked t) + ;; SNARK code assumes that propositions and constants with the same name have different + ;; internal representations so that different properties can be specified for them + ;; this includes the case for true and false, which are treated specially + (cl:assert (neq true 'true)) + (cl:assert (neq false 'false)) + (setf *not* + (declare-logical-symbol + 'not + :make-compound*-function #'negate* + :input-code #'input-negation + :polarity-map (list #'opposite-polarity) + :rewrite-code '(not-wff-rewriter))) + (setf *and* + (declare-logical-symbol + 'and + :make-compound*-function #'conjoin* + :input-code #'input-conjunction + :associative (use-ac-connectives?) + :commutative (use-ac-connectives?) + :rewrite-code (if (use-ac-connectives?) '(and-wff-rewriter) nil))) + (setf *or* + (declare-logical-symbol + 'or + :make-compound*-function #'disjoin* + :input-code #'input-disjunction + :associative (use-ac-connectives?) + :commutative (use-ac-connectives?) + :rewrite-code (if (use-ac-connectives?) '(or-wff-rewriter) nil))) + (setf *implies* + (declare-logical-symbol + 'implies + :make-compound*-function #'make-implication* + :input-code #'input-implication + :polarity-map (list #'opposite-polarity) + :rewrite-code '(implies-wff-rewriter))) + (setf *implied-by* + (declare-logical-symbol + 'implied-by + :make-compound*-function #'make-reverse-implication* + :input-code #'input-reverse-implication + :polarity-map (list #'identity #'opposite-polarity) + :rewrite-code '(implied-by-wff-rewriter))) + (setf *iff* + (declare-logical-symbol + 'iff + :make-compound*-function #'make-equivalence* + :input-code #'input-equivalence + :polarity-map *all-both-polarity* + :associative (use-ac-connectives?) + :commutative (use-ac-connectives?) + :alias '<=>)) + (setf *xor* + (declare-logical-symbol + 'xor + :make-compound*-function #'make-exclusive-or* + :input-code #'input-exclusive-or + :polarity-map *all-both-polarity* + :associative (use-ac-connectives?) + :commutative (use-ac-connectives?))) + (setf *if* + (declare-logical-symbol + 'if + :make-compound*-function #'make-conditional* + :input-code #'input-conditional + :polarity-map (list (constantly :both)))) + (setf *answer-if* + (declare-logical-symbol + 'answer-if + :make-compound*-function #'make-conditional-answer* + :input-code #'input-conditional-answer + :polarity-map (list (constantly :both)))) + (setf *forall* (declare-logical-symbol 'forall :input-code #'input-quantification :to-lisp-code #'quant-compound-to-lisp)) + (setf *exists* (declare-logical-symbol 'exists :input-code #'input-quantification :to-lisp-code #'quant-compound-to-lisp)) + (setf *=* (declare-relation1 '= 2 :input-code #'input-equality :rewrite-code '(equality-rewriter arithmetic-relation-rewriter) :satisfy-code '(reflexivity-satisfier) :commutative t)) + (declare-logical-symbol '=> :macro t :input-code #'input-kif-forward-implication) + (declare-logical-symbol '<= :macro t :input-code #'input-kif-backward-implication) + (declare-logical-symbol 'nand :macro t :input-code #'input-nand) + (declare-logical-symbol 'nor :macro t :input-code #'input-nor) + (declare-relation1 '/= 2 :macro t :input-code #'input-disequality) + (setf (function-boolean-valued-p *=*) '=) + (setf (function-logical-symbol-dual *and*) *or*) + (setf (function-logical-symbol-dual *or*) *and*) + (setf (function-logical-symbol-dual *forall*) *exists*) + (setf (function-logical-symbol-dual *exists*) *forall*) + + (setf *a-function-with-left-to-right-ordering-status* (declare-function '$$_internal1 :any :ordering-status :left-to-right)) + (setf *a-function-with-multiset-ordering-status* (declare-function '$$_internal2 :any :ordering-status :multiset)) + + (declare-function1 '$$quote :any :macro t :input-code #'input-quoted-constant) + #+ignore + (declare-relation2 '$$eqe 2 :rewrite-code 'equality-rewriter :satisfy-code 'constructor-reflexivity-satisfier :alias '$$eq_equality :constraint-theory 'equality) + (declare-code-for-lists) + (declare-code-for-bags) + (declare-code-for-strings) + (declare-code-for-numbers) + (declare-code-for-dates) + (declare-constant '$$empty-flat-bag :locked t :constructor t) + (declare-function1 '$$flat-bag 2 :associative t :commutative t :identity '$$empty-flat-bag) + (declare-constant '$$empty-flat-list :locked t :constructor t) + (declare-function1 '$$flat-list 2 :associative t :identity '$$empty-flat-list) + + #+ignore + (declare-relation2 'nonvariable 1 :rewrite-code 'nonvariable-rewriter :satisfy-code 'nonvariable-satisfier) + #+ignore + (declare-function 'the 2 :rewrite-code 'the-term-rewriter) + nil) + +(defun initialize-sort-theory2 () + (declare-subsort 'top-sort-a t :subsorts-incompatible t :alias :top-sort-a) + (declare-subsort 'string 'top-sort-a) + (declare-subsort 'list 'top-sort-a) + (declare-subsort 'number 'top-sort-a :alias 'complex) + (declare-subsort 'time-interval 'top-sort-a) + (declare-subsort 'time-point 'top-sort-a) + + (declare-subsort 'real 'complex) + (declare-subsort 'rational 'real) + (declare-subsort 'integer 'rational) + + (declare-subsort 'nonnegative 'real :alias '(nonnegative-real nonnegative-number)) + (declare-subsort 'nonpositive 'real) + (declare-subsort 'nonzero 'number :alias 'nonzero-number) + (declare-sorts-incompatible 'nonnegative 'nonpositive 'nonzero) + + (declare-sort 'positive :iff '(and nonnegative nonzero) :alias '(positive-real positive-number)) + (declare-sort 'negative :iff '(and nonpositive nonzero) :alias '(negative-real negative-number)) + (declare-sort 'zero :iff '(and nonnegative nonpositive integer)) + + ;; includes sort names used by declare-number + (dolist (sign '(positive negative nonnegative nonzero)) + (dolist (type '(real rational integer)) + (when (implies (eq 'real type) (eq 'nonzero sign)) + (declare-sort (intern (to-string sign "-" type) :snark) + :iff `(and ,sign ,type) + :alias (and (eq 'nonnegative sign) (eq 'integer type) 'natural))))) + nil) + +(defun number-sort-name (x) + (etypecase x + (integer + (if (< 0 x) 'positive-integer (if (> 0 x) 'negative-integer 'zero))) + (ratio + (if (< 0 x) 'positive-rational 'negative-rational)) + (complex + 'nonzero))) + +;;; symbol-definitions.lisp EOF diff --git a/src/symbol-ordering.lisp b/src/symbol-ordering.lisp new file mode 100644 index 0000000..ea609bc --- /dev/null +++ b/src/symbol-ordering.lisp @@ -0,0 +1,251 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: symbol-ordering.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim + (special + *symbols-in-symbol-table* + )) + +;;; use-default-ordering = nil no default ordering +;;; use-default-ordering = t high arity > low arity, same arity alphabetically later > earlier +;;; use-default-ordering = :reverse high arity > low arity, same arity alphabetically earlier > later +;;; use-default-ordering = :arity high arity > low arity + +(defvar ordering-is-total nil) ;can be set if all symbols have been totally ordered by ordering declarations + +(defvar *symbol-ordering*) + +(defun initialize-symbol-ordering () + (setf *symbol-ordering* (make-poset))) + +(defun default-symbol-ordering-compare (symbol1 symbol2) + (cond + ((and (test-option23?) + (if (function-symbol-p symbol1) (function-skolem-p symbol1) (constant-skolem-p symbol1)) + (not (if (function-symbol-p symbol2) (function-skolem-p symbol2) (constant-skolem-p symbol2))) + (not (and (ordering-functions>constants?) (not (function-symbol-p symbol1)) (function-symbol-p symbol2)))) + '>) + ((and (test-option23?) + (not (if (function-symbol-p symbol1) (function-skolem-p symbol1) (constant-skolem-p symbol1))) + (if (function-symbol-p symbol2) (function-skolem-p symbol2) (constant-skolem-p symbol2)) + (not (and (ordering-functions>constants?) (function-symbol-p symbol1) (not (function-symbol-p symbol2))))) + '<) + ((function-symbol-p symbol1) + (cond + ((not (function-symbol-p symbol2)) + '>) + ((and (equality-relation-symbol-p symbol1) (not (equality-relation-symbol-p symbol2))) + '<) + ((and (equality-relation-symbol-p symbol2) (not (equality-relation-symbol-p symbol1))) + '>) + ((and (function-skolem-p symbol1) (not (function-skolem-p symbol2))) + '>) + ((and (function-skolem-p symbol2) (not (function-skolem-p symbol1))) + '<) + ((and (function-constructor symbol1) (not (function-constructor symbol2))) + '<) + ((and (function-constructor symbol2) (not (function-constructor symbol1))) + '>) + ((and (eq 'arithmetic (function-constraint-theory symbol1)) (not (eq 'arithmetic (function-constraint-theory symbol2)))) + '<) + ((and (eq 'arithmetic (function-constraint-theory symbol2)) (not (eq 'arithmetic (function-constraint-theory symbol1)))) + '>) + (t + (let ((arity1 (if (function-associative symbol1) 2 (function-arity symbol1))) + (arity2 (if (function-associative symbol2) 2 (function-arity symbol2)))) + (cond + ((eql arity1 arity2) + (cond + ((eq :arity (use-default-ordering?)) + '?) + (t + (default-symbol-ordering-compare1 (function-name symbol1) (function-name symbol2))))) + ((or (not (numberp arity1)) + (not (numberp arity2))) + '?) + ((and (1-ary-functions>2-ary-functions-in-default-ordering?) (= 1 arity1) (= 2 arity2) (not (function-boolean-valued-p symbol1)) (not (function-boolean-valued-p symbol2))) + '>) + ((and (1-ary-functions>2-ary-functions-in-default-ordering?) (= 2 arity1) (= 1 arity2) (not (function-boolean-valued-p symbol1)) (not (function-boolean-valued-p symbol2))) + '<) + (t + (if (> arity1 arity2) '> '<))))))) + ((function-symbol-p symbol2) + '<) + ((symbolp symbol1) ;symbols > strings > numbers + (if (symbolp symbol2) + (cond + ((and (constant-skolem-p symbol1) (not (constant-skolem-p symbol2))) + '>) + ((and (constant-skolem-p symbol2) (not (constant-skolem-p symbol1))) + '<) + ((and (constant-constructor symbol1) (not (constant-constructor symbol2))) + '<) + ((and (constant-constructor symbol2) (not (constant-constructor symbol1))) + '>) + ((eq :arity (use-default-ordering?)) + '?) + (t + (default-symbol-ordering-compare1 symbol1 symbol2))) + '>)) + ((symbolp symbol2) + '<) + ((stringp symbol1) + (if (stringp symbol2) (if (string> symbol1 symbol2) '> '<) '>)) + ((stringp symbol2) + '<) + (t + (if (greater? symbol1 symbol2) '> '<)))) + +(defun default-symbol-ordering-compare1 (symbol1 symbol2) + (if (if (eq :reverse (use-default-ordering?)) + (string< (symbol-name symbol1) (symbol-name symbol2)) + (string> (symbol-name symbol1) (symbol-name symbol2))) + '> + '<)) + +(defun declare-ordering-greaterp2 (x y) + (cond + ((or (not (iff (symbol-boolean-valued-p x) (symbol-boolean-valued-p y))) + (and (ordering-functions>constants?) (not (function-symbol-p x)) (function-symbol-p y))) + (warn "Ignoring ordering declaration ~A > ~A." x y)) + ((not (and (ordering-functions>constants?) (function-symbol-p x) (not (function-symbol-p y)))) + (declare-poset-greaterp *symbol-ordering* (symbol-number x) (symbol-number y))))) + +(definline symbol-ordering-compare (symbol1 symbol2) + (cond + ((eql symbol1 symbol2) + '=) + (t + (symbol-ordering-compare1 symbol1 symbol2)))) + +(defun symbol-ordering-compare1 (symbol1 symbol2) + (let ((n1 (symbol-number symbol1)) + (n2 (symbol-number symbol2))) + (cond + ((poset-greaterp *symbol-ordering* n1 n2) + '>) + ((poset-greaterp *symbol-ordering* n2 n1) + '<) + (t + (let ((ordering-fun (use-default-ordering?))) + (cond + (ordering-fun + (cl:assert (iff (symbol-boolean-valued-p symbol1) (symbol-boolean-valued-p symbol2))) + (let ((com (funcall (if (or (eq t ordering-fun) + (eq :arity ordering-fun) + (eq :reverse ordering-fun)) + #'default-symbol-ordering-compare + ordering-fun) + symbol1 + symbol2))) + (ecase com + (> + (declare-ordering-greaterp2 symbol1 symbol2)) + (< + (declare-ordering-greaterp2 symbol2 symbol1)) + (? + )) + com)) + (t + '?))))))) + +(defun opposite-order (x) + (case x + (> + '<) + (< + '>) + (otherwise + x))) + +(defun print-symbol-ordering (&optional (symbol-or-symbols none)) + (let ((symbols (cond + ((eq none symbol-or-symbols) + none) + ((consp symbol-or-symbols) + symbol-or-symbols) + (t + (list symbol-or-symbols)))) + (l nil)) + (prog-> + (map-sparse-vector-with-indexes (sparse-matrix-rows *symbol-ordering*) ->* row x#) + (symbol-numbered x# -> x) + (map-sparse-vector row ->* y#) + (symbol-numbered y# -> y) + (when (implies (neq none symbols) + (member (symbol-to-name x) symbols)) + (or (assoc x l) (first (push (list x nil nil) l)) -> v) + (push y (third v))) + (when (implies (neq none symbols) + (member (symbol-to-name y) symbols)) + (or (assoc y l) (first (push (list y nil nil) l)) -> v) + (push x (second v)))) + (mapc (lambda (v) + (setf (first v) (symbol-to-name (first v))) + (when (second v) + (setf (second v) (sort (mapcar 'symbol-to-name (second v)) 'constant-name-lessp))) + (when (third v) + (setf (third v) (sort (mapcar 'symbol-to-name (third v)) 'constant-name-lessp)))) + l) + (setf l (sort l 'constant-name-lessp :key #'first)) + (terpri-comment) + (prin1 `(ordering-functions>constants? ,(ordering-functions>constants?))) + (dolist (v l) + (terpri-comment) + (prin1 (cons 'declare-ordering-greaterp + (append (and (second v) (list (kwote (second v)))) + (list (kwote (first v))) + (and (third v) (list (kwote (third v)))))))))) + +(defun declare-ordering-greaterp (x y &rest others) + ;; user function for declaring that x > y in ordering precedence relation + ;; x and y can be a symbol or lists of symbols + ;; if x and y are lists of symbols, then every symbol in x is declared greater than every symbol in y + (dotails (l (mapcar (lambda (x) + (if (consp x) (mapcar #'input-symbol x) (list (input-symbol x)))) + (list* x y others))) + (unless (null (rest l)) + (dolist (x (first l)) + (dolist (y (second l)) + (declare-ordering-greaterp2 x y)))))) + +(defun rpo-add-created-function-symbol (fn) + (prog-> + (map-symbol-table ->* name kind symbol) + (declare (ignore name)) + (cond + ((or (eq :variable kind) (eq :sort kind)) + ) + ((eq symbol fn) + ) + ((symbol-boolean-valued-p symbol) + ) + ((if (function-symbol-p fn) + (and (function-symbol-p symbol) + (function-created-p symbol) + (> (function-arity fn) (function-arity symbol))) + (and (not (function-symbol-p symbol)) + (constant-created-p symbol))) + (declare-ordering-greaterp2 fn symbol)) + (t + (declare-ordering-greaterp2 symbol fn))))) + +;;; symbol-ordering.lisp EOF diff --git a/src/symbol-table2.lisp b/src/symbol-table2.lisp new file mode 100644 index 0000000..0b7b7bb --- /dev/null +++ b/src/symbol-table2.lisp @@ -0,0 +1,397 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: symbol-table2.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *symbol-table*) + +(declaim (special *input-wff*)) + +;;; identical names in different packages yield different symbols +;;; logical symbols, equality relation, etc., are in SNARK package +;;; +;;; builtin constants (numbers and strings) are not stored in the symbol table + +(defun make-symbol-table () + (setf *symbol-table* (make-hash-table)) + nil) + +(defmacro symbol-table-entries (name) + `(gethash ,name *symbol-table*)) + +(defun create-symbol-table-entry (name symbol) + (pushnew symbol (symbol-table-entries name)) + symbol) + +(defun find-symbol-table-entry (name kind &optional arity) +;;(cl:assert (implies (eq :logical-symbol kind) (eq :any arity))) + (dolist (symbol (symbol-table-entries name) none) + (when (symbol-table-kind-match symbol kind arity) + (return symbol)))) + +(defun find-or-create-symbol-table-entry (name kind &optional arity (sym none)) +;;(cl:assert (implies (eq :logical-symbol kind) (eq :any arity))) + (let ((symbol (find-symbol-table-entry name kind arity))) + (cond + ((neq none symbol) + (when (and (neq none sym) (neql sym symbol)) + (with-standard-io-syntax2 + (error "~S cannot be used as ~A name or alias of ~S; it is a ~A name or alias of ~S." name kind sym kind symbol))) + symbol) + (t + (cond + ((neq none sym) + (setf symbol sym)) + (t + (ecase kind + (:variable + (setf symbol (make-variable none))) ;declare-variable replaces none by proper sort + (:constant + (setf symbol name) + (constant-info symbol nil)) + (:proposition + (setf symbol + (cond + ((eq 'true name) ;use value of lisp defconstants true and false to represent truth values + true) + ((eq 'false name) + false) + (t + (make-symbol (symbol-name name))))) + (constant-info symbol nil) + (setf (constant-boolean-valued-p0 symbol) name)) + (:function + (setf symbol (make-function-symbol name arity))) + (:relation + (setf symbol (make-function-symbol name arity)) + (setf (function-boolean-valued-p symbol) t)) + (:logical-symbol + (setf symbol (make-function-symbol name :any)) + (setf (function-boolean-valued-p symbol) t) + (setf (function-logical-symbol-p symbol) name))))) + (prog-> + (dolist (symbol-table-entries name) ->* symbol2) + (symbol-kind symbol2 -> kind2 arity2) + (cond + ((or (and (eq kind kind2) + (naturalp arity2) ;function or relation already declared with fixed arity + (not (naturalp arity)) ;now with special (e.g., :any) arity + (ecase arity (:any t))) + (and (eq :relation kind) (eq :logical-symbol kind2)) + (and (eq :logical-symbol kind) (eq :relation kind2))) + (with-standard-io-syntax2 + (error "~S cannot be used as a ~@[~A-ary ~]~A; it is a ~@[~A-ary ~]~A." + name (if (eq :logical-symbol kind) nil arity) kind (if (eq :logical-symbol kind2) nil arity2) kind2))) + ((and (print-symbol-table-warnings?) + (or (eq :all (print-symbol-table-warnings?)) + (and (or (eq :function kind) (eq :relation kind) (eq :logical-symbol kind)) + (or (eq :function kind2) (eq :relation kind2) (eq :logical-symbol kind2))) + (and (eq :constant kind) (eq :variable kind2)) + (and (eq :variable kind) (eq :constant kind2)))) + (with-standard-io-syntax2 + (warn "~S is being used as a ~@[~A-ary ~]~A~@[ in ~S~]; it is also a ~@[~A-ary ~]~A." + name (if (eq :logical-symbol kind) nil arity) kind *input-wff* (if (eq :logical-symbol kind2) nil arity2) kind2))))) + (create-symbol-table-entry name symbol) + (values symbol t))))) + +(defun create-aliases-for-symbol (symbol aliases) + (mvlet (((values kind arity) (symbol-kind symbol))) + (dolist (alias (mklist aliases)) + (ecase kind + (:function (can-be-function-name alias 'error)) + (:relation (can-be-relation-name alias 'error)) + (:constant (can-be-constant-alias alias 'error)) + (:proposition (can-be-proposition-name alias 'error)) + (:logical-symbol (can-be-logical-symbol-name alias 'error)) + (:sort (can-be-sort-name alias 'error))) + (find-or-create-symbol-table-entry alias kind arity symbol)))) + +(defun rename-function-symbol (symbol new-name) + (create-aliases-for-symbol symbol new-name) + (setf (function-name symbol) new-name) + (setf (function-code-name0 symbol) nil)) + +(defun symbol-kind (x) + (cond + ((function-symbol-p x) + (values (function-kind x) (function-arity x))) + ((variable-p x) + :variable) + ((sort? x) + :sort) + ((constant-boolean-valued-p x) + :proposition) + (t + :constant))) + +(defun symbol-table-kind-match (symbol2 kind arity) + ;; can existing symbol2 be used as a kind/arity symbol + (mvlet (((values kind2 arity2) (symbol-kind symbol2))) + (and (eq kind kind2) + (or (eql arity arity2) + (case arity2 + (:any + (or (eq :any arity) (naturalp arity))) + (2 + (and (function-associative symbol2) (or (eq :any arity) (naturalp arity)))) + (otherwise + nil)))))) + +(defun symbol-table-constant? (name) + (remove-if-not #'(lambda (x) (eq :constant (symbol-kind x))) (symbol-table-entries name))) + +(defun symbol-table-function? (name) + (remove-if-not #'(lambda (x) (eq :function (symbol-kind x))) (symbol-table-entries name))) + +(defun symbol-table-relation? (name) + (remove-if-not #'(lambda (x) (eq :relation (symbol-kind x))) (symbol-table-entries name))) + +(defun map-symbol-table (cc &key logical-symbols variables) + (prog-> + (maphash *symbol-table* ->* name entries) + (dolist entries ->* symbol) + (symbol-kind symbol -> kind) + (when (case kind + (:variable variables) + (:logical-symbol logical-symbols) + (:proposition (implies (not logical-symbols) (not (or (eq true symbol) (eq false symbol))))) + (otherwise t)) + (funcall cc name kind symbol)))) + +(defun symbol-aliases (symbol) + ;; slow + (let ((aliases nil)) + (prog-> + (symbol-to-name symbol -> name) + (map-symbol-table :logical-symbols t :variables nil ->* name2 kind2 symbol2) + (declare (ignore kind2)) + (when (eql symbol symbol2) + (unless (eql name name2) + (push name2 aliases)))) + (sort aliases #'string< :key #'symbol-name))) + +(defun print-symbol-table (&key logical-symbols variables) + (with-standard-io-syntax2 + (labels + ((print-aliases (symbol) + (let ((aliases (symbol-aliases symbol))) + (when aliases + (format t "~35T (alias ~S~{, ~S~})" (first aliases) (rest aliases))))) + (print-symbols1 (list kind) + (when list + (let ((len (length list))) + (format t "~%~D ~(~A~)~P:" len kind len)) + (dolist (symbol (sort list #'function-name-arity-lessp)) + (format t "~% ~S~26T" symbol) + (let ((arity (function-arity symbol))) + (unless (member arity '(:any)) + (format t " ~A-ary" arity))) + (when (function-macro symbol) + (format t " macro")) + (print-aliases symbol)))) + (print-symbols2 (list kind orderfn) + (when list + (let ((len (length list))) + (format t "~%~D ~(~A~)~P:" len kind len)) + (dolist (symbol (sort list orderfn)) + (cond + ((or (eq :constant kind) (eq :proposition kind)) + (format t "~% ~S" (constant-name symbol)) + (print-aliases symbol)) + ((eq :sort kind) + (format t "~% ~S" (sort-name symbol)) + (print-aliases symbol)) + (t + (format t "~% ~S" symbol))))))) + (let ((list-of-variables nil) + (list-of-sorts nil) + (list-of-constants nil) + (list-of-propositions nil) + (list-of-functions nil) + (list-of-relations nil) + (list-of-logical-symbols nil) + (ambiguous nil)) + (prog-> + (identity none -> previous-name) + (map-symbol-table :logical-symbols logical-symbols :variables variables ->* name kind symbol) + (cond + ((neql previous-name name) + (setf previous-name name)) + ((or (null ambiguous) (neql name (first ambiguous))) + (push name ambiguous))) + (ecase kind + (:variable + (push name list-of-variables)) + (:sort + (when (eq name (sort-name symbol)) + (push symbol list-of-sorts))) + (:constant + (when (eql name (constant-name symbol)) + (push symbol list-of-constants))) + (:proposition + (when (eq name (constant-name symbol)) + (push symbol list-of-propositions))) + (:function + (when (eq name (function-name symbol)) + (push symbol list-of-functions))) + (:relation + (when (eq name (function-name symbol)) + (push symbol list-of-relations))) + (:logical-symbol + (when (eq name (function-name symbol)) + (push symbol list-of-logical-symbols))))) + (print-symbols1 list-of-logical-symbols :logical-symbol) + (print-symbols2 list-of-variables :variable #'string<) + (print-symbols2 list-of-sorts :sort #'(lambda (x y) (string< (sort-name x) (sort-name y)))) + (print-symbols2 list-of-propositions :proposition #'constant-name-lessp) + (print-symbols2 list-of-constants :constant #'constant-name-lessp) + (print-symbols1 list-of-functions :function) + (print-symbols1 list-of-relations :relation) + (when ambiguous + (format t "~%~D symbol~:P with multiple meanings:" (length ambiguous)) + (dolist (symbol (sort ambiguous #'string<)) + (format t "~% ~S" symbol))) + nil)))) + +(defun symbol-to-name (x) + (cond + ((function-symbol-p x) + (function-name x)) + ((sort? x) + (sort-name x)) + (t + (constant-name x)))) + +(defun symbol-boolean-valued-p (x) + (if (function-symbol-p x) + (function-boolean-valued-p x) + (constant-boolean-valued-p x))) + +(defun symbol-number (x) + (if (function-symbol-p x) + (function-number x) + (constant-number x))) + +(definline symbol-numbered (n) + (funcall *standard-eql-numbering* :inverse n)) + +(defun the-function-symbol (name arity &optional kind) + (let ((symbol (find-symbol-table-entry name (or kind :function) arity))) + (cl:assert (neq none symbol)) + symbol)) + +(defun current-function-name (name arity &optional kind) + (function-name (the-function-symbol name arity (or kind :function)))) + +(defun input-symbol (name &key macro) + ;; return SNARK symbol whose name is name + ;; primary usage is for term ordering declarations + ;; special handling for true and false + ;; accept as input the internal symbols for true and false + ;; if name is 'true or 'false, return the constant true or false if there is one; otherwise return the proposition + (cond + ((numberp name) + (declare-number name)) + ((stringp name) + (declare-string name)) + ((or (eq true name) (eq false name) (function-symbol-p name)) + name) ;already in internal format + (t + (can-be-constant-or-function-name name 'error) + (let ((found nil)) + (prog-> + (dolist (symbol-table-entries name) ->* symbol) + (symbol-kind symbol -> kind) + (cond + ((or (eq :sort kind) (eq :variable kind)) + ) + ((and (not macro) (function-symbol-p symbol) (function-macro symbol)) + ) + (found + (cond + ((and (or (eq 'true name) (eq 'false name)) (eq :proposition kind) (eq :constant (first found))) + ) + ((and (or (eq 'true name) (eq 'false name)) (eq :constant kind) (eq :proposition (first found))) + (setf found (cons kind symbol))) + (t + (error "There is more than one entry for ~S in symbol table." name)))) + (t + (setf found (cons kind symbol))))) + (cond + ((null found) + (error "Couldn't find ~S in symbol table." name)) + (t + (cdr found))))))) + +(defun input-constant-symbol (name) + (let ((quoted (and (consp name) (eq '$$quote (first name)) (rest name) (null (rrest name))))) + (when quoted + (setf name (second name))) + (cond + ((numberp name) + (declare-number name)) + ((stringp name) + (declare-string name)) + (t + (unless (and quoted (atom name)) + (can-be-constant-name name 'error)) + (find-or-create-symbol-table-entry name :constant))))) + +(defun input-proposition-symbol (name) + (cond + ((or (eq true name) (eq false name)) ;allow internal true and false values in input + name) ;they are already in internal format + (t + (can-be-proposition-name name 'error) + (find-or-create-symbol-table-entry name :proposition)))) + +(defun input-function-symbol (name arity &optional rel) + ;; find or create a function (or relation) symbol with the given name and arity + (cond + ((function-symbol-p name) + ;; generalize by allowing name to be a function (or relation) symbol of correct arity + (cl:assert (and (function-has-arity-p name arity) (iff (function-boolean-valued-p name) rel))) + name) + (t + (can-be-function-name name 'error) + (find-or-create-symbol-table-entry name (if rel :relation :function) arity)))) + +(defun input-relation-symbol (name arity) + ;; find or create a relation symbol with the given name and arity + (input-function-symbol name arity t)) + +(defun input-logical-symbol (name &optional create-if-does-not-exist) + (cond + (create-if-does-not-exist + (can-be-logical-symbol-name name 'error) + (find-or-create-symbol-table-entry name :logical-symbol :any)) + (t + (find-symbol-table-entry name :logical-symbol :any)))) + +(defun expr-arity (x) + ;; used by input-wff etc. to count arguments of nonatomic expression + (list-p (rest x))) + +(defun input-head-function-symbol (term) + (input-function-symbol (first term) (expr-arity term))) + +(defun input-head-relation-symbol (wff) + (input-relation-symbol (first wff) (expr-arity wff))) + +;;; symbol-table2.lisp EOF diff --git a/src/term-hash.lisp b/src/term-hash.lisp new file mode 100644 index 0000000..d494a57 --- /dev/null +++ b/src/term-hash.lisp @@ -0,0 +1,250 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: term-hash.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *atom-hash-code*) +(defvar *term-by-hash-array*) +(defvar *hash-term-uses-variable-numbers* t) +(defvar *hash-term-only-computes-code* nil) +(defvar *hash-term-not-found-action* :add) + +(defun initialize-term-hash () + (setf *atom-hash-code* 0) + (setf *term-by-hash-array* (make-sparse-vector)) + nil) + +(defun make-atom-hash-code () + ;; return a hash-code in [2,1023] + (if (<= (setf *atom-hash-code* (mod (+ (* 129 *atom-hash-code*) 1) 1024)) 1) + (make-atom-hash-code) + *atom-hash-code*)) + +(defun find-term-by-hash (x hash) + (let* ((term-by-hash-array *term-by-hash-array*) + (terms (sparef term-by-hash-array hash))) + (when terms + (dolist (term terms) + (when (eq term x) + (return-from find-term-by-hash term))) + (dolist (term terms) + (when (equal-p term x) + (return-from find-term-by-hash term)))) + (ecase *hash-term-not-found-action* + (:add + (setf (sparef term-by-hash-array hash) (cons x terms)) + x) + (:throw + (throw 'hash-term-not-found none)) + (:error + (error "No hash-term for ~S." x))))) + +(defun term-by-hash-array-terms (&optional delete-variants) + (let ((terms nil) terms-last) + (prog-> + (map-sparse-vector *term-by-hash-array* ->* l) + (copy-list l -> l) + (ncollect (if (and delete-variants (not *hash-term-uses-variable-numbers*)) + (delete-duplicates l :test #'variant-p) + l) + terms)) + (if (and delete-variants *hash-term-uses-variable-numbers*) + (delete-duplicates terms :test #'variant-p) + terms))) + +(defmacro thvalues (hash x) + `(if *hash-term-only-computes-code* ,hash (values ,hash ,x))) + +(defun hash-term* (x subst) + (dereference + x subst + :if-variable (thvalues (if *hash-term-uses-variable-numbers* (+ 1024 (variable-number x)) 0) x) + :if-constant (thvalues (constant-hash-code x) x) + :if-compound (mvlet (((:values hash x) (hash-compound x subst))) + (thvalues hash (if (eq *cons* (head x)) x (find-term-by-hash x hash)))))) + +(defun hash-term-code (x &optional subst) + ;; just return the hash code without finding or creating canonical forms + (let ((*hash-term-only-computes-code* t)) + (hash-term* x subst))) + +(defun hash-term (x &optional subst) + ;; find or create canonical form of x.subst + ;; but doesn't store a canonical form for conses + ;; (equal-p x (hash-term x)) + ;; (equal-p x y) => (eql (hash-term x) (hash-term y)) + (when (test-option38?) + (return-from hash-term (instantiate x subst))) + (mvlet (((:values hash x) (hash-term* x subst))) + (values x hash))) + +(defun some-hash-term (x &optional subst) + ;; hash-term or none + (let ((*hash-term-not-found-action* :throw)) + (catch 'hash-term-not-found + (hash-term x subst)))) + +(defun the-hash-term (x &optional subst) + ;; hash-term or error + (let ((*hash-term-not-found-action* :error)) + (hash-term x subst))) + +(defun hash-list (l subst multiplier) + ;; (a b c ...) -> 2*hash(a) + 3*hash(b) + 4*hash(c) ... + (cond + ((null l) + 0) + (t + (mvlet* ((x (first l)) + ((:values xhash x*) (hash-term* x subst)) + (y (rest l))) + (when multiplier + (setf xhash (* multiplier xhash))) + (if (null y) + (thvalues xhash (if (eql x x*) l (cons x* nil))) + (mvlet (((:values yhash y*) (hash-list y subst (and multiplier (+ multiplier 1))))) + (thvalues (+ xhash yhash) (if (and (eq y y*) (eql x x*)) l (cons x* y*))))))))) + +(defun hash-compound (compd &optional subst) + ;; this uses a simpler term hashing function than before + ;; it should be is easier to verify and maintain + ;; + ;; for (f t1 ... tn) it computes (+ (# f) (* 2 (# t1)) ... (* (+ n 1) (# tn))) + ;; but uses 0 for (# f) if f is associative (since these symbols may disappear) + ;; and uses 1 for multipliers if f is associative, commutative, etc. + ;; + ;; when *hash-term-uses-variable-numbers* is nil + ;; it should be the case that (implies (subsumes-p t1 t2) (<= (# t1) (# t2))) + (let ((head (head compd)) + (args (args compd))) + (cond + ((null args) + (thvalues (function-hash-code head) compd)) + (t + (ecase (function-index-type head) + ((nil :hash-but-dont-index) + (mvlet (((:values hash args*) + (hash-list args subst (and (not (function-associative head)) + (not (function-commutative head)) + 2)))) + (incf hash (if (function-associative head) + (* (function-hash-code head) (+ 1 (length (rest (rest args))))) + (function-hash-code head))) + (thvalues hash (if (eq args args*) compd (make-compound* head args*))))) + (:commute + (prog-> + (first args -> arg1) + (hash-term* arg1 subst -> hash1 arg1*) + (second args -> arg2) + (hash-term* arg2 subst -> hash2 arg2*) + (rest (rest args) -> args3) + (hash-list args3 subst 4 -> hash3 args3*) + (thvalues (+ (function-hash-code head) (* 2 hash1) (* 2 hash2) hash3) + (if (eq args3 args3*) + (if (eql arg2 arg2*) + (if (eql arg1 arg1*) + compd + (make-compound* head arg1* (rest args))) + (make-compound* head arg1* arg2* args3)) + (make-compound* head arg1* arg2* args3*))))) + (:jepd + (prog-> + (first args -> arg1) + (hash-term* arg1 subst -> hash1 arg1*) + (second args -> arg2) + (hash-term* arg2 subst -> hash2 arg2*) + (third args -> arg3) + (instantiate arg3 subst -> arg3*) + (thvalues (+ (function-hash-code head) (* 2 hash1) (* 2 hash2)) + (if (eq arg3 arg3*) + (if (eql arg2 arg2*) + (if (eql arg1 arg1*) + compd + (make-compound* head arg1* (rest args))) + (make-compound* head arg1* arg2* (rest (rest args)))) + (make-compound head arg1* arg2* arg3*)))))))))) + +(defun print-term-hash (&key (details t) terms) + (let ((a (and details (make-sparse-vector :default-value 0))) + (nterms 0)) + (prog-> + (map-sparse-vector *term-by-hash-array* ->* l) + (length l -> len) + (incf nterms len) + (when details + (incf (sparef a len)))) + (cond + (details + (format t "~%; Term-hash-array has ~:D position~:P filled with ~:D term~:P in all." + (sparse-vector-count *term-by-hash-array*) nterms) + (prog-> + (map-sparse-vector-with-indexes a ->* n len) + (format t "~%; Term-hash-array has ~:D position~:P filled with ~:D term~:P each." n len))) + (t + (format t "~%; Term-hash-array has ~:D term~:P in all." nterms)))) + (when terms + (prog-> + (map-sparse-vector-with-indexes *term-by-hash-array* ->* l position) + (when (implies (and (numberp terms) (< 1 terms)) (>= (length l) terms)) + (format t "~%; ~6D: ~S~{~%; ~S~}" position (first l) (rest l)))))) + +(defvar *default-hash-term-set-count-down-to-hashing* 10) ;can insert this many before hashing + +(defstruct (hash-term-set + (:constructor make-hash-term-set (&optional substitution)) + (:conc-name :hts-)) + (terms nil) ;list or hash-table of terms + (substitution nil :read-only t) + (count-down-to-hashing *default-hash-term-set-count-down-to-hashing*)) + +(defun hts-member-p (term hts) + (let* ((terms (hts-terms hts)) + (l (if (eql 0 (hts-count-down-to-hashing hts)) + (gethash (hash-term-code term) terms) + terms))) + (if (and l (member-p term l (hts-substitution hts))) t nil))) + +(defun hts-adjoin-p (term hts) + ;; if term is a already a member of hts, return NIL + ;; otherwise add it and return true + (let* ((terms (hts-terms hts)) + (c (hts-count-down-to-hashing hts)) + h + (l (if (eql 0 c) + (gethash (setf h (hash-term-code term)) terms) + terms))) + (cond + ((and l (member-p term l (hts-substitution hts))) + nil) + ((eql 0 c) + (setf (gethash h terms) (cons term l)) + t) + ((eql 1 c) + (setf (hts-terms hts) (setf terms (make-hash-table))) + (setf (gethash (hash-term-code term) terms) (cons term nil)) + (dolist (term l) + (push term (gethash (hash-term-code term) terms))) + (setf (hts-count-down-to-hashing hts) 0) + t) + (t + (setf (hts-terms hts) (cons term l)) + (setf (hts-count-down-to-hashing hts) (- c 1)) + t)))) + +;;; term-hash.lisp EOF diff --git a/src/term-memory.lisp b/src/term-memory.lisp new file mode 100644 index 0000000..686425c --- /dev/null +++ b/src/term-memory.lisp @@ -0,0 +1,286 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: term-memory.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *term-memory*) + +(defstruct (term-memory-entry + (:include path-index-entry) + (:conc-name :tme-) + (:copier nil)) + (number (nonce) :read-only t) + (rows-containing-atom-positively nil) + (rows-containing-atom-negatively nil) + (rows-containing-paramodulatable-equality nil) + (rows-containing-term nil) + (rewrites nil) + size + depth + mindepth) + +(defstruct (term-memory + (:conc-name :tm-) + (:constructor make-term-memory0) + (:copier nil)) + (retrieve-generalization-calls 0) ;number of generalization retrieval calls + (retrieve-generalization-count 0) + (retrieve-instance-calls 0) ; " instance " + (retrieve-instance-count 0) + (retrieve-unifiable-calls 0) ; " unifiable " + (retrieve-unifiable-count 0) + (retrieve-variant-calls 0) ; " variant " + (retrieve-variant-count 0) + (retrieve-all-calls 0) ; " all " + (retrieve-all-count 0) + ) + +(defun make-term-memory-entry1 (term) + (make-term-memory-entry + :term term + :size (size term) + :depth (depth term) + :mindepth (mindepth term))) + +(defun make-term-memory (&key indexing-method depth-limit make-printable-nodes-p) + (declare (ignore indexing-method depth-limit make-printable-nodes-p)) + (make-path-index :entry-constructor #'make-term-memory-entry1) + (make-trie-index :entry-constructor #'make-term-memory-entry1) + (setf *term-memory* (make-term-memory0)) + *term-memory*) + +(defun term-memory-entry (term) +;;(path-index-entry term) + (nth-value 1 (tm-store term)) + ) + +(defun some-term-memory-entry (term) + (some-path-index-entry term)) + +(defun the-term-memory-entry (term) + (the-path-index-entry term)) + +(defun tm-store (term) +;;(cl:assert (eql term (hash-term term))) + (when (variable-p term) + (error "STORING VARIABLE IN TERM MEMORY")) + (let (entry) + (cond + ((setf entry (some-path-index-entry term)) + (cl:assert (eql term (tme-term entry))) + (values term entry t)) + (t + (setf entry (path-index-insert term)) + (cl:assert (eql term (tme-term entry))) + (trie-index-insert term entry) + (when (or (test-option51?) (test-option52?)) + (feature-vector-index-insert entry *feature-vector-term-index*)) + (values term entry))))) + +(defun tm-remove-entry (entry) + (let ((rowset (tme-rows-containing-term entry))) + (when rowset + (rowsets-delete-column rowset) + (setf (tme-rows-containing-term entry) nil))) + (let ((rowset (tme-rows-containing-atom-positively entry))) + (when rowset + (rowsets-delete-column rowset) + (setf (tme-rows-containing-atom-positively entry) nil))) + (let ((rowset (tme-rows-containing-atom-negatively entry))) + (when rowset + (rowsets-delete-column rowset) + (setf (tme-rows-containing-atom-negatively entry) nil))) + (path-index-delete (tme-term entry)) + (trie-index-delete (tme-term entry) entry) + (when (or (test-option51?) (test-option52?)) + (feature-vector-index-delete entry *feature-vector-term-index*))) + +(defun retrieve-generalization-entries (cc term &optional subst test) + (when (test-option51?) + (if (null test) + (prog-> + (map-feature-vector-term-index-generalizations term subst ->* entry) + (funcall cc entry)) + (prog-> + (map-feature-vector-term-index-generalizations term subst ->* entry) + (funcall test entry ->nonnil test-value) + (funcall cc entry test-value))) + (return-from retrieve-generalization-entries)) + #-ignore (incf (tm-retrieve-generalization-calls *term-memory*)) + (if (null test) + (prog-> + (map-trie-index :generalization term subst ->* entry) + #-ignore (incf (tm-retrieve-generalization-count *term-memory*)) + (funcall cc entry)) + (prog-> + (map-trie-index :generalization term subst ->* entry) + (funcall test entry ->nonnil test-value) + #-ignore (incf (tm-retrieve-generalization-count *term-memory*)) + (funcall cc entry test-value)))) + +(defun retrieve-instance-entries (cc term &optional subst test) + (when (test-option52?) + (if (null test) + (prog-> + (map-feature-vector-term-index-instances term subst ->* entry) + (funcall cc entry)) + (prog-> + (map-feature-vector-term-index-instances term subst ->* entry) + (funcall test entry ->nonnil test-value) + (funcall cc entry test-value))) + (return-from retrieve-instance-entries)) + #-ignore (incf (tm-retrieve-instance-calls *term-memory*)) + (cond + ((and (ground-p term subst) (simply-indexed-p term subst)) + (if (null test) + (prog-> + (map-trie-index :instance term subst ->* entry) + #-ignore (incf (tm-retrieve-instance-count *term-memory*)) + (funcall cc entry)) + (prog-> + (map-trie-index :instance term subst ->* entry) + (funcall test entry ->nonnil test-value) + #-ignore (incf (tm-retrieve-instance-count *term-memory*)) + (funcall cc entry test-value)))) + (t + (if (null test) + (prog-> + (map-path-index-entries :instance term subst test ->* entry) + #-ignore (incf (tm-retrieve-instance-count *term-memory*)) + (funcall cc entry)) + (prog-> + (map-path-index-entries :instance term subst test ->* entry test-value) + #-ignore (incf (tm-retrieve-instance-count *term-memory*)) + (funcall cc entry test-value)))))) + +(defun retrieve-unifiable-entries (cc term &optional subst test) + #-ignore (incf (tm-retrieve-unifiable-calls *term-memory*)) + (if (null test) + (prog-> + (map-path-index-entries :unifiable term subst test ->* entry) + #-ignore (incf (tm-retrieve-unifiable-count *term-memory*)) + (funcall cc entry)) + (prog-> + (map-path-index-entries :unifiable term subst test ->* entry test-value) + #-ignore (incf (tm-retrieve-unifiable-count *term-memory*)) + (funcall cc entry test-value)))) + +(defun retrieve-resolvable-entries (cc atom &optional subst test) + (unless (do-not-resolve atom) + (retrieve-unifiable-entries cc atom subst test))) + +(defun retrieve-paramodulatable-entries (cc term &optional subst test) + (unless (do-not-paramodulate term) + (retrieve-unifiable-entries cc term subst test))) + +(defun retrieve-variant-entries (cc term &optional subst test) + #-ignore (incf (tm-retrieve-variant-calls *term-memory*)) + (if (null test) + (prog-> + (map-path-index-entries :variant term subst test ->* entry) + #-ignore (incf (tm-retrieve-variant-count *term-memory*)) + (funcall cc entry)) + (prog-> + (map-path-index-entries :variant term subst test ->* entry test-value) + #-ignore (incf (tm-retrieve-variant-count *term-memory*)) + (funcall cc entry test-value)))) + +(defun retrieve-all-entries (cc &optional test) + #-ignore (incf (tm-retrieve-all-calls *term-memory*)) + (if (null test) + (prog-> + (map-path-index-by-query t test ->* entry) + #-ignore (incf (tm-retrieve-all-count *term-memory*)) + (funcall cc entry)) + (prog-> + (map-path-index-by-query t test ->* entry test-value) + #-ignore (incf (tm-retrieve-all-count *term-memory*)) + (funcall cc entry test-value)))) + +(defun print-term-memory (&key terms nodes) + (print-term-hash :terms nil :details nil) + (print-feature-vector-row-index) + (when (or (test-option51?) (test-option52?)) + (print-feature-vector-term-index)) + (print-path-index :terms terms :nodes nodes) + (print-trie-index :terms terms :nodes nodes) + (unless (eql 0 (tm-retrieve-variant-calls *term-memory*)) + (format t "~%; Retrieved ~:D variant term~:P in ~:D call~:P." + (tm-retrieve-variant-count *term-memory*) + (tm-retrieve-variant-calls *term-memory*))) + (unless (eql 0 (tm-retrieve-generalization-calls *term-memory*)) + (format t "~%; Retrieved ~:D generalization term~:P in ~:D call~:P." + (tm-retrieve-generalization-count *term-memory*) + (tm-retrieve-generalization-calls *term-memory*))) + (unless (eql 0 (tm-retrieve-instance-calls *term-memory*)) + (format t "~%; Retrieved ~:D instance term~:P in ~:D call~:P." + (tm-retrieve-instance-count *term-memory*) + (tm-retrieve-instance-calls *term-memory*))) + (unless (eql 0 (tm-retrieve-unifiable-calls *term-memory*)) + (format t "~%; Retrieved ~:D unifiable term~:P in ~:D call~:P." + (tm-retrieve-unifiable-count *term-memory*) + (tm-retrieve-unifiable-calls *term-memory*))) + (unless (eql 0 (tm-retrieve-all-calls *term-memory*)) + (format t "~%; Retrieved ~:D unrestricted term~:P in ~:D call~:P." + (tm-retrieve-all-count *term-memory*) + (tm-retrieve-all-calls *term-memory*)))) + +(defun tme-useless-p (entry) + (and (eql 0 (sparse-vector-count (tme-rows-containing-term entry))) + (eql 0 (sparse-vector-count (tme-rows-containing-atom-positively entry))) + (eql 0 (sparse-vector-count (tme-rows-containing-atom-negatively entry))) + (null (tme-rows-containing-paramodulatable-equality entry)) + (null (tme-rewrites entry)))) + +(defmacro rows-containing-atom-positively (atom) + `(tme-rows-containing-atom-positively + (term-memory-entry ,atom))) + +(defmacro rows-containing-atom-negatively (atom) + `(tme-rows-containing-atom-negatively + (term-memory-entry ,atom))) + +(defmacro rows-containing-paramodulatable-equality (equality) + `(tme-rows-containing-paramodulatable-equality + (term-memory-entry ,equality))) + +(defmacro rows-containing-term (term) + `(tme-rows-containing-term + (term-memory-entry ,term))) + +(defmacro rewrites (term) + `(tme-rewrites + (term-memory-entry ,term))) + +(defun insert-into-rows-containing-term (row term) + (let ((e (term-memory-entry term))) + (rowset-insert row (or (tme-rows-containing-term e) + (setf (tme-rows-containing-term e) (make-rowset)))))) + +(defun insert-into-rows-containing-atom-positively (row atom) + (let ((e (term-memory-entry atom))) + (rowset-insert row (or (tme-rows-containing-atom-positively e) + (setf (tme-rows-containing-atom-positively e) (make-rowset)))))) + +(defun insert-into-rows-containing-atom-negatively (row atom) + (let ((e (term-memory-entry atom))) + (rowset-insert row (or (tme-rows-containing-atom-negatively e) + (setf (tme-rows-containing-atom-negatively e) (make-rowset)))))) + +;;; term-memory.lisp EOF diff --git a/src/terms2.lisp b/src/terms2.lisp new file mode 100644 index 0000000..10f9fcf --- /dev/null +++ b/src/terms2.lisp @@ -0,0 +1,231 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: terms2.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *cons*) +(defvar *=*) +(defvar *not*) +(defvar *and*) +(defvar *or*) +(defvar *implies*) +(defvar *implied-by*) +(defvar *iff*) +(defvar *xor*) +(defvar *if*) +(defvar *forall*) +(defvar *exists*) +(defvar *answer-if*) + +(defvar *a-function-with-left-to-right-ordering-status*) +(defvar *a-function-with-multiset-ordering-status*) + +(definline compound-appl-p (x) + (and (consp x) (function-symbol-p (carc x)))) + +(definline heada (appl) + ;; only if appl is compound-appl, not compound-cons + (carc appl)) + +(definline argsa (appl) + ;; only if appl is compound-appl, not compound-cons + (cdrc appl)) + +(definline constant-p (x) + (and (atom x) (not (variable-p x)))) + +(definline compound-p (x) + (consp x)) + +(defun make-compound%2 (head arg1 arg2) + (if (eq *cons* head) + (cons arg1 arg2) + (list head arg1 arg2))) + +(defun make-compound%* (head args) + (if (eq *cons* head) + (cons (first args) (second args)) + (cons head args))) + +(defmacro make-compound (head &rest args) + ;; e.g., (make-compound 'f 'a 'b 'c) = (f a b c) + (case (length args) + (2 + `(make-compound%2 ,head ,@args)) + (otherwise + `(list ,head ,@args)))) + +(defmacro make-compound* (head &rest args) + ;; e.g., (make-compound* 'f '(a b c)) = (make-compound* 'f 'a '(b c)) = (f a b c) + (cl:assert (not (null args))) + `(make-compound%* ,head (list* ,@args))) + +(definline arg1a (appl) + ;; only if appl is compound-appl, not compound-cons + (first (argsa appl))) + +(definline arg2a (appl) + ;; only if appl is compound-appl, not compound-cons + (second (argsa appl))) + +(definline arg1 (compound) + (let ((v (car compound))) + (if (function-symbol-p v) (arg1a compound) v))) + +(definline arg2 (compound) + (let ((v (car compound))) + (if (function-symbol-p v) (arg2a compound) (cdrc compound)))) + +(definline args (compound) + ;; note: (iff (neq (args compound) (args compound)) (eq *cons* (head compound))) + (let ((v (car compound))) + (if (function-symbol-p v) (argsa compound) (list v (cdrc compound))))) + +(definline head (compound) + (let ((v (car compound))) + (if (function-symbol-p v) v *cons*))) + +(definline head-or-term (x) + (cond + ((consp x) + (let ((v (carc x))) + (if (function-symbol-p v) v *cons*))) + (t + x))) + +(defmacro fancy-make-compound* (head &rest args) + (let ((hd (gensym)) + (fn (gensym))) + `(let* ((,hd ,head) + (,fn (function-make-compound*-function ,hd))) + (if ,fn + ,(if (null (rest args)) + `(funcall ,fn ,(first args)) + `(funcall ,fn (list* ,@args))) + (make-compound* ,hd ,@args))))) + +(defun make-compound2 (head args) + ;; e.g., (make-compound2 'and '(a b c)) = (and a (and b c)) + ;; (cl:assert (<= 2 (length args))) + (cond + ((null (rrest args)) + (make-compound* head args)) + (t + (make-compound head (first args) (make-compound2 head (rest args)))))) + +(defmacro make-a1-compound* (head identity &rest args) + (case (length args) + (1 + (let ((x (gensym))) + `(let ((,x ,(first args))) + (cond + ((null ,x) + ,identity) + ((null (rest ,x)) + (first ,x)) + (t + (make-compound* ,head ,x)))))) + (2 + (let ((x (gensym)) (y (gensym))) + `(let ((,x ,(first args)) (,y ,(second args))) + (cond + ((null ,y) + ,x) + (t + (make-compound* ,head ,x ,y)))))) + (otherwise + `(make-compound* ,head ,@args)))) + +(defmacro dereference (x subst &key + (if-variable nil) + (if-constant nil) + (if-compound nil if-compound-supplied) + (if-compound-cons nil if-compound-cons-supplied) + (if-compound-appl nil if-compound-appl-supplied)) + ;; dereferences x leaving result in x + (cl:assert (symbolp x)) + (cl:assert (symbolp subst)) + (cl:assert (implies if-compound-supplied + (and (not if-compound-cons-supplied) + (not if-compound-appl-supplied)))) + `(cond + ,@(unless (null subst) + (list (let ((bindings (gensym))) + `((and (variable-p ,x) + (or (null ,subst) + (let ((,bindings ,subst)) + (loop ;cf. lookup-variable-in-substitution + (cond + ((eq ,x (caarcc ,bindings)) + (if (variable-p (setf ,x (cdarcc ,bindings))) + (setf ,bindings ,subst) + (return nil))) + ((null (setf ,bindings (cdrc ,bindings))) + (return t))))))) + ,if-variable)))) + ,@(when if-compound + (list `((consp ,x) ,if-compound))) + ,@(when (or if-compound-cons if-compound-appl) + (list `((consp ,x) (if (function-symbol-p (carc ,x)) ,if-compound-appl ,if-compound-cons)))) + ,@(when (and if-constant (not (or if-compound if-compound-cons if-compound-appl))) + (list `((consp ,x) nil))) + ,@(when (and (null subst) (or if-variable if-constant)) + (list `((variable-p ,x) ,if-variable))) + ,@(when if-constant + (list `(t ,if-constant))))) + +(defmacro dereference2 (x y subst &key + if-constant*constant if-constant*compound if-constant*variable + if-compound*constant if-compound*compound if-compound*variable + if-variable*constant if-variable*compound if-variable*variable) + `(dereference + ,x ,subst + :if-constant (dereference ,y ,subst :if-constant ,if-constant*constant :if-compound ,if-constant*compound :if-variable ,if-constant*variable) + :if-compound (dereference ,y ,subst :if-constant ,if-compound*constant :if-compound ,if-compound*compound :if-variable ,if-compound*variable) + :if-variable (dereference ,y ,subst :if-constant ,if-variable*constant :if-compound ,if-variable*compound :if-variable ,if-variable*variable))) + +(defmacro prefer-to-bind-p (var2 var1) + (declare (ignore var2 var1)) + nil) + +(defvar *frozen-variables* nil) ;list of variables not allowed to be instantiated + +(definline variable-frozen-p (var) + (let ((l *frozen-variables*)) + (and l (member var l :test #'eq)))) + +(definline unfrozen-variable-p (x) + (and (variable-p x) + (not (variable-frozen-p x)))) + +(definline make-tc (term count) + ;; make term and count pair for count-arguments + (cons term count)) + +(definline tc-term (x) + ;; term part of term and count pair created by count-arguments + ;; term and count pair is represented as (term . count) + (carc x)) + +(defmacro tc-count (x) + ;; count part of term and count pair created by count-arguments + ;; term and count pair is represented as (term . count) + `(the fixnum (cdrc ,x))) + +;;; terms2.lisp EOF diff --git a/src/topological-sort.lisp b/src/topological-sort.lisp new file mode 100644 index 0000000..4292a4f --- /dev/null +++ b/src/topological-sort.lisp @@ -0,0 +1,81 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*- +;;; File: topological-sort.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2006. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-lisp) + +(defun topological-sort* (items map-predecessors) + ;; see Cormen, Leiserson, Rivest text + ;; (funcall map-predecessors cc u items) iterates over u in items + ;; that must occur before v and executes (funcall cc u) + ;; note: also eliminates EQL duplicates + (let ((color (make-hash-table)) + (result nil) result-last) + (labels + ((dfs-visit (v) + (when (eq :white (gethash v color :white)) + (setf (gethash v color) :gray) + (funcall map-predecessors #'dfs-visit v items) + (collect v result)))) + (loop + (if (null items) + (return result) + (dfs-visit (pop items))))))) + +(defun topological-sort (items must-precede-predicate) + (topological-sort* + items + (lambda (cc v items) + (mapc (lambda (u) + (when (and (neql u v) (funcall must-precede-predicate u v)) + (funcall cc u))) + items)))) + +#+ignore +(defun test-topological-sort* () + (topological-sort* + '(belt jacket pants shirt shoes socks tie undershorts watch) + (lambda (cc v items) + (declare (ignore items)) + (dolist (x '((undershorts . pants) + (undershorts . shoes) + (pants . belt) + (pants . shoes) + (belt . jacket) + (shirt . belt) + (shirt . tie) + (tie . jacket) + (socks . shoes))) + (when (eql v (cdr x)) + (funcall cc (car x))))))) + +#+ignore +(defun test-topological-sort () + (topological-sort + '(belt jacket pants shirt shoes socks tie undershorts watch) + (lambda (u v) + (member v + (cdr (assoc u + '((undershorts pants shoes) + (pants belt shoes) + (belt jacket) + (shirt belt tie) + (tie jacket) + (socks shoes)))))))) + +;;; topological-sort.lisp EOF diff --git a/src/tptp-symbols.lisp b/src/tptp-symbols.lisp new file mode 100644 index 0000000..e363bfc --- /dev/null +++ b/src/tptp-symbols.lisp @@ -0,0 +1,98 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*- +;;; File: tptp-symbols.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark-user) + +;;; defines TPTP arithmetic relations and functions in terms of SNARK ones +;;; +;;; TPTP assumes polymorphic relations and functions over disjoint integer, rational, and real domains +;;; +;;; SNARK integers are a subtype of rationals and rationals are a subtype of reals +;;; +;;; reals are represented as rationals (e.g., 0.5 -> 1/2) + +(defun declare-tptp-sort (sort-name) + (declare-subsort sort-name 'tptp-nonnumber :subsorts-incompatible t)) + +(defun declare-tptp-symbols1 (&key new-name) + (declare-sort '|$int| :iff 'integer) + (declare-sort '|$rat| :iff 'rational) + (declare-sort '|$real| :iff 'real) + ;; instead of + ;; (declare-subsort '|$i| :top-sort-a :subsorts-incompatible t), + ;; declare TPTP sorts so that TPTP distinct_objects can be sorted not just as strings + (declare-subsort 'tptp-nonnumber 'top-sort :subsorts-incompatible t) + (declare-sorts-incompatible 'tptp-nonnumber 'number) + (declare-tptp-sort '|$i|) + + (labels + ((declare-tptp-symbol (fn x) + (mvlet (((list tptp-name name arity) x)) + (funcall fn name arity (if new-name :new-name :alias) tptp-name)))) + + (mapc #'(lambda (x) (declare-tptp-symbol 'declare-relation x)) + '((|$less| $$less 2) + (|$lesseq| $$lesseq 2) + (|$greater| $$greater 2) + (|$greatereq| $$greatereq 2) + + #+ignore + (|$evaleq| $$eq 2) + + (|$is_int| $$integerp 1) + (|$is_rat| $$rationalp 1) + (|$is_real| $$realp 1) + )) + + (mapc #'(lambda (x) (declare-tptp-symbol 'declare-function x)) + '((|$uminus| $$uminus 1) + (|$sum| $$sum 2) + (|$difference| $$difference 2) + (|$product| $$product 2) + (|$quotient| $$quotient 2) + (|$quotient_e| $$quotient_e 2) + (|$quotient_f| $$quotient_f 2) + (|$quotient_t| $$quotient_t 2) + (|$remainder_e| $$remainder_e 2) + (|$remainder_f| $$remainder_f 2) + (|$remainder_t| $$remainder_t 2) + (|$floor| $$floor 1) + (|$truncate| $$truncate 1) + (|$to_int| $$floor 1) + )) + + (snark::declare-arithmetic-function '|$to_rat| 1 :sort 'rational :rewrite-code 'to_rat-term-rewriter) + (snark::declare-arithmetic-function '|$to_real| 1 :sort 'real :rewrite-code 'to_real-term-rewriter) + nil)) + +(defun declare-tptp-symbols2 (&optional type) + (declare (ignore type)) + nil) + +(defun to_rat-term-rewriter (term subst) + (let ((x (first (args term)))) + (dereference x subst) + (if (rationalp x) x (if (subsort? (term-sort x subst) (the-sort 'rational)) x none)))) + +(defun to_real-term-rewriter (term subst) + (let ((x (first (args term)))) + (dereference x subst) + (if (realp x) x (if (subsort? (term-sort x subst) (the-sort 'real)) x none)))) + +;;; tptp-symbols.lisp EOF diff --git a/src/tptp.lisp b/src/tptp.lisp new file mode 100644 index 0000000..9a202d3 --- /dev/null +++ b/src/tptp.lisp @@ -0,0 +1,645 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: tptp.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; TSTP justifications are incomplete: +;;; cnf and other transformations aren't named +;;; use of AC, other theories aren't named +;;; constraints aren't shown + +(defun print-row-in-tptp-format (row) + (let ((wff (row-wff row))) + (dolist (x (row-constraints row)) + (when (member (car x) '(arithmetic equality)) + (unless (eq true (cdr x)) + (setf wff (make-reverse-implication wff (cdr x)))))) + (print-wff-in-tptp-format1 wff (row-name-or-number row) (row-reason row) (row-source row)) + row)) + +(defun print-wff-in-tptp-format1 (wff name-or-number reason source) + (let ((vars (variables wff))) + (cond + ((some #'(lambda (var) (not (top-sort? (variable-sort var)))) vars) + (let ((*renumber-ignore-sort* t)) + (setf wff (renumber (make-compound *forall* (mapcar #'(lambda (var) (list var (tptp-sort-name (variable-sort var)))) (reverse vars)) wff)))) + (princ "tff(")) + ((not (unsorted-p wff)) + (princ "tff(")) + ((clause-p wff nil t) + (princ "cnf(")) + (t + (princ "fof(")))) + (print-row-name-or-number-in-tptp-format name-or-number) + (princ ", ") + (print-row-reason-in-tptp-format reason) + (princ ",") + (terpri) + (princ " ") + (print-wff-in-tptp-format wff) + (let ((v (print-row-reason-in-tptp-format2 reason))) + (print-row-source-in-tptp-format source v)) + (princ ").") + wff) + +(defun print-row-reason-in-tptp-format (reason) + (princ (case reason + (assertion "axiom") + (assumption "hypothesis") + (conjecture "conjecture") + (negated_conjecture "negated_conjecture") + (hint "hint") + (otherwise "plain")))) + +(defun print-row-name-or-number-in-tptp-format (name-or-number) + (print-symbol-in-tptp-format name-or-number)) + +(defun print-row-reason-in-tptp-format2 (reason) + (case reason + ((assertion assumption conjecture negated_conjecture hint nil) + nil) + (otherwise + (princ ",") + (terpri) + (princ " ") + (print-row-reason-in-tptp-format3 reason) + t))) + +(defun print-row-reason-in-tptp-format3 (x) + (cond + ((consp x) + (princ "inference(") + (cond + ((eq 'paramodulate (first x)) + (setf x (append x '(|theory(equality)|)))) + ((eq 'rewrite (first x)) + (cond + ((member :code-for-= (rrest x)) + (setf x (append (remove :code-for-= x) '(|theory(equality)|)))) + ((some (lambda (row) (and (row-p row) (compound-p (row-wff row)) (eq *=* (head (row-wff row))))) (rrest x)) + (setf x (append x '(|theory(equality)|))))))) + (print-symbol-in-tptp-format (first x)) + (princ ",") + (princ "[status(thm)]") + (princ ",") + (princ "[") + (let ((first t)) + (dolist (arg (rest x)) + (if first (setf first nil) (princ ",")) + (print-row-reason-in-tptp-format3 arg))) + (princ "]") + (princ ")")) + ((row-p x) + (print-row-name-or-number-in-tptp-format (row-name-or-number x))) + ((or (eq '|theory(equality)| x) (eq :code-for-= x)) + (princ '|theory(equality)|)) + (t + (print-symbol-in-tptp-format x)))) + +(defun print-row-source-in-tptp-format (source &optional list) + ;; "file('foo.tptp',ax1)" or (|file| |foo.tptp| |ax1|) + (when source + (cond + ((and (stringp source) (< 6 (length source)) (string= "file(" source :end2 4)) + (princ ",") + (terpri) + (princ (if list " [" " ")) + (princ source) + (when list (princ "]"))) + ((and (consp source) (eq '|file| (first source)) (<= 2 (length source) 3)) + (princ ",") + (terpri) + (princ (if list " [" " ")) + (princ "file(") + (print-symbol-in-tptp-format (second source)) + (when (rrest source) + (princ ",") + (print-symbol-in-tptp-format (third source))) + (princ ")") + (when list (princ "]"))))) + source) + +(defun print-wff-in-tptp-format (wff &optional subst) + (dereference + wff subst + :if-variable (print-term-in-tptp-format wff) + :if-constant (cond + ((eq true wff) + (princ "$true")) + ((eq false wff) + (princ "$false")) + (t + (print-term-in-tptp-format wff))) + :if-compound (cond + ((equality-p wff) + (print-term-in-tptp-format (arg1 wff) subst) (princ " = ") (print-term-in-tptp-format (arg2 wff) subst)) + ((negation-p wff) + (let ((wff (arg1 wff))) + (dereference wff subst) + (cond + ((equality-p wff) + (print-term-in-tptp-format (arg1 wff) subst) (princ " != ") (print-term-in-tptp-format (arg2 wff) subst)) + (t + (princ "~ ") (print-wff-in-tptp-format wff subst))))) + ((disjunction-p wff) + (princ "(") (print-wffs-in-tptp-format (args wff) subst " | ") (princ ")")) + ((conjunction-p wff) + (princ "(") (print-wffs-in-tptp-format (args wff) subst " & ") (princ ")")) + ((equivalence-p wff) + (princ "(") (print-wffs-in-tptp-format (args wff) subst " <=> ") (princ ")")) + ((exclusive-or-p wff) + (princ "(") (print-wffs-in-tptp-format (args wff) subst " <~> ") (princ ")")) + ((implication-p wff) + (princ "(") (print-wffs-in-tptp-format (args wff) subst " => ") (princ ")")) + ((reverse-implication-p wff) + (princ "(") (print-wffs-in-tptp-format (args wff) subst " <= ") (princ ")")) + ((universal-quantification-p wff) + (princ "(! ") (print-varspecs (arg1 wff)) (princ " : ") (print-wff-in-tptp-format (arg2 wff) subst) (princ ")")) + ((existential-quantification-p wff) + (princ "(? ") (print-varspecs (arg1 wff)) (princ " : ") (print-wff-in-tptp-format (arg2 wff) subst) (princ ")")) + (t + (print-term-in-tptp-format wff subst)))) + wff) + +(defun print-wffs-in-tptp-format (wffs subst sep) + (let ((first t)) + (dolist (wff wffs) + (if first (setf first nil) (princ sep)) + (print-wff-in-tptp-format wff subst)))) + +(defun tptp-function-name (fn) + ;; if symbol begins with $$, return an alias if it is lower case and begins with $ + (let* ((name (function-name fn)) + (s (symbol-name name))) + (or (and (< 2 (length s)) + (eql #\$ (char s 1)) + (eql #\$ (char s 0)) + (some #'(lambda (alias) + (let ((s (symbol-name alias))) + (and (< 1 (length s)) + (eql #\$ (char s 0)) + (neql #\$ (char s 1)) + (notany #'upper-case-p s) + alias))) + (symbol-aliases fn))) + name))) + +(defun print-term-in-tptp-format (term &optional subst) + (dereference + term subst + :if-variable (progn + (cl:assert (top-sort? (variable-sort term))) + (mvlet (((values i j) (floor (variable-number term) 6))) + (princ (char "XYZUVW" j)) + (unless (= 0 i) + (write i :radix nil :base 10)))) + :if-constant (print-symbol-in-tptp-format (constant-name term)) + :if-compound (let ((head (head term))) + (cond + ((eq *cons* head) + (princ "[") + (print-list-in-tptp-format term subst) + (princ "]")) + (t + (print-symbol-in-tptp-format (tptp-function-name head)) + (princ "(") + (print-list-in-tptp-format (args (unflatten-term1 term subst)) subst) + (princ ")"))))) + term) + +(defun print-varspecs (l) + (princ "[") + (let ((first t)) + (dolist (x l) + (if first (setf first nil) (princ ", ")) + (cond + ((variable-p x) + (print-term-in-tptp-format x)) + (t + (print-term-in-tptp-format (first x)) + (princ ": ") + (print-term-in-tptp-format (second x)))))) + (princ "]")) + +(defun print-list-in-tptp-format (l subst) + (let ((first t)) + (loop + (cond + ((dereference l subst :if-compound-cons t) + (if first (setf first nil) (princ ",")) + (print-term-in-tptp-format (car l) subst) + (setf l (cdr l))) + ((null l) + (return)) + (t + (princ "|") + (print-term-in-tptp-format l subst) + (return)))))) + +(defun quote-tptp-symbol? (x &optional invert) + ;; returns t (or :escape) if symbol must be quoted as in 'a=b' + ;; returns :escape if some characters must be escaped as in 'a\'b' + ;; returns nil for , , + (and (symbolp x) + (let* ((string (symbol-name x)) + (len (length string))) + (or (= 0 len) + (let ((quote nil) + (dollar nil)) + (dotimes (i len (or quote dollar)) + (let ((ch (char string i))) + (cond + ((or (eql #\' ch) (eql #\\ ch)) + (return :escape)) + ((= 0 i) + (if (eql #\$ ch) + (setf dollar t) + (setf quote (if invert (not (upper-case-p ch)) (not (lower-case-p ch)))))) + (dollar + (unless (and (= 1 i) (eql #\$ ch)) + (setf dollar nil) + (setf quote (if invert (not (upper-case-p ch)) (not (lower-case-p ch)))))) + ((not quote) + (setf quote (not (or (alphanumericp ch) (eql #\_ ch))))))))))))) + +(defun print-symbol-in-tptp-format (x) + (etypecase x + (symbol + (let* ((string (symbol-name x)) + (invert (and nil (eq :invert (readtable-case *readtable*)) (not (iff (some #'upper-case-p string) (some #'lower-case-p string))))) + (quote (quote-tptp-symbol? x invert))) + (when quote + (princ #\')) + (cond + ((eq :escape quote) + (map nil + #'(lambda (ch) + (cond + ((or (eq #\' ch) (eq #\\ ch)) + (princ #\\) + (princ ch)) + (t + (princ (if invert (char-invert-case ch) ch))))) + string)) + (invert + (princ x)) + (t + (princ string))) + (when quote + (princ #\'))) + x) + (number + (write x :radix nil :base 10)) + (string + (prin1 x)))) + +(defun tptp-sort-name (sort) + (let ((name (sort-name sort))) + (case name + (integer '|$int|) + (rational '|$rat|) + (real '|$real|) + (otherwise name)))) + +(defvar *tptp-environment-variable* + #-mcl "/Users/mark/tptp" + #+mcl "Ame:Users:mark:tptp") + +(defun tptp-include-file-name (filename filespec) + ;; filename is file name argument of an include directive + ;; filespec specifies the file that contains the include directive + (or (let (pathname) + (cond + ((and (setf pathname (merge-pathnames (string filename) filespec)) + (probe-file pathname)) + pathname) + ((and *tptp-environment-variable* + (setf pathname (merge-pathnames (to-string *tptp-environment-variable* #-mcl "/" #+mcl ":" filename) filespec)) + (probe-file pathname)) + pathname))) + ;; as backup, use this older ad hoc code for TPTP/Problems & TPTP/Axioms directory structure + (let ((revdir (reverse (pathname-directory filespec))) v) + (cond + ((setf v (member "Problems" revdir :test #'string-equal)) + (setf revdir (rest v))) + ((setf v (member-if #'(lambda (x) (and (stringp x) (<= 4 (length x)) (string-equal "TPTP" x :end2 4))) revdir)) + (setf revdir v))) + (setf filename (string filename)) + (loop + (let ((pos (position-if #'(lambda (ch) (or (eq '#\/ ch) (eq '#\: ch))) filename))) + (cond + ((null pos) + (return)) + (t + (setf revdir (cons (subseq filename 0 pos) revdir)) + (setf filename (subseq filename (+ pos 1))))))) + (make-pathname + :directory (nreverse revdir) + :name (pathname-name filename) + :type (pathname-type filename))))) + +(defun tptp-file-source-string (filename &optional (name none)) + (if (eq none name) + (list '|file| filename) + (list '|file| filename name))) + +(defun mapnconc-tptp-file-forms (function filespec &key (if-does-not-exist :error) (package *package*)) + (let ((*package* (find-or-make-package package)) + (snark-infix-reader::*infix-operators* snark-infix-reader::*infix-operators*) + (snark-infix-reader::*prefix-operators* snark-infix-reader::*prefix-operators*) + (snark-infix-reader::*postfix-operators* snark-infix-reader::*postfix-operators*)) + (declare-tptp-operators) + (labels + ((mapnconc-tptp-file-forms1 (filespec if-does-not-exist formula-selection) + (let ((filename (intern (namestring filespec))) + (tokens (with-open-file (stream filespec :direction :input :if-does-not-exist if-does-not-exist) + (tokenize stream :rationalize t))) + (result nil) result-last form) + (loop + (when (null tokens) + (return result)) + (setf (values form tokens) (read-tptp-term1 tokens)) + (ecase (if (consp form) (first form) form) + ((|cnf| |fof| |tff|) + (when (implies formula-selection (member (second form) formula-selection)) + (ncollect (funcall function + (cond + ((eq '|type| (third form)) + (input-tptp-type-declaration (fourth form))) + (t + (let ((ask-for-answer (and (consp (fourth form)) (eq 'tptp-double-question-mark (first (fourth form))))) + (ask-for-answer2 (member (third form) '(|question| |negated_question|)))) + (let ((args nil)) + (when (or ask-for-answer ask-for-answer2) + (setf args (list* :answer 'from-wff args))) + (let ((reason (tptp-to-snark-reason (third form)))) + (unless (eq 'assertion reason) + (setf args (list* :reason reason args)))) + (when (and (eq '|cnf| (first form)) (can-be-row-name (second form))) + (setf args (list* :name (second form) args))) + (setf args (list* :source (tptp-file-source-string filename (second form)) args)) + (list* 'assertion (if ask-for-answer (cons 'exists (rest (fourth form))) (fourth form)) args)))))) + result))) + (|include| + (cl:assert (implies (rrest form) (and (consp (third form)) (eq '$$list (first (third form)))))) + (ncollect (mapnconc-tptp-file-forms1 (tptp-include-file-name (second form) filespec) :error (rest (third form))) result))))))) + (mapnconc-tptp-file-forms1 filespec if-does-not-exist nil)))) + +(defun tptp-to-snark-reason (reason) + (case reason + (|axiom| 'assertion) + ((|assumption| |hypothesis|) 'assumption) + ((|negated_conjecture| |negated_question|) 'negated_conjecture) + ((|conjecture| |question|) 'conjecture) + (otherwise 'assertion))) + +(defun input-tptp-type-declaration (x) + (cond + ((and (consp x) (eq 'tptp-colon (first x))) + (cond + ((eq '|$tType| (third x)) + ;; default declaration that can be overridden by subtype declaration + `(declare-tptp-sort ',(second x))) + ((symbolp (third x)) + (if (eq '|$o| (third x)) + `(declare-proposition ',(second x)) + `(declare-constant ',(second x) :sort ',(third x)))) + (t + (cl:assert (and (consp (third x)) + (eq 'tptp-type-arrow (first (third x))) + (tptp-type-product-p (second (third x))))) + (let* ((argsorts (number-list (tptp-type-product-list (second (third x))))) + (arity (length argsorts))) + (if (eq '|$o| (third (third x))) + `(declare-relation ',(second x) ,arity :sort ',argsorts) + `(declare-function ',(second x) ,arity :sort ',(cons (third (third x)) argsorts))))))) + ((and (consp x) (eq 'tptp-subtype (first x)) (symbolp (second x)) (symbolp (third x))) + `(declare-subsort ',(second x) ',(third x) :subsorts-incompatible t)) + (t + (error "Could not interpret type declaration ~S." x)))) + +(defun tptp-type-product-p (x) + (or (symbolp x) + (and (consp x) + (eq 'tptp-type-product (pop x)) + (consp x) + (tptp-type-product-p (pop x)) + (consp x) + (tptp-type-product-p (pop x)) + (null x)))) + +(defun tptp-type-product-list (x) + (if (symbolp x) + (list x) + (append (tptp-type-product-list (second x)) + (tptp-type-product-list (third x))))) + +(defun number-list (l &optional (n 1)) + (if (endp l) + nil + (cons (list n (first l)) + (number-list (rest l) (+ 1 n))))) + +(defvar *tptp-format* :tptp) + +;(defvar *tptp-input-directory* '(:absolute #+(and mcl (not openmcl)) "Macintosh HD" "Users" "mark" "tptp" "snark" "in")) +;(defvar *tptp-input-directory-domains?* nil) +;(defvar *tptp-input-file-type* "tptp") + +(defvar *tptp-input-directory* '(:absolute #+(and mcl (not openmcl)) "Macintosh HD" "Users" "mark" "tptp" "Problems")) +(defvar *tptp-input-directory-has-domain-subdirectories* t) +(defvar *tptp-input-file-type* "p") + +(defvar *tptp-output-directory* '(:absolute #+(and mcl (not openmcl)) "Macintosh HD" "Users" "mark" "tptp" "snark" "out")) +(defvar *tptp-output-directory-has-domain-subdirectories* nil) +(defvar *tptp-output-file-type* "out") + +(defun tptp-problem-pathname0 (name type directory has-domain-subdirectories) + (let ((pn (merge-pathnames (parse-namestring (to-string name "." type)) (make-pathname :directory directory)))) + (if has-domain-subdirectories + (merge-pathnames (make-pathname :directory (append (pathname-directory pn) (list (subseq (pathname-name pn) 0 3)))) pn) + pn))) + +(defun tptp-problem-input-pathname (problem) + (tptp-problem-pathname0 + problem + *tptp-input-file-type* + *tptp-input-directory* + *tptp-input-directory-has-domain-subdirectories*)) + +(defun tptp-problem-output-pathname (problem) + (tptp-problem-pathname0 + problem + *tptp-output-file-type* + *tptp-output-directory* + *tptp-output-directory-has-domain-subdirectories*)) + +(defun do-tptp-problem (problem &key (format *tptp-format*) (use-coder nil) options) + (refute-file + (tptp-problem-input-pathname problem) + :use-coder use-coder + :format format + :options options + :ignore-errors t + :verbose t + :output-file (tptp-problem-output-pathname problem) + :if-exists nil)) + +(defun do-tptp-problem0 (problem &key (format *tptp-format*) (use-coder nil) options) + (refute-file + (tptp-problem-input-pathname problem) + :use-coder use-coder + :format format + :options options)) + +(defun do-tptp-problem1 (problem &key (format *tptp-format*) options) + (do-tptp-problem0 + problem + :format format + :options (append '((agenda-length-limit nil) + (agenda-length-before-simplification-limit nil) + (use-hyperresolution t) + (use-ur-resolution t) + (use-paramodulation t) + (use-factoring :pos) + (use-literal-ordering-with-hyperresolution 'literal-ordering-p) + (use-literal-ordering-with-paramodulation 'literal-ordering-p) + (ordering-functions>constants t) + (assert-context :current) + (use-closure-when-satisfiable t) + (print-options-when-starting nil) + (use-variable-name-sorts nil) + (use-purity-test t) + (use-relevance-test t) + (snark-user::declare-tptp-symbols1)) + options))) + +(defun translate-assertion-file-to-tptp-format (inputfilespec &optional outputfilespec &rest read-assertion-file-options) + (let ((snark-state (suspend-snark))) + (unwind-protect + (progn + (initialize) + (use-subsumption nil) + (use-simplification-by-units nil) + (use-simplification-by-equalities nil) + (print-options-when-starting nil) + (print-summary-when-finished nil) + (print-rows-when-derived nil) + (mapc #'eval (apply #'read-assertion-file inputfilespec read-assertion-file-options)) + (closure) + (cond + (outputfilespec + (with-open-file (*standard-output* outputfilespec :direction :output) + (print-rows :format :tptp))) + (t + (print-rows :format :tptp)))) + (resume-snark snark-state)) + nil)) + +(defun declare-tptp-operators () + (declare-operator-syntax "<=>" :xfy 505 'iff) + (declare-operator-syntax "<~>" :xfy 505 'xor) + (declare-operator-syntax "=>" :xfy 504 'implies) + (declare-operator-syntax "<=" :xfy 504 'implied-by) + (declare-operator-syntax "&" :xfy 503 'and) + (declare-operator-syntax "~&" :xfy 503 'nand) + (declare-operator-syntax "|" :xfy 502 'or) + (declare-operator-syntax "~|" :xfy 502 'nor) +;;(declare-operator-syntax "@" :yfx 501) + (declare-operator-syntax "*" :yfx 480 'tptp-type-product) +;;(declare-operator-syntax "+" :yfx 480 'tptp-type-union) + (declare-operator-syntax ":" :xfy 450 'tptp-colon) + (declare-operator-syntax "~" :fy 450 'not) + (declare-operator-syntax "<<" :xfx 450 'tptp-subtype) + (declare-operator-syntax ">" :xfy 440 'tptp-type-arrow) + (declare-operator-syntax "=" :xfx 405 '=) + (declare-operator-syntax "!=" :xfx 405 '/=) +;;(declare-operator-syntax "~=" :xfx 405) + (declare-operator-syntax "!" :fx 400 'forall) + (declare-operator-syntax "?" :fx 400 'exists) + (declare-operator-syntax "??" :fx 400 'tptp-double-question-mark) +;;(declare-operator-syntax "^" :fx 400) +;;(declare-operator-syntax ".." :xfx 400) +;;(declare-operator-syntax "!" :xf 100) + nil) + +(defun tptp-to-snark-input (x) + (cond + ((atom x) + (cond + ((eq '|$true| x) + true) + ((eq '|$false| x) + false) + (t + (fix-tptp-symbol x)))) + ((and (eq 'tptp-colon (first x)) + (consp (second x)) + (member (first (second x)) '(forall exists tptp-double-question-mark)) + (consp (second (second x))) + (eq '$$list (first (second (second x))))) + ;; (: (quantifier (list . variables)) form) -> (quantifer variables form) + (list (first (second x)) (strip-colons (rest (second (second x)))) (tptp-to-snark-input (third x)))) + (t + (lcons (fix-tptp-symbol (first x)) (tptp-to-snark-input-args (rest x)) x)))) + +(defun fix-tptp-symbol (x) + ;; this is to allow users to input '?x' to create a constant ?x instead of a variable + ;; '?...' is tokenized as |^A?...| and '^A...' is tokenized as |^A^A...| by the infix reader + ;; this code removes the front ^A and wraps the symbol in a $$quote form if second character is ? + (let (name) + (cond + ((and (symbolp x) (< 0 (length (setf name (symbol-name x)))) (eql (code-char 1) (char name 0))) + (if (and (< 0 (length (setf name (subseq name 1)))) (eql (code-char 1) (char name 0))) + (intern name) + (list '$$quote (intern name)))) + (t + x)))) + +(defun tptp-to-snark-input-args (l) + (lcons (tptp-to-snark-input (first l)) + (tptp-to-snark-input-args (rest l)) + l)) + +(defun strip-colons (l) + ;; (: var type) -> (var type) in quantifier variables + ;; no transformation yet for (: integer var) or (: integer (: var type)) + (lcons (if (and (consp (first l)) + (eq 'tptp-colon (first (first l))) + (symbolp (second (first l))) + (symbolp (third (first l)))) + (rest (first l)) + (first l)) + (strip-colons (rest l)) + l)) + +(defun read-tptp-term1 (x &rest options) + (declare (dynamic-extent options)) + (multiple-value-bind (term rest) (apply 'read-infix-term x (append options (list :rationalize t))) + (values (tptp-to-snark-input term) rest))) + +(defun read-tptp-term (x &rest options) + (declare (dynamic-extent options)) + (let ((snark-infix-reader::*infix-operators* snark-infix-reader::*infix-operators*) + (snark-infix-reader::*prefix-operators* snark-infix-reader::*prefix-operators*) + (snark-infix-reader::*postfix-operators* snark-infix-reader::*postfix-operators*)) + (declare-tptp-operators) + (apply 'read-tptp-term1 x options))) + +;;; tptp.lisp EOF diff --git a/src/trie-index.lisp b/src/trie-index.lisp new file mode 100644 index 0000000..a893a61 --- /dev/null +++ b/src/trie-index.lisp @@ -0,0 +1,574 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: trie-index.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *trie-index*) + +(defstruct (trie-index + (:constructor make-trie-index0 (entry-constructor)) + (:copier nil)) + (entry-constructor nil :read-only t) ;term->entry function for new entry insertion + (node-counter (make-counter 1) :read-only t) + (entry-counter (make-counter) :read-only t) + (top-node (make-trie-index-internal-node) :read-only t) + (retrieve-generalization-calls 0 :type integer) ;number of generalization retrieval calls + (retrieve-generalization-count 0 :type integer) + (retrieve-instance-calls 0 :type integer) ; " instance " + (retrieve-instance-count 0 :type integer) + (retrieve-unifiable-calls 0 :type integer) ; " unifiable " + (retrieve-unifiable-count 0 :type integer) + (retrieve-variant-calls 0 :type integer) ; " variant " + (retrieve-variant-count 0 :type integer) + (retrieve-all-calls 0 :type integer) ; " all " + (retrieve-all-count 0 :type integer)) + +(defstruct (trie-index-internal-node + (:copier nil)) + (variable-child-node nil) ;nil or node + (constant-indexed-child-nodes nil) ;constant# -> node sparse-vector + (function-indexed-child-nodes nil)) ;function# -> node sparse-vector + +(defstruct (trie-index-leaf-node + (:include sparse-vector (snark-sparse-array::default-value0 none :read-only t)) + (:copier nil)) + ) + +(defmacro trie-index-leaf-node-entries (n) + n) + +(defstruct (index-entry + (:constructor make-index-entry (term)) + (:copier nil)) + (term nil :read-only t)) + +(defun make-trie-index (&key (entry-constructor #'make-index-entry)) + (setf *trie-index* (make-trie-index0 entry-constructor))) + +(definline trie-index-internal-node-variable-indexed-child-node (node &optional create internal) + (or (trie-index-internal-node-variable-child-node node) + (and create + (progn + (increment-counter (trie-index-node-counter *trie-index*)) + (setf (trie-index-internal-node-variable-child-node node) + (if internal + (make-trie-index-internal-node) + (make-trie-index-leaf-node))))))) + +(definline trie-index-internal-node-constant-indexed-child-node (const node &optional create internal) + (let ((children (trie-index-internal-node-constant-indexed-child-nodes node))) + (unless children + (when create + (setf children (setf (trie-index-internal-node-constant-indexed-child-nodes node) (make-sparse-vector))))) + (and children + (let ((const# (constant-number const))) + (or (sparef children const#) + (and create + (progn + (increment-counter (trie-index-node-counter *trie-index*)) + (setf (sparef children const#) + (if internal + (make-trie-index-internal-node) + (make-trie-index-leaf-node)))))))))) + +(definline trie-index-internal-node-function-indexed-child-node (fn node &optional create internal) + (let ((children (trie-index-internal-node-function-indexed-child-nodes node))) + (unless children + (when create + (setf children (setf (trie-index-internal-node-function-indexed-child-nodes node) (make-sparse-vector))))) + (and children + (let ((fn# (function-number fn))) + (or (sparef children fn#) + (and create + (progn + (increment-counter (trie-index-node-counter *trie-index*)) + (setf (sparef children fn#) + (if internal + (make-trie-index-internal-node) + (make-trie-index-leaf-node)))))))))) + +(definline function-trie-index-lookup-args (fn term) + ;; fn = (head term) unless term is nil (not specified) + (ecase (function-index-type fn) + ((nil) + (cond + ((function-unify-code fn) + nil) + (t + (let ((arity (function-arity fn))) + (if (eq :any arity) (list (args term)) (args term)))))) + (:commute + ;; index all arguments, lookup with first two in order and commuted + ;; (a b c d) -> 4, (c d a b), (c d (%index-or (a b) (b a))) for arity 4 + ;; (a b c d) -> 3, ((c d) a b), ((c d) (%index-or (a b) (b a))) for arity :any + (let ((arity (function-arity fn))) + (let* ((args (args term)) + (l (rest (rest args))) + (a (first args)) + (b (second args)) + (v (list (list '%index-or (if l (list a b) args) (list b a))))) + (cond + ((eq :any arity) + (cons l v)) + (l + (append l v)) + (t + v))))) + (:jepd + ;; index only first two arguments, lookup with first two in order and commuted + ;; (a b c) -> 2, (a b), ((%index-or (a b) (b a))) + (let* ((args (args term)) + (a (first args)) + (b (second args))) + (list (list '%index-or (list a b) (list b a))))) + (:hash-but-dont-index + nil))) + +(definline function-trie-index-args (fn term) + (ecase (function-index-type fn) + ((nil) + (cond + ((function-unify-code fn) + nil) + (t + (let ((arity (function-arity fn))) + (if (eq :any arity) (list (args term)) (args term)))))) + (:commute + (let ((arity (function-arity fn))) + (let* ((args (args term)) + (l (rest (rest args))) + (v (if l (list (first args) (second args)) args))) + (cond + ((eq :any arity) + (cons l v)) + (l + (append l v)) + (t + v))))) + (:jepd + (let ((args (args term))) + (list (first args) (second args)))) + (:hash-but-dont-index + nil))) + +(definline function-trie-index-arity (fn) + (ecase (function-index-type fn) + ((nil) + (cond + ((function-unify-code fn) + 0) + (t + (let ((arity (function-arity fn))) + (if (eq :any arity) 1 arity))))) + (:commute + (let ((arity (function-arity fn))) + (if (eq :any arity) 3 arity))) + (:jepd + 2) + (:hash-but-dont-index + 0))) + +(defun simply-indexed-p (term &optional subst) + (dereference + term subst + :if-variable t + :if-constant t + :if-compound-cons (and (simply-indexed-p (carc term)) + (simply-indexed-p (cdrc term))) + :if-compound-appl (and (let ((fn (heada term))) + (ecase (function-index-type fn) + ((nil) + (null (function-unify-code fn))) + (:commute + nil) + (:hash-but-dont-index + t) + (:jepd + nil))) + (dolist (arg (argsa term) t) + (unless (simply-indexed-p arg subst) + (return nil)))))) + +(definline trie-index-build-path-for-terms (terms node internal) + (if internal + (dolist (x terms node) + (setf node (trie-index-build-path-for-term x node t))) + (dotails (l terms node) + (setf node (trie-index-build-path-for-term (first l) node (rest l)))))) + +(defun trie-index-build-path-for-term (term node &optional internal) + (dereference + term nil + :if-variable (trie-index-internal-node-variable-indexed-child-node node t internal) + :if-constant (trie-index-internal-node-constant-indexed-child-node term node t internal) + :if-compound (let* ((head (head term)) + (args (function-trie-index-args head term))) + (if (null args) + (trie-index-internal-node-function-indexed-child-node head node t internal) + (trie-index-build-path-for-terms args (trie-index-internal-node-function-indexed-child-node head node t t) internal))))) + +(definline trie-index-path-for-terms (terms path) + (dolist (x terms path) + (when (null (setf path (trie-index-path-for-term x path))) + (return nil)))) + +(defun trie-index-path-for-term (term path) + (let ((node (first path))) + (dereference + term nil + :if-variable (let ((n (trie-index-internal-node-variable-indexed-child-node node))) + (and n (list* n 'variable path))) + :if-constant (let ((n (trie-index-internal-node-constant-indexed-child-node term node))) + (and n (list* n 'constant term path))) + :if-compound (let* ((head (head term)) + (n (trie-index-internal-node-function-indexed-child-node head node))) + (and n (let ((args (function-trie-index-args head term))) + (if (null args) + (list* n 'function head path) + (trie-index-path-for-terms args (list* n 'function head path))))))))) + +(defun trie-index-insert (term &optional entry) + (let* ((trie-index *trie-index*) + (entries (trie-index-leaf-node-entries (trie-index-build-path-for-term term (trie-index-top-node trie-index))))) + (cond + ((null entry) + (prog-> + (map-sparse-vector entries :reverse t ->* e) + (when (or (eql term (index-entry-term e)) (and (test-option38?) (equal-p term (index-entry-term e)))) + (return-from trie-index-insert e))) + (setf entry (funcall (trie-index-entry-constructor trie-index) term))) + (t + (cl:assert (eql term (index-entry-term entry))) + (prog-> + (map-sparse-vector entries :reverse t ->* e) + (when (eq entry e) + (return-from trie-index-insert e)) + (when (or (eql term (index-entry-term e)) (and (test-option38?) (equal-p term (index-entry-term e)))) + (error "There is already a trie-index entry for term ~A." term))))) + (increment-counter (trie-index-entry-counter trie-index)) + (setf (sparef entries (nonce)) entry))) + +(defun trie-index-delete (term &optional entry) + (let* ((trie-index *trie-index*) + (path (trie-index-path-for-term term (list (trie-index-top-node trie-index))))) + (when path + (let* ((entries (trie-index-leaf-node-entries (pop path))) + (k (cond + ((null entry) + (prog-> + (map-sparse-vector-with-indexes entries :reverse t ->* e k) + (when (eql term (index-entry-term e)) + (return-from prog-> k)))) + (t + (cl:assert (eql term (index-entry-term entry))) + (prog-> + (map-sparse-vector-with-indexes entries :reverse t ->* e k) + (when (eq entry e) + (return-from prog-> k))))))) + (when k + (decrement-counter (trie-index-entry-counter trie-index)) + (setf (sparef entries k) none) + (when (eql 0 (sparse-vector-count entries)) + (let ((node-counter (trie-index-node-counter trie-index)) + parent) + (loop + (ecase (pop path) + (function + (let ((k (function-number (pop path)))) + (setf (sparef (trie-index-internal-node-function-indexed-child-nodes (setf parent (pop path))) k) nil))) + (constant + (let ((k (constant-number (pop path)))) + (setf (sparef (trie-index-internal-node-constant-indexed-child-nodes (setf parent (pop path))) k) nil))) + (variable + (setf (trie-index-internal-node-variable-child-node (setf parent (pop path))) nil))) + (decrement-counter node-counter) + (unless (and (rest path) ;not top node + (null (trie-index-internal-node-variable-child-node parent)) + (eql 0 (sparse-vector-count (trie-index-internal-node-function-indexed-child-nodes parent))) + (eql 0 (sparse-vector-count (trie-index-internal-node-constant-indexed-child-nodes parent)))) + (return))))) + t))))) + +(defmacro map-trie-index-entries (&key if-variable if-constant if-compound count-call count-entry) + (declare (ignorable count-call count-entry)) + `(labels + ((map-for-term (cc term node) + (dereference + term subst + :if-variable ,if-variable + :if-constant ,if-constant + :if-compound ,if-compound)) + (map-for-terms (cc terms node) + (cond + ((null terms) + (funcall cc node)) + (t + (let ((term (pop terms))) + (cond + ((and (consp term) (eq '%index-or (first term))) + (cond + ((null terms) + (prog-> + (dolist (rest term) ->* terms1) + (map-for-terms terms1 node ->* node) + (funcall cc node))) + (t + (prog-> + (dolist (rest term) ->* terms1) + (map-for-terms terms1 node ->* node) + (map-for-terms terms node ->* node) + (funcall cc node))))) + (t + (cond + ((null terms) + (prog-> + (map-for-term term node ->* node) + (funcall cc node))) + (t + (prog-> + (map-for-term term node ->* node) + (map-for-terms terms node ->* node) + (funcall cc node)))))))))) + (skip-terms (cc n node) + (declare (type fixnum n)) + (cond + ((= 1 n) + (progn + (prog-> + (trie-index-internal-node-variable-indexed-child-node node ->nonnil node) + (funcall cc node)) + (prog-> + (trie-index-internal-node-constant-indexed-child-nodes node ->nonnil constant-indexed-children) + (map-sparse-vector constant-indexed-children ->* node) + (funcall cc node)) + (prog-> + (trie-index-internal-node-function-indexed-child-nodes node ->nonnil function-indexed-children) + (map-sparse-vector-with-indexes function-indexed-children ->* node fn#) + (skip-terms (function-trie-index-arity (symbol-numbered fn#)) node ->* node) + (funcall cc node)))) + ((= 0 n) + (funcall cc node)) + (t + (progn + (decf n) + (prog-> + (trie-index-internal-node-variable-indexed-child-node node ->nonnil node) + (skip-terms n node ->* node) + (funcall cc node)) + (prog-> + (trie-index-internal-node-constant-indexed-child-nodes node ->nonnil constant-indexed-children) + (map-sparse-vector constant-indexed-children ->* node) + (skip-terms n node ->* node) + (funcall cc node)) + (prog-> + (trie-index-internal-node-function-indexed-child-nodes node ->nonnil function-indexed-children) + (map-sparse-vector-with-indexes function-indexed-children ->* node fn#) + (skip-terms (+ n (function-trie-index-arity (symbol-numbered fn#))) node ->* node) + (funcall cc node))))))) + (let ((trie-index *trie-index*)) +;; ,count-call + (cond + ((simply-indexed-p term subst) + (prog-> + (map-for-term term (trie-index-top-node trie-index) ->* leaf-node) + (map-sparse-vector (trie-index-leaf-node-entries leaf-node) :reverse t ->* e) +;; ,count-entry + (funcall cc e))) + (t + (prog-> + (quote nil -> seen) + (map-for-term term (trie-index-top-node trie-index) ->* leaf-node) + (when (do ((s seen (cdrc s))) ;(not (member leaf-node seen)) + ((null s) + t) + (when (eq leaf-node (carc s)) + (return nil))) + (prog-> + (map-sparse-vector (trie-index-leaf-node-entries leaf-node) :reverse t ->* e) +;; ,count-entry + (funcall cc e)) + (setf seen (cons leaf-node seen))))))) + nil)) + +(defun map-trie-index-instance-entries (cc term subst) + (map-trie-index-entries + :count-call (incf (trie-index-retrieve-instance-calls trie-index)) + :count-entry (incf (trie-index-retrieve-instance-count trie-index)) + :if-variable (prog-> + (skip-terms 1 node ->* node) + (funcall cc node)) + :if-constant (prog-> + (trie-index-internal-node-constant-indexed-child-node term node ->nonnil node) + (funcall cc node)) + :if-compound (prog-> + (head term -> head) + (trie-index-internal-node-function-indexed-child-node head node ->nonnil node) + (map-for-terms (function-trie-index-lookup-args head term) node ->* node) + (funcall cc node)))) + +(defun map-trie-index-generalization-entries (cc term subst) + ;; in snark-20060805 vs. snark-20060806 test over TPTP, + ;; constant and compound lookup before variable lookup outperforms + ;; variable lookup before constant and compound lookup + (map-trie-index-entries + :count-call (incf (trie-index-retrieve-generalization-calls trie-index)) + :count-entry (incf (trie-index-retrieve-generalization-count trie-index)) + :if-variable (prog-> + (trie-index-internal-node-variable-indexed-child-node node ->nonnil node) + (funcall cc node)) + :if-constant (progn + (prog-> + (trie-index-internal-node-constant-indexed-child-node term node ->nonnil node) + (funcall cc node)) + (prog-> + (trie-index-internal-node-variable-indexed-child-node node ->nonnil node) + (funcall cc node))) + :if-compound (progn + (prog-> + (head term -> head) + (trie-index-internal-node-function-indexed-child-node head node ->nonnil node) + (map-for-terms (function-trie-index-lookup-args head term) node ->* node) + (funcall cc node)) + (prog-> + (trie-index-internal-node-variable-indexed-child-node node ->nonnil node) + (funcall cc node))))) + +(defun map-trie-index-unifiable-entries (cc term subst) + (map-trie-index-entries + :count-call (incf (trie-index-retrieve-unifiable-calls trie-index)) + :count-entry (incf (trie-index-retrieve-unifiable-count trie-index)) + :if-variable (prog-> + (skip-terms 1 node ->* node) + (funcall cc node)) + :if-constant (progn + (prog-> + (trie-index-internal-node-variable-indexed-child-node node ->nonnil node) + (funcall cc node)) + (prog-> + (trie-index-internal-node-constant-indexed-child-node term node ->nonnil node) + (funcall cc node))) + :if-compound (progn + (prog-> + (trie-index-internal-node-variable-indexed-child-node node ->nonnil node) + (funcall cc node)) + (prog-> + (head term -> head) + (trie-index-internal-node-function-indexed-child-node head node ->nonnil node) + (map-for-terms (function-trie-index-lookup-args head term) node ->* node) + (funcall cc node))))) + +(defun map-trie-index-variant-entries (cc term subst) + (map-trie-index-entries + :count-call (incf (trie-index-retrieve-variant-calls trie-index)) + :count-entry (incf (trie-index-retrieve-variant-count trie-index)) + :if-variable (prog-> + (trie-index-internal-node-variable-indexed-child-node node ->nonnil node) + (funcall cc node)) + :if-constant (prog-> + (trie-index-internal-node-constant-indexed-child-node term node ->nonnil node) + (funcall cc node)) + :if-compound (prog-> + (head term -> head) + (trie-index-internal-node-function-indexed-child-node head node ->nonnil node) + (map-for-terms (function-trie-index-lookup-args head term) node ->* node) + (funcall cc node)))) + +(defun map-trie-index-all-entries (cc) + (let ((term (make-variable nil 0)) + (subst nil)) + (map-trie-index-entries + :count-call (incf (trie-index-retrieve-all-calls trie-index)) + :count-entry (incf (trie-index-retrieve-all-count trie-index)) + :if-variable (prog-> + (skip-terms 1 node ->* node) + (funcall cc node))))) + +(definline map-trie-index (cc type term &optional subst) + (ecase type + (:generalization + (map-trie-index-generalization-entries cc term subst)) + (:instance + (map-trie-index-instance-entries cc term subst)) + (:unifiable + (map-trie-index-unifiable-entries cc term subst)) + (:variant + (map-trie-index-variant-entries cc term subst)))) + +(defun print-trie-index (&key terms nodes) + (let ((index *trie-index*)) + (mvlet (((:values current peak added deleted) (counter-values (trie-index-entry-counter index)))) + (format t "~%; Trie-index has ~:D entr~:@P (~:D at peak, ~:D added, ~:D deleted)." current peak added deleted)) + (mvlet (((:values current peak added deleted) (counter-values (trie-index-node-counter index)))) + (format t "~%; Trie-index has ~:D node~:P (~:D at peak, ~:D added, ~:D deleted)." current peak added deleted)) + (unless (eql 0 (trie-index-retrieve-variant-calls index)) + (format t "~%; Trie-index retrieved ~:D variant term~:P in ~:D call~:P." + (trie-index-retrieve-variant-count index) + (trie-index-retrieve-variant-calls index))) + (unless (eql 0 (trie-index-retrieve-generalization-calls index)) + (format t "~%; Trie-index retrieved ~:D generalization term~:P in ~:D call~:P." + (trie-index-retrieve-generalization-count index) + (trie-index-retrieve-generalization-calls index))) + (unless (eql 0 (trie-index-retrieve-instance-calls index)) + (format t "~%; Trie-index retrieved ~:D instance term~:P in ~:D call~:P." + (trie-index-retrieve-instance-count index) + (trie-index-retrieve-instance-calls index))) + (unless (eql 0 (trie-index-retrieve-unifiable-calls index)) + (format t "~%; Trie-index retrieved ~:D unifiable term~:P in ~:D call~:P." + (trie-index-retrieve-unifiable-count index) + (trie-index-retrieve-unifiable-calls index))) + (unless (eql 0 (trie-index-retrieve-all-calls index)) + (format t "~%; Trie-index retrieved ~:D unrestricted term~:P in ~:D call~:P." + (trie-index-retrieve-all-count index) + (trie-index-retrieve-all-calls index))) + (when (or nodes terms) + (print-index* (trie-index-top-node index) nil terms)))) + +(defun print-index* (node revpath print-terms) + (prog-> + (map-index-leaf-nodes node revpath ->* node revpath) + (print-index-leaf-node node revpath print-terms))) + +(defmethod map-index-leaf-nodes (cc (node trie-index-internal-node) revpath) + (prog-> + (trie-index-internal-node-variable-indexed-child-node node ->nonnil node) + (map-index-leaf-nodes node (cons '? revpath) ->* node revpath) + (funcall cc node revpath)) + (prog-> + (map-sparse-vector-with-indexes (trie-index-internal-node-constant-indexed-child-nodes node) ->* node const#) + (map-index-leaf-nodes node (cons (symbol-numbered const#) revpath) ->* node revpath) + (funcall cc node revpath)) + (prog-> + (map-sparse-vector-with-indexes (trie-index-internal-node-function-indexed-child-nodes node) ->* node fn#) + (map-index-leaf-nodes node (cons (symbol-numbered fn#) revpath) ->* node revpath) + (funcall cc node revpath))) + +(defmethod map-index-leaf-nodes (cc (node trie-index-leaf-node) revpath) + (funcall cc node revpath)) + +(defmethod print-index-leaf-node ((node trie-index-leaf-node) revpath print-terms) + (with-standard-io-syntax2 + (prog-> + (trie-index-leaf-node-entries node -> entries) + (format t "~%; Path ~A has ~:D entr~:@P." (reverse revpath) (sparse-vector-count entries)) + (when print-terms + (map-sparse-vector entries :reverse t ->* entry) + (format t "~%; ") + (print-term (index-entry-term entry)))))) + +;;; trie-index.lisp EOF diff --git a/src/trie.lisp b/src/trie.lisp new file mode 100644 index 0000000..92f80ce --- /dev/null +++ b/src/trie.lisp @@ -0,0 +1,101 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: trie.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; trie indexed by list of integers + +(defmacro make-trie-node () + `(cons nil nil)) + +(defmacro trie-node-data (node) + `(car ,node)) + +(defmacro trie-node-branches (node) + `(cdr ,node)) + +(defstruct (trie + (:copier nil)) + (top-node (make-trie-node) :read-only t) + (node-counter (make-counter 1) :read-only t)) + +(defun trieref (trie keys) + (do ((keys keys (rest keys)) + (node (trie-top-node trie) (let ((b (trie-node-branches node))) + (if b (sparef b (first keys)) nil)))) + ((or (null node) (null keys)) + (if node (trie-node-data node) nil)))) + +(defun (setf trieref) (data trie keys) + (if data + (do ((keys keys (rest keys)) + (node (trie-top-node trie) (let ((b (trie-node-branches node)) + (key (first keys))) + (if b + (or (sparef b key) + (setf (sparef b key) + (progn (increment-counter (trie-node-counter trie)) (make-trie-node)))) + (setf (sparef (setf (trie-node-branches node) (make-sparse-vector)) key) + (progn (increment-counter (trie-node-counter trie)) (make-trie-node))))))) + ((null keys) + (setf (trie-node-data node) data))) + (labels + ((trie-delete (node keys) + ;; return t to delete this node from parent when data and branches are both empty + (cond + ((null keys) + (setf (trie-node-data node) nil) + (null (trie-node-branches node))) + (t + (let ((b (trie-node-branches node))) + (when b + (let* ((key (first keys)) + (node1 (sparef b key))) + (when (and node1 (trie-delete node1 (rest keys))) + (decrement-counter (trie-node-counter trie)) + (if (= 1 (sparse-vector-count b)) + (progn (setf (trie-node-branches node) nil) (null (trie-node-data node))) + (setf (sparef b key) nil)))))))))) + (trie-delete (trie-top-node trie) keys) + nil))) + +(defun trie-size (trie &optional count-only-data-nodes?) + (labels + ((ts (node) + (let ((size (if (and count-only-data-nodes? (null (trie-node-data node))) 0 1))) + (prog-> + (trie-node-branches node ->nonnil b) + (map-sparse-vector b ->* node) + (setf size (+ size (trie-size node count-only-data-nodes?)))) + size))) + (ts (trie-top-node trie)))) + +(defun map-trie (function trie-or-node) + (labels + ((mt (node) + (let ((d (trie-node-data node))) + (when d + (funcall function d))) + (let ((b (trie-node-branches node))) + (when b + (map-sparse-vector #'mt b))))) + (declare (dynamic-extent #'mt)) + (mt (if (trie-p trie-or-node) (trie-top-node trie-or-node) trie-or-node)))) + +;;; trie.lisp EOF diff --git a/src/unify-bag.lisp b/src/unify-bag.lisp new file mode 100644 index 0000000..871f701 --- /dev/null +++ b/src/unify-bag.lisp @@ -0,0 +1,859 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: unify-bag.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun submultisetp (x y &key test key) + (cond + ((null x) + t) + ((null y) + nil) + (t + (setf y (copy-list y)) + (dolist (x1 x t) + (cond + ((if test + (funcall test x1 (car y)) + (eql x1 (car y))) + (setf y (cdr y))) + (t + (do ((l1 y l2) + (l2 (cdr y) (cdr l2))) + ((null l2) (return-from submultisetp nil)) + (when (if key + (if test + (funcall test (funcall key x1) (funcall key (car l2))) + (eql (funcall key x1) (funcall key (car l2)))) + (if test + (funcall test x1 (car l2)) + (eql x1 (car l2)))) + (rplacd l1 (cdr l2)) + (return nil))))))))) + +(defun multiset-equal (x y &key test key) + (and (length= x y) + (submultisetp x y :test test :key key))) + +;;; special variables used by bag unification algorithm +;;; and linear Diophantine equation basis algorithm + +(defvar maxx) +(defvar maxy) + +(defmacro check-unify-bag-basis-size () + `(when (< (unify-bag-basis-size-limit?) (incf unify-bag-basis-size)) + (warn "Unify-bag basis size limit exceeded. No unifiers returned.") + (throw 'unify-bag-basis-quit + nil))) + +(defmacro a-coef (i) + `(svref a-coef-array ,i)) + +(defmacro b-coef (j) + `(svref b-coef-array ,j)) + +(defmacro x-term (i) + `(svref x-term-array ,i)) + +(defmacro y-term (j) + `(svref y-term-array ,j)) + +(defmacro x-bind (i) + `(svref x-bind-array ,i)) + +(defmacro y-bind (j) + `(svref y-bind-array ,j)) + +(defmacro xx-unify-p (i k) + ;; x-term.i,x-term.k unifiability (i 2 variables. + ;; + ;; Performance should be best when: + ;; maxb <= maxa. + ;; a1 >= a2 >= ... >= am. + ;; b1 <= b2 <= ... <= bn. + (let ((simple-solution (make-array (list nxcoefs nycoefs))) ;x-term.i,y-term.j unifiability + (x-term-ground-array (and (not all-x-term-ground) (make-array nxcoefs))) (new-all-x-term-ground t) + (y-term-ground-array (and (not all-y-term-ground) (make-array nycoefs))) (new-all-y-term-ground t) + (maxa 0) (maxb 0) (suma 0) (sumb 0) + (complex-solutions nil)) + ;; recompute all-x-term-ground and all-y-term-ground in case formerly nonground terms are now ground + (loop for i below nxcoefs + as coef = (a-coef i) + do (incf suma coef) + (when (> coef maxa) + (setf maxa coef)) + (unless all-x-term-ground + (let ((ground (frozen-p (x-term i) subst))) + (setf (x-term-ground-p i) ground) + (unless ground + (setf new-all-x-term-ground nil))))) + (loop for j below nycoefs + as coef = (b-coef j) + do (incf sumb coef) + (when (> coef maxb) + (setf maxb coef)) + (unless all-y-term-ground + (let ((ground (frozen-p (y-term j) subst))) + (setf (y-term-ground-p j) ground) + (unless ground + (setf new-all-y-term-ground nil))))) + (setf all-x-term-ground new-all-x-term-ground) + (setf all-y-term-ground new-all-y-term-ground) + (when (cond + (all-x-term-ground + (or all-y-term-ground (and (eq none identity) (or (< suma sumb) (< maxa maxb))))) + (all-y-term-ground + (and (eq none identity) (or (> suma sumb) (> maxa maxb)))) + (t + nil)) + (throw 'unify-bag-basis-quit nil)) + (dotimes (i nxcoefs) ;initialize xy-unify-p + (let* ((x-term.i (x-term i)) + (x-term.i-ground (or all-x-term-ground (x-term-ground-p i)))) + (dotimes (j nycoefs) + (let ((y-term.j (y-term j))) + (setf (xy-unify-p i j) (cond + ((and x-term.i-ground (or all-y-term-ground (y-term-ground-p j))) + nil) + ((and (embedding-variable-p x-term.i) + (embedding-variable-p y-term.j)) + nil) + (t + (unify-p x-term.i y-term.j subst)))))))) + (dotimes (i nxcoefs) + (unless (and (neq none identity) (not (or all-x-term-ground (x-term-ground-p i))) (unify-p (x-term i) identity subst)) + (dotimes (j nycoefs (throw 'unify-bag-basis-quit nil)) + (when (xy-unify-p i j) + (return nil))))) + (dotimes (j nycoefs) + (unless (and (neq none identity) (not (or all-y-term-ground (y-term-ground-p j))) (unify-p (y-term j) identity subst)) + (dotimes (i nxcoefs (throw 'unify-bag-basis-quit nil)) + (when (xy-unify-p i j) + (return nil))))) + (let ((xx-and-yy-unify-array (let ((ncoefs (if (>= nxcoefs nycoefs) nxcoefs nycoefs))) + (make-array (list ncoefs ncoefs)))) + (unify-bag-basis-size 0)) + (unless all-x-term-ground + (dotimes (i (- nxcoefs 1)) ;initialize xx-unify-p + (do* ((x-term.i (x-term i)) + (x-term.i-ground (x-term-ground-p i)) + (k (+ i 1) (+ k 1))) + ((eql k nxcoefs)) + (let ((x-term.k (x-term k))) + (setf (xx-unify-p i k) (cond + ((and x-term.i-ground (x-term-ground-p k)) + nil) + (t + (unify-p x-term.i x-term.k subst)))))))) + (unless all-y-term-ground + (dotimes (j (- nycoefs 1)) ;initialize yy-unify-p + (do* ((y-term.j (y-term j)) + (y-term.j-ground (y-term-ground-p j)) + (k (+ j 1) (+ k 1))) + ((eql k nycoefs)) + (let ((y-term.k (y-term k))) + (setf (yy-unify-p j k) (cond + ((and y-term.j-ground (y-term-ground-p k)) + nil) + (t + (unify-p y-term.j y-term.k subst)))))))) + (setf x-term-ground-array nil) ;done with x-term-ground-array + (setf y-term-ground-array nil) ;and y-term-ground-array now + (dotimes (i nxcoefs) ;store 2 variable solutions in simple-solution + (cond + ((unfrozen-variable-p (x-term i)) + (dotimes (j nycoefs) + (when (xy-unify-p i j) + (cond + ((unfrozen-variable-p (y-term j)) + (check-unify-bag-basis-size) + (let ((k (lcm (a-coef i) (b-coef j)))) + (setf (aref simple-solution i j) (cons (truncate k (a-coef i)) + (truncate k (b-coef j)))))) + ((eql 0 (mod (b-coef j) (a-coef i))) + (check-unify-bag-basis-size) + (setf (aref simple-solution i j) (cons (truncate (b-coef j) (a-coef i)) 1))))))) + (t + (dotimes (j nycoefs) + (when (xy-unify-p i j) + (cond + ((unfrozen-variable-p (y-term j)) + (cond + ((eql 0 (mod (a-coef i) (b-coef j))) + (check-unify-bag-basis-size) + (setf (aref simple-solution i j) (cons 1 (truncate (a-coef i) (b-coef j))))))) + ((eql (a-coef i) (b-coef j)) + (check-unify-bag-basis-size) + #+openmcl ;workaround for openmcl-1.1-pre-070722 + (setf (aref simple-solution i j) (cons 1 1)) + #-openmcl + (setf (aref simple-solution i j) '(1 . 1))))))))) + (cond + ((and (<= maxa 1) (<= maxb 1)) ;no complex solutions if all coefficients <= 1 + ) + (t + (let (initial-maxsum + (maxx (make-array nxcoefs)) + (maxy (make-array nycoefs)) + (xsol (make-array nxcoefs)) + (ysol (make-array nycoefs)) + complex-solutions-tail) + (cond + (all-x-term-ground + (setf initial-maxsum suma) + (dotimes (i nxcoefs) + (setf (svref maxx i) 1)) + (dotimes (j nycoefs) + (setf (svref maxy j) (if (unfrozen-variable-p (y-term j)) maxa 1)))) + (all-y-term-ground + (setf initial-maxsum sumb) + (dotimes (j nycoefs) + (setf (svref maxy j) 1)) + (dotimes (i nxcoefs) + (setf (svref maxx i) (if (unfrozen-variable-p (x-term i)) maxb 1)))) + (t + (setf initial-maxsum 0) + (dotimes (i nxcoefs) + (setf (svref maxx i) (if (unfrozen-variable-p (x-term i)) maxb 1))) + (dotimes (j nycoefs) + (incf initial-maxsum + (* (setf (svref maxy j) (if (unfrozen-variable-p (y-term j)) maxa 1)) + (b-coef j)))))) + (labels + ((xloop (i sum maxsum) + (let ((i+1 (+ i 1))) + (setf (svref xsol i) 0) + (cond + ((< i+1 nxcoefs) + (xloop i+1 sum maxsum)) + ((plusp sum) + (yloop 0 sum))) + (let ((maxval (svref maxx i))) + (when (plusp maxval) + (let ((a-coef.i (a-coef i))) + (incf sum a-coef.i) + (when (<= sum maxsum) + (do ((val 1 (+ val 1)) + (maxx maxx) + (maxy maxy) + (newmaxx nil) + (newmaxy nil)) + ((> val maxval)) + (setf (svref xsol i) val) + (when (eql 1 val) + (do ((k (+ i 1) (+ k 1))) + ((eql k nxcoefs)) + (when (or all-x-term-ground (not (xx-unify-p i k))) + (unless newmaxx + (setf maxx (copy-seq maxx)) + (setf newmaxx t)) + (setf (svref maxx k) 0))) + (dotimes (j nycoefs) + (let ((maxy.j (svref maxy j))) + (when (and (plusp maxy.j) + (not (xy-unify-p i j))) + (decf maxsum (* (b-coef j) maxy.j)) + (unless newmaxy + (setf maxy (copy-seq maxy)) + (setf newmaxy t)) + (setf (svref maxy j) 0))))) + (dotimes (j nycoefs) + (let ((simple-solution.i.j (aref simple-solution i j))) + (when (consp simple-solution.i.j) + (when (eql val (car simple-solution.i.j)) + (let ((maxy.j (svref maxy j)) + (n (cdr simple-solution.i.j))) + (when (>= maxy.j n) + (let ((n-1 (- n 1))) + (decf maxsum (* (b-coef j) (- maxy.j n-1))) + (unless newmaxy + (setf maxy (copy-seq maxy)) + (setf newmaxy t)) + (setf (svref maxy j) n-1)))))))) + (cond + ((< i+1 nxcoefs) + (xloop i+1 sum maxsum)) + (t + (yloop 0 sum))) + (incf sum a-coef.i) + (when (> sum maxsum) + (return nil))))))))) + + (yloop (j sum) + (let ((b-coef.j (b-coef j)) + (maxval (svref maxy j)) + (j+1 (+ j 1))) + (cond + ((eql j+1 nycoefs) + (let ((val (truncate sum b-coef.j))) + (when (and (<= val maxval) + (eql (* b-coef.j val) sum)) + (setf (svref ysol j) val) + (filter)))) + (t + (do ((val 0 (+ val 1)) + (maxy maxy) + (newmaxy nil)) + ((> val maxval)) + (setf (svref ysol j) val) + (when (eql val 1) + (do ((k (+ j 1) (+ k 1))) + ((eql k nycoefs)) + (when (or all-y-term-ground (not (yy-unify-p j k))) + (unless newmaxy + (setf maxy (copy-seq maxy)) + (setf newmaxy t)) + (setf (svref maxy k) 0)))) + (yloop j+1 sum) + (decf sum b-coef.j) + (when (minusp sum) + (return nil))))))) + + (filter nil + ;; eliminate solutions with only two variables + ;; and solutions that that are greater than a previous solution and are thus composable + ;; store the solution if it passes the tests +;; (format t "~%" ) (dotimes (i nxcoefs) (format t "~4d" (svref xsol i))) +;; (format t " ") (dotimes (j nycoefs) (format t "~4d" (svref ysol j))) + (cond + ((and + (loop for i from (+ 1 (loop for k below nxcoefs when (plusp (svref xsol k)) return k)) below nxcoefs + never (plusp (svref xsol i))) ;returns t if xsol has only one nonzero value + (loop for j from (+ 1 (loop for k below nycoefs when (plusp (svref ysol k)) return k)) below nycoefs + never (plusp (svref ysol j)))) ;returns t if ysol has only one nonzero value + ) + ((loop for v in complex-solutions ;returns t if new solution is greater than previous one + thereis (and + (loop with xsol1 = (car v) + for i below nxcoefs + always (>= (svref xsol i) (svref xsol1 i))) + (loop with ysol1 = (cdr v) + for j below nycoefs + always (>= (svref ysol j) (svref ysol1 j))))) + ) + (t + (check-unify-bag-basis-size) + (setf complex-solutions-tail + (if complex-solutions-tail + (setf (cdr complex-solutions-tail) + (cons (cons (copy-seq xsol) + (copy-seq ysol)) + nil)) + (setf complex-solutions + (cons (cons (copy-seq xsol) + (copy-seq ysol)) + nil)))))))) + + (xloop 0 0 initial-maxsum))))) + (when (trace-unify-bag-basis?) + (print-unify-bag-basis nxcoefs nycoefs a-coef-array b-coef-array simple-solution complex-solutions)) + (values simple-solution complex-solutions)))) + +(declare-snark-option use-subsume-bag t t) + +(defun ac-unify (cc x y subst) + (unify-bag cc (args x) (args y) subst (head x))) + +(defun unify-bag (cc terms1 terms2 subst fn) + (cond + ((and (use-subsume-bag?) (frozen-p terms2 subst)) + (subsume-bag cc terms1 terms2 subst fn)) + ((and (use-subsume-bag?) (frozen-p terms1 subst)) + (subsume-bag cc terms2 terms1 subst fn)) + ((meter-unify-bag?) + (let ((start-time (get-internal-run-time))) + (unwind-protect + (let-options ((meter-unify-bag nil)) ;only meter top-level calls + (unify-bag* cc fn terms1 terms2 subst)) + (let ((elapsed-time (/ (- (get-internal-run-time) start-time) + (float internal-time-units-per-second)))) + (when (implies (numberp (meter-unify-bag?)) (<= (meter-unify-bag?) elapsed-time)) + (format t "~2&~,3F seconds to unify-bag ~S and ~S." + elapsed-time + (flatten-term (make-compound* fn terms1) subst) + (flatten-term (make-compound* fn terms2) subst))))))) + (t + (unify-bag* cc fn terms1 terms2 subst)))) + +(defun unify-bag* (cc fn terms1 terms2 subst) + (let ((identity (let ((id (function-identity2 fn))) + (cond + ((neq none id) + id) + (t + none)))) + (nxcoefs 0) (nycoefs 0) + (x-term-is-ground nil) (y-term-is-ground nil) + (all-x-term-ground t) (all-y-term-ground t) + firsta firstb firstx firsty + (terms-and-counts (count-arguments fn terms2 subst (count-arguments fn terms1 subst) -1))) + (loop for tc in terms-and-counts + as count = (tc-count tc) + when (plusp count) + do (incf nxcoefs) + (unless firsta + (setf firsta count) + (setf firstx (tc-term tc))) + (when (or (not x-term-is-ground) all-x-term-ground) + (if (frozen-p (tc-term tc) subst) + (setf x-term-is-ground t) + (setf all-x-term-ground nil))) + else + when (minusp count) + do (incf nycoefs) + (unless firstb + (setf firstb (- count)) + (setf firsty (tc-term tc))) + (when (or (not y-term-is-ground) all-y-term-ground) + (if (frozen-p (tc-term tc) subst) + (setf y-term-is-ground t) + (setf all-y-term-ground nil)))) + (cond + ((and (eql 0 nxcoefs) (eql 0 nycoefs)) + (funcall cc subst)) + ((or (eql 0 nxcoefs) (eql 0 nycoefs)) + (unless (eq none identity) + (unify-identity cc terms-and-counts subst identity))) + ((and (eql 1 nxcoefs) (eql 1 nycoefs)) ;unify-identity is an unimplemented possibility too + (cond + ((eql firsta firstb) + (unify cc firstx firsty subst)) + ((eql 0 (rem firstb firsta)) + (when (unfrozen-variable-p firstx) + (unify cc firstx (make-compound* fn (consn firsty nil (/ firstb firsta))) subst))) + ((eql 0 (rem firsta firstb)) + (when (unfrozen-variable-p firsty) + (unify cc (make-compound* fn (consn firstx nil (/ firsta firstb))) firsty subst))) + (t + (when (and (unfrozen-variable-p firstx) (unfrozen-variable-p firsty)) + (let ((n (lcm firsta firstb)) + (newvar (make-variable (function-sort fn)))) + (prog-> + (unify firstx (make-compound* fn (consn newvar nil (/ n firsta))) subst ->* subst) + (unify cc firsty (make-compound* fn (consn newvar nil (/ n firstb))) subst))))))) + ((and (eql 1 nxcoefs) (eql 1 firsta)) ;unify-identity is an unimplemented possibility too + (when (unfrozen-variable-p firstx) + (unify cc firstx + (make-compound* fn (loop for tc in terms-and-counts + as count = (tc-count tc) + when (minusp count) + nconc (consn (tc-term tc) nil (- count)))) + subst + ))) + ((and (eql 1 nycoefs) (eql 1 firstb)) ;unify-identity is an unimplemented possibility too + (when (unfrozen-variable-p firsty) + (unify cc (make-compound* fn (loop for tc in terms-and-counts + as count = (tc-count tc) + when (plusp count) + nconc (consn (tc-term tc) nil count))) + firsty + subst + ))) + (all-y-term-ground + (loop for tc in terms-and-counts + do (setf (tc-count tc) (- (tc-count tc)))) + (unify-bag0 cc fn nycoefs nxcoefs terms-and-counts identity subst all-y-term-ground all-x-term-ground)) + (t + (unify-bag0 cc fn nxcoefs nycoefs terms-and-counts identity subst all-x-term-ground all-y-term-ground))))) + +(defun sort-terms-and-counts (terms-and-counts subst) + ;; compounds < constants & frozen variables < unfrozen variables + (stable-sort terms-and-counts + (lambda (tc1 tc2) + (let ((x (tc-term tc1)) (y (tc-term tc2))) + (dereference + x subst + :if-variable (dereference y subst :if-variable (and (variable-frozen-p x) + (not (variable-frozen-p y)))) + :if-constant (dereference y subst :if-variable (not (variable-frozen-p y))) + :if-compound (dereference y subst :if-variable t :if-constant t)))))) + +(defun unify-bag0 (cc fn nxcoefs nycoefs terms-and-counts identity subst all-x-term-ground all-y-term-ground) + (let ((a-coef-array (make-array nxcoefs)) + (b-coef-array (make-array nycoefs)) + (x-term-array (make-array nxcoefs)) + (y-term-array (make-array nycoefs))) + (loop for tc in (sort-terms-and-counts ;initialize a-coef-array, x-term-array + (loop for x in terms-and-counts when (plusp (tc-count x)) collect x) + subst) + as i from 0 + do (setf (a-coef i) (tc-count tc)) + (setf (x-term i) (tc-term tc))) + (loop for tc in (sort-terms-and-counts ;initialize b-coef-array, y-term-array + (loop for x in terms-and-counts when (minusp (tc-count x)) collect x) + subst) + as j from 0 + do (setf (b-coef j) (- (tc-count tc))) + (setf (y-term j) (tc-term tc))) + (catch 'unify-bag-basis-quit + (mvlet (((values simple-solution complex-solutions) + (unify-bag-basis nxcoefs nycoefs a-coef-array b-coef-array x-term-array y-term-array identity subst + all-x-term-ground all-y-term-ground))) + (dotimes (i nxcoefs) (setf (a-coef i) nil)) ;reuse a-coef-array as x-bind-array + (dotimes (j nycoefs) (setf (b-coef j) nil)) ;reuse b-coef-array as y-bind-array + (unify-bag1 cc fn nxcoefs nycoefs a-coef-array b-coef-array x-term-array y-term-array subst identity + simple-solution complex-solutions))))) + +(defmacro nosol3x (s) + `(and (null (x-bind i)) ;x-term unmatched, but no later simple-solution applies + (or (eq none identity) + (not (unfrozen-variable-p (x-term i)))) + (loop for j1 from ,s below nycoefs + as simple-solution.i.j1 = (aref simple-solution i j1) + never (and (consp simple-solution.i.j1) + (or (and (null (y-bind j1)) (eql 1 (cdr simple-solution.i.j1))) + (unfrozen-variable-p (y-term j1))))))) + +(defmacro nosol3y (s) + `(and (null (y-bind j)) ;y-term unmatched, but no later simple-solution applies + (or (eq none identity) + (not (unfrozen-variable-p (y-term j)))) + (loop for i1 from ,s below nxcoefs + as simple-solution.i1.j = (aref simple-solution i1 j) + never (and (consp simple-solution.i1.j) + (or (and (null (x-bind i1)) (eql 1 (car simple-solution.i1.j))) + (unfrozen-variable-p (x-term i1))))))) + +(defmacro unify-bag2* (x subst) + `(if ,x + (unify-bag2 ,x ,subst) + (unless (or (loop for i below nxcoefs thereis (nosol3x 0)) + (loop for j below nycoefs thereis (nosol3y 0))) + (unify-bag3 0 0 ,subst)))) + +(defun unify-bag1 (cc fn + nxcoefs nycoefs + x-bind-array y-bind-array + x-term-array y-term-array subst + identity simple-solution complex-solutions) + (labels + ((unify-bag2 (complex-solns subst) + (let ((xsol (caar complex-solns)) + (ysol (cdar complex-solns))) + (cond + ((and ;check that this solution can be added in + (loop for i below nxcoefs + as xsol.i = (svref xsol i) + never (and (neql 0 xsol.i) + (or (neql 1 xsol.i) (x-bind i)) + (not (unfrozen-variable-p (x-term i))))) + (loop for j below nycoefs + as ysol.j = (svref ysol j) + never (and (neql 0 ysol.j) + (or (neql 1 ysol.j) (y-bind j)) + (not (unfrozen-variable-p (y-term j)))))) + (when (test-option8?) + (unless (and (neq none identity) ; AC1 UNIFICATION SUPPORT? + (loop for i below nxcoefs + never (and (plusp (svref xsol i)) + (not (unfrozen-variable-p (x-term i))))) + (loop for j below nycoefs + never (and (plusp (svref ysol j)) + (not (unfrozen-variable-p (y-term j)))))) + (unify-bag2* (cdr complex-solns) subst))) + (let ((newvar (or (dotimes (j nycoefs) + (when (and (eql 1 (svref ysol j)) + (not (unfrozen-variable-p (y-term j)))) + (return (y-term j)))) + (dotimes (i nxcoefs) + (when (and (eql 1 (svref xsol i)) + (not (unfrozen-variable-p (x-term i)))) + (return (x-term i)))) + (make-variable (function-sort fn))))) + (dotimes (i nxcoefs) + (let ((xsol.i (svref xsol i))) + (unless (eql 0 xsol.i) + (setf (x-bind i) (consn newvar (x-bind i) xsol.i))))) + (dotimes (j nycoefs) + (let ((ysol.j (svref ysol j))) + (unless (eql 0 ysol.j) + (setf (y-bind j) (consn newvar (y-bind j) ysol.j))))) + (unify-bag2* (cdr complex-solns) subst)) + (dotimes (i nxcoefs) + (let ((xsol.i (svref xsol i))) + (unless (eql 0 xsol.i) + (setf (x-bind i) (nthcdr xsol.i (x-bind i)))))) + (dotimes (j nycoefs) + (let ((ysol.j (svref ysol j))) + (unless (eql 0 ysol.j) + (setf (y-bind j) (nthcdr ysol.j (y-bind j)))))) + (unless (test-option8?) + (unless (and (neq none identity) ; AC1 UNIFICATION SUPPORT? + (loop for i below nxcoefs + never (and (plusp (svref xsol i)) + (not (unfrozen-variable-p (x-term i))))) + (loop for j below nycoefs + never (and (plusp (svref ysol j)) + (not (unfrozen-variable-p (y-term j)))))) + (unify-bag2* (cdr complex-solns) subst))) + ) + (t + (unify-bag2* (cdr complex-solns) subst))))) + + (unify-bag3* (i j+1 subst) + (if (eql j+1 nycoefs) + (let ((i+1 (+ i 1))) + (if (eql i+1 nxcoefs) + (progn + (when (trace-unify-bag-bindings?) + (terpri-comment) + (format t "Unify-bag will try to unify") + (print-bindings x-term-array x-bind-array nxcoefs) + (print-bindings y-term-array y-bind-array nycoefs) + (terpri)) + (bind-xterm 0 subst)) ;start unifying terms and bindings + (unify-bag3 i+1 0 subst))) + (unify-bag3 i j+1 subst))) + + (unify-bag3 (i j subst) + (let ((simple-solution.i.j (aref simple-solution i j)) + (j+1 (+ j 1))) + (cond + ((consp simple-solution.i.j) + (let ((m (car simple-solution.i.j)) + (n (cdr simple-solution.i.j)) + (x-term.i (x-term i)) + (y-term.j (y-term j)) + (x-bind.i (x-bind i)) + (y-bind.j (y-bind j))) + (cond + ((and (or (and (null x-bind.i) (eql 1 m)) + (unfrozen-variable-p x-term.i)) + (or (and (null y-bind.j) (eql 1 n)) + (unfrozen-variable-p y-term.j))) + (unless (and (neq none identity) ;AC1 UNIFICATION SUPPORT + (unfrozen-variable-p x-term.i) + (unfrozen-variable-p y-term.j)) + (when (or x-bind.i y-bind.j) + (unless (or (nosol3x j+1) (nosol3y (+ i 1))) + (unify-bag3* i j+1 subst)))) + (cond + ((and (null x-bind.i) (eql 1 m) + (null y-bind.j) (eql 1 n) + (not (unfrozen-variable-p x-term.i)) + (not (unfrozen-variable-p y-term.j)) + (not (special-unify-p x-term.i subst)) + (not (special-unify-p y-term.j subst))) + (setf (x-bind i) (cons x-term.i nil)) + (setf (y-bind j) (cons y-term.j nil)) + (prog-> + (unify x-term.i y-term.j subst ->* subst) + (unify-bag3* i j+1 subst))) + (t + (let ((newvar (cond + ((not (unfrozen-variable-p y-term.j)) + y-term.j) + ((not (unfrozen-variable-p x-term.i)) + x-term.i) + (t + (make-variable (function-sort fn)))))) + (setf (x-bind i) (consn newvar x-bind.i m)) + (setf (y-bind j) (consn newvar y-bind.j n)) + (unify-bag3* i j+1 subst)))) + (setf (x-bind i) x-bind.i) + (setf (y-bind j) y-bind.j) + (unless (and (neq none identity) ;AC1 UNIFICATION SUPPORT + (unfrozen-variable-p x-term.i) + (unfrozen-variable-p y-term.j)) + (unless (or x-bind.i y-bind.j) + (unless (or (nosol3x j+1) (nosol3y (+ i 1))) + (unify-bag3* i j+1 subst))))) + (t + (unless (or (nosol3x j+1) (nosol3y (+ i 1))) + (unify-bag3* i j+1 subst)))))) + (t + (unify-bag3* i j+1 subst))))) + + (bind-xterm (i subst) + (prog-> + (x-term i -> x-term.i) + (x-bind i -> x-bind.i) + (+ i 1 -> i+1) + (cond + ((eql i+1 nxcoefs) ;unify x-term and x-bind, then do (bind-yterm 0) + (cond + ((null x-bind.i) + (unify x-term.i identity subst ->* subst) + (bind-yterm 0 subst)) + ((null (cdr x-bind.i)) + (cond + ((eq x-term.i (car x-bind.i)) + (bind-yterm 0 subst)) + (t + (unify x-term.i (car x-bind.i) subst ->* subst) + (bind-yterm 0 subst)))) + (t + (unify x-term.i (make-compound* fn x-bind.i) subst ->* subst) + (bind-yterm 0 subst)))) + (t ;unify x-term and x-bind, then do (bind-xterm i+1) + (cond + ((null x-bind.i) + (unify x-term.i identity subst ->* subst) + (bind-xterm i+1 subst)) + ((null (cdr x-bind.i)) + (cond + ((eq x-term.i (car x-bind.i)) + (bind-xterm i+1 subst)) + (t + (unify x-term.i (car x-bind.i) subst ->* subst) + (bind-xterm i+1 subst)))) + (t + (unify x-term.i (make-compound* fn x-bind.i) subst ->* subst) + (bind-xterm i+1 subst))))))) + + (bind-yterm (j subst) + (prog-> + (y-term j -> y-term.j) + (y-bind j -> y-bind.j) + (+ j 1 -> j+1) + (cond + ((eql j+1 nycoefs) ;unify y-term and y-bind, then do (funcall function) + (cond + ((null y-bind.j) + (unify cc y-term.j identity subst)) + ((null (cdr y-bind.j)) + (cond + ((eq y-term.j (car y-bind.j)) + (funcall cc subst)) + (t + (unify cc y-term.j (car y-bind.j) subst)))) + (t + (unify cc y-term.j (make-compound* fn y-bind.j) subst)))) + (t ;unify y-term and y-bind, then do (bind-yterm j+1) + (cond + ((null y-bind.j) + (unify y-term.j identity subst ->* subst) + (bind-yterm j+1 subst)) + ((null (cdr y-bind.j)) + (cond + ((eq y-term.j (car y-bind.j)) + (bind-yterm j+1 subst)) + (t + (unify y-term.j (car y-bind.j) subst ->* subst) + (bind-yterm j+1 subst)))) + (t + (unify y-term.j (make-compound* fn y-bind.j) subst ->* subst) + (bind-yterm j+1 subst))))))) + + (print-bindings (term bind ncoefs) + (dotimes (i ncoefs) + (format t "~% ~S & ~S" (svref term i) (make-a1-compound* fn identity (svref bind i)))))) + + (unify-bag2* complex-solutions subst))) + +(defun unify-identity (cc terms-and-counts subst identity) + (let ((x (first terms-and-counts)) + (y (rest terms-and-counts))) + (cond + ((eql 0 (tc-count x)) + (cond + ((null y) + (funcall cc subst)) + (t + (unify-identity cc y subst identity)))) + (t + (cond + ((null y) + (unify cc (tc-term x) identity subst)) + (t + (prog-> + (unify (tc-term x) identity subst ->* subst) + (unify-identity cc y subst identity)))))))) + +;;; unify-bag.lisp EOF diff --git a/src/unify-vector.lisp b/src/unify-vector.lisp new file mode 100644 index 0000000..eab1dd0 --- /dev/null +++ b/src/unify-vector.lisp @@ -0,0 +1,135 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: unify-vector.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; unify-vector implements incomplete associative unification +;;; complete associative unification is infinitary + +(defun first-and-rest-of-vector (terms subst fn identity) + (cond + ((null terms) + (values none nil)) + (t + (let ((term (first terms))) + (dereference + term subst + :if-compound (when (eq fn (head term)) + (return-from first-and-rest-of-vector + (first-and-rest-of-vector (append (args term) (rest terms)) subst fn identity))) + :if-constant (when (eql identity term) + (return-from first-and-rest-of-vector + (first-and-rest-of-vector (rest terms) subst fn identity)))) + (values term (rest terms)))))) + +(defun unify-identity-with-vector (cc terms subst fn identity) + (let ((vars nil) term) + (loop + (setf (values term terms) (first-and-rest-of-vector terms subst fn identity)) + (cond + ((eq none term) + (dolist (var vars) + (setf subst (bind-variable-to-term var identity subst))) + (funcall cc subst) + (return)) + ((and (unfrozen-variable-p term) + (constant-sort-p identity (variable-sort term))) + (pushnew term vars)) + (t + (return)))))) + +(defun unify-variable-with-vector (cc var arg args subst fn identity max) + ;; case where var matches arg plus one or more terms from args + (when (and (implies max (<= 2 max)) + (subsort? (function-sort fn) (variable-sort var))) + (let ((l nil) + (count 0)) + (loop + (cond + ((or (eq none arg) + (not (implies max (>= max count))) + (variable-occurs-p var arg subst)) + (return)) + (t + (setf l (append l (list arg))) + (when (<= 2 (incf count)) + (funcall cc (bind-variable-to-term var (make-compound* fn l) subst) args)) + (setf (values arg args) (first-and-rest-of-vector args subst fn identity)))))))) + +(defun unify-variable-with-vector-max (args args2 subst fn identity) + (and (frozen-p args subst) + (- (+ 1 (argument-count-a1 fn args subst identity)) + (argument-count-a1 fn args2 subst identity t)))) + +(defun associative-unify (cc x y subst) + (unify-vector cc (args x) (args y) subst (head x))) + +(defun unify-vector (cc args1 args2 subst fn &optional (identity (function-identity2 fn))) + ;; terminating, incomplete associative unification--no variable splitting + (prog-> + (first-and-rest-of-vector args1 subst fn identity -> firstargs1 restargs1) + (first-and-rest-of-vector args2 subst fn identity -> firstargs2 restargs2) + (cond + ((eql firstargs1 firstargs2) + (if (eq none firstargs1) + (funcall cc subst) + (unify-vector cc restargs1 restargs2 subst fn identity))) + ((eq none firstargs1) + (unless (eq none identity) + (unify-identity-with-vector cc args2 subst fn identity))) + ((eq none firstargs2) + (unless (eq none identity) + (unify-identity-with-vector cc args1 subst fn identity))) + ((and (null restargs1) (null restargs2)) + (unify cc firstargs1 firstargs2 subst)) + (t + (when (unfrozen-variable-p firstargs1) + (unless (eq none identity) + (when (constant-sort-p identity (variable-sort firstargs1)) + (unify-vector cc restargs1 args2 (bind-variable-to-term firstargs1 identity subst) fn identity))) + (when restargs2 + (unify-variable-with-vector + firstargs1 firstargs2 restargs2 subst fn identity + (unify-variable-with-vector-max restargs2 restargs1 subst fn identity) + ->* subst restargs2) + (unify-vector cc restargs1 restargs2 subst fn identity))) + (when (unfrozen-variable-p firstargs2) + (unless (eq none identity) + (when (constant-sort-p identity (variable-sort firstargs2)) + (unify-vector cc args1 restargs2 (bind-variable-to-term firstargs2 identity subst) fn identity))) + (when restargs1 + (unify-variable-with-vector + firstargs2 firstargs1 restargs1 subst fn identity + (unify-variable-with-vector-max restargs1 restargs2 subst fn identity) + ->* subst restargs1) + (unify-vector cc restargs1 restargs2 subst fn identity))) + (unless (and (or (null restargs1) (null restargs2)) (eq none identity)) + (if (and (compound-appl-p firstargs1) + (compound-appl-p firstargs2) + (eq (heada firstargs1) (heada firstargs2)) + (or (special-unify-p firstargs1 subst) + (special-unify-p firstargs2 subst))) + (prog-> + (unify-vector restargs1 restargs2 subst fn ->* subst) + (unify cc firstargs1 firstargs2 subst)) + (prog-> + (unify firstargs1 firstargs2 subst ->* subst) + (unify-vector cc restargs1 restargs2 subst fn identity)))))))) + +;;; unify-vector.lisp EOF diff --git a/src/unify.lisp b/src/unify.lisp new file mode 100644 index 0000000..50e3d27 --- /dev/null +++ b/src/unify.lisp @@ -0,0 +1,234 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: unify.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(declaim (special *subsuming*)) + +(defvar *unify-special* t) + +(defstruct special-unification-problem + algorithms + term1 + term2) + +(defun unify (cc term1 term2 &optional subst) + (macrolet + ((unify-variable*constant (u v) + `(if (and (not (variable-frozen-p ,u)) + (constant-sort-p ,v (variable-sort ,u))) + (setf subst (bind-variable-to-term ,u ,v subst)) + (return-from unify))) + (unify-variable*compound (u v) + `(if (and (not (variable-frozen-p ,u)) + (if (embedding-variable-p ,u) + (not (embedding-variable-occurs-p (args ,v) subst)) + (not (variable-occurs-p ,u (args ,v) subst))) + (let ((s (variable-sort ,u))) + (or (top-sort? s) + (subsort? (compound-sort ,v subst) s)))) + (setf subst (bind-variable-to-term ,u ,v subst)) + (return-from unify)))) + (prog ((args1 nil) (args2 nil) (moreterms1 nil) (moreterms2 nil) oterm1 oterm2 + (special-unification-problems nil) algrthm temp1 temp2 + (tracing (trace-unify?))) + (when tracing + (let ((cc1 cc)) + (setf cc (lambda (subst) + (format t "~2%RESULT = ~A" subst) + (funcall cc1 subst))))) + loop + (when tracing + (format t "~2%TERM1 = ~A" term1) + (format t "; ARGS1 = ~A" args1) + (format t "; MORETERMS1 = ~A" moreterms1) + (format t "~1%TERM2 = ~A" term2) + (format t "; ARGS2 = ~A" args2) + (format t "; MORETERMS2 = ~A" moreterms2) + (format t "~1%SPECIAL = ~A" + (mapcar (lambda (x) + (make-compound + *=* + (special-unification-problem-term1 x) + (special-unification-problem-term2 x))) + special-unification-problems)) + (format t "~1%SUBST = ~A" subst)) + (cond + ((eql term1 term2) + ) + (t + (dereference2 + term1 term2 subst + :if-variable*variable (cond + ((eq term1 term2) + ) + ((and (embedding-variable-p term1) (embedding-variable-p term2)) + (return-from unify)) + ((variable-frozen-p term1) + (if (and (not (variable-frozen-p term2)) + (subsort? (variable-sort term1) (variable-sort term2))) + (setf subst (bind-variable-to-term term2 term1 subst)) + (return-from unify))) + ((variable-frozen-p term2) + (if (subsort? (variable-sort term2) (variable-sort term1)) + (setf subst (bind-variable-to-term term1 term2 subst)) + (return-from unify))) + (t + (when (prefer-to-bind-p term2 term1) + (psetq term1 term2 term2 term1)) + (let ((sterm1 (variable-sort term1)) + (sterm2 (variable-sort term2))) + (cond + ((subsort? sterm2 sterm1) + (setf subst (bind-variable-to-term term1 term2 subst))) + ((subsort? sterm1 sterm2) + (setf subst (bind-variable-to-term term2 term1 subst))) + (t + (let ((sz (sort-intersection sterm1 sterm2))) + (if (null sz) + (return-from unify) + (let ((z (make-variable sz))) + (setf subst (bind-variable-to-term term2 z (bind-variable-to-term term1 z subst))))))))))) + :if-compound*compound (unless (eq term1 term2) + (cond + ((neq (setf temp1 (head term1)) (head term2)) + (return-from unify)) + ((eq *cons* temp1) + (unless (eq (setf temp1 (cdr term1)) (setf temp2 (cdr term2))) + (push temp1 moreterms1) + (push temp2 moreterms2)) + (setf term1 (car term1) term2 (car term2)) + (go loop)) + (t + (setf oterm1 term1 oterm2 term2) + (setf term1 (argsa term1) term2 (argsa term2) algrthm (function-unify-code temp1)) + (cond + ((not algrthm) + (cond + ((or args1 args2) + (push term1 moreterms1) + (push term2 moreterms2)) + (t + (setf args1 term1) + (setf args2 term2)))) + ((or (null *unify-special*) ;might-unify-p ignores some special-unification problems + (and (consp *unify-special*) + (not (subsetp algrthm *unify-special*)))) + ) + ((or args1 args2 moreterms1 special-unification-problems) + (push (make-special-unification-problem :algorithms algrthm :term1 oterm1 :term2 oterm2) + special-unification-problems)) + (t + (dolist (fun algrthm) + (funcall fun cc oterm1 oterm2 subst)) + (return-from unify)))))) + :if-constant*constant (unless (eql term1 term2) + (return-from unify)) + :if-variable*compound (unify-variable*compound term1 term2) + :if-compound*variable (unify-variable*compound term2 term1) + :if-variable*constant (unify-variable*constant term1 term2) + :if-constant*variable (unify-variable*constant term2 term1) + :if-compound*constant (return-from unify) + :if-constant*compound (return-from unify)))) + ;; term1 and term2 have been unified + (cond + (args1 + (cond + (args2 + (setf term1 (pop args1)) + (setf term2 (pop args2)) + (go loop)) + (t + (return-from unify)))) + (args2 + (return-from unify)) + (moreterms1 + (setf term1 (pop moreterms1)) + (setf term2 (pop moreterms2)) + (go loop)) + (special-unification-problems + (unify-special cc special-unification-problems subst)) + (t + (funcall cc subst)))))) + +(defun unify-p (x y &optional subst) + (prog-> + (unify x y subst ->* subst) + (declare (ignore subst)) + (return-from unify-p t)) + nil) + +(defun might-unify-p (x y &optional subst) + ;; returns nil if x and y are definitely not unifiable + ;; used by unify-bag to identify nonunifiable arguments + (let ((*unify-special* '(unify-commute))) + (unify-p x y subst))) + +(defun unifiers (x y &optional subst) + (let ((unifiers nil) unifiers-last) + (prog-> + (unify x y subst ->* subst) + (collect subst unifiers)) + unifiers)) + +(defun unify-special (cc special-unification-problems subst) + (prog-> + (first special-unification-problems -> x) + (rest special-unification-problems -> l) + (cond + ((null l) + (dolist (special-unification-problem-algorithms x) ->* fun) + (funcall fun (special-unification-problem-term1 x) (special-unification-problem-term2 x) subst ->* subst) + (funcall cc subst)) + (t + (dolist (special-unification-problem-algorithms x) ->* fun) + (funcall fun (special-unification-problem-term1 x) (special-unification-problem-term2 x) subst ->* subst) + (unify-special cc l subst))))) + +(defun commutative-unify (cc x y subst) + (let* ((terms1 (args x)) + (terms2 (args y)) + (x1 (first terms1)) (l1 (rest terms1)) (y1 (first l1)) (z1 (rest l1)) + (x2 (first terms2)) (l2 (rest terms2)) (y2 (first l2)) (z2 (rest l2))) + ;; terms1 = (x1 . l1) = (x1 y1 . z1) + ;; terms2 = (x2 . l2) = (x2 y2 . z2) + (cond + ((equal-p x1 x2 subst) + (unify cc l1 l2 subst)) + ((equal-p x1 y2 subst) + (unify cc l1 (cons x2 z2) subst)) + ((equal-p y1 x2 subst) + (unify cc (cons x1 z1) l2 subst)) + ((equal-p y1 y2 subst) + (unify cc (cons x1 z1) (cons x2 z2) subst)) + (t + (unify cc terms1 terms2 subst) + (unless (or (equal-p x1 y1 subst) + (equal-p x2 y2 subst)) + (unify cc terms1 (list* y2 x2 z2) subst)))))) + +(defun dont-unify (cc x y subst) + ;; can use this to prevent resolution of list-to-atom formulas, for example + (cond + (*subsuming* + (unify cc (args x) (args y) subst)) + ((equal-p x y subst) + (funcall cc subst)))) + +;;; unify.lisp EOF diff --git a/src/useful.lisp b/src/useful.lisp new file mode 100644 index 0000000..4bfb77f --- /dev/null +++ b/src/useful.lisp @@ -0,0 +1,167 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: useful.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2010. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +#+lucid +(defmacro lambda (&rest args) + `(function (lambda ,@args))) + +(defmacro setq-once (var form) + ;; return value of var if non-nil + ;; otherwise set var to value of form and return it + `(or ,var (setf ,var ,form) (error "setq-once value is nil."))) + +(definline assoc/eq (item alist) + #+lucid (assoc item alist) ;depending on the implementation, + #-lucid (assoc item alist :test #'eq) ;specifying EQ can make assoc faster + ) + +#+lucid +(defmacro declaim (&rest declaration-specifiers) + (list* 'eval-when + '(compile load eval) + (mapcar (lambda (x) `(proclaim ',x)) declaration-specifiers))) + +#+lucid +(defmacro constantly (object) + (function (lambda (&rest args) + (declare (ignore args)) + object))) + +(defun list-p (x) + ;; if x is a null terminated list, return its length + ;; otherwise return nil + (let ((n 0)) + (declare (type integer n)) + (loop + (cond + ((null x) + (return n)) + ((atom x) + (return nil)) + (t + (incf n) + (setf x (rest x))))))) + +(defvar *outputting-comment* nil) + +(definline comment* (output-stream) + (princ "; " output-stream) + (setf *outputting-comment* t) ;not stream specific bug + nil) + +(definline nocomment* (output-stream) + (declare (ignore output-stream)) + (setf *outputting-comment* nil)) + +(defun comment (&optional (output-stream *standard-output*)) + (unless *outputting-comment* + (comment* output-stream))) + +(defun nocomment (&optional (output-stream *standard-output*)) + (declare (ignorable output-stream)) + (nocomment* output-stream)) + +(defun terpri (&optional (output-stream *standard-output*)) + (cl:terpri output-stream) + (nocomment* output-stream)) + +(defun terpri-comment (&optional (output-stream *standard-output*)) + (cl:terpri output-stream) + (comment* output-stream)) + +(defvar *terpri-indent* 0) +(declaim (type fixnum *terpri-indent*)) + +(defun terpri-comment-indent (&optional (output-stream *standard-output*)) + (cl:terpri output-stream) + (comment* output-stream) + (dotimes (dummy *terpri-indent*) + (declare (ignorable dummy)) + (princ " " output-stream))) + +(defun terpri-indent (&optional (output-stream *standard-output*)) + (cl:terpri output-stream) + (nocomment* output-stream) + (dotimes (dummy *terpri-indent*) + (declare (ignorable dummy)) + (princ " " output-stream))) + +(defun unimplemented (&optional (datum "Unimplemented functionality.") &rest args) + (apply #'error datum args)) + +(defvar *hash-dollar-package* nil) +(defvar *hash-dollar-readtable* nil) + +(defun hash-dollar-reader (stream subchar arg) + ;; reads exp in #$exp into package (or *hash-dollar-package* *package*) with case preserved + (declare (ignore subchar arg)) + (let ((*readtable* *hash-dollar-readtable*) + (*package* (or *hash-dollar-package* *package*))) + (read stream t nil t))) + +(defun initialize-hash-dollar-reader () + (unless *hash-dollar-readtable* + (setf *hash-dollar-readtable* (copy-readtable nil)) + (setf (readtable-case *hash-dollar-readtable*) :preserve) + (set-dispatch-macro-character #\# #\$ 'hash-dollar-reader *hash-dollar-readtable*) + (set-dispatch-macro-character #\# #\$ 'hash-dollar-reader) + t)) + +(initialize-hash-dollar-reader) + +(defstruct (hash-dollar + (:constructor make-hash-dollar (symbol)) + (:print-function print-hash-dollar-symbol3) + (:copier nil)) + (symbol nil :read-only t)) + +(defun print-hash-dollar-symbol3 (x stream depth) + (declare (ignore depth)) + (let* ((symbol (hash-dollar-symbol x)) + (*readtable* *hash-dollar-readtable*) + (*package* (or (symbol-package symbol) *package*))) + (princ "#$" stream) + (prin1 symbol stream))) + +(defun hash-dollar-symbolize (x) + (cond + ((consp x) + (cons (hash-dollar-symbolize (car x)) (hash-dollar-symbolize (cdr x)))) + ((and (symbolp x) (not (null x)) #+ignore (not (keywordp x))) + (make-hash-dollar x)) + (t + x))) + +(defun hash-dollar-prin1 (object &optional (output-stream *standard-output*)) + (prin1 (hash-dollar-symbolize object) output-stream) + object) + +(defun hash-dollar-print (object &optional (output-stream *standard-output*)) + (prog2 + (terpri output-stream) + (hash-dollar-prin1 object output-stream) + (princ " " output-stream))) + +;;; in MCL, (hash-dollar-print '|a"b|) erroneously prints #$a"b instead of #$|a"b| +;;; it appears that readtable-case = :preserve suppresses all escape character printing, +;;; not just those for case + +;;; useful.lisp EOF diff --git a/src/variables.lisp b/src/variables.lisp new file mode 100644 index 0000000..0f7794c --- /dev/null +++ b/src/variables.lisp @@ -0,0 +1,77 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: variables.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2012. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defconstant $number-of-variable-blocks 1000) +(defconstant $number-of-variables-per-block 6000) +(defconstant $number-of-variables-in-blocks (* $number-of-variable-blocks $number-of-variables-per-block)) + +(defvar *variables*) ;tables to translate (sort number) pairs to variables +(defvar *next-variable-number* 0) ;next number to use for new unique variable +(declaim (type integer *next-variable-number*)) + +(defstruct (variable + (:constructor make-variable0 (sort number)) + (:copier nil) + (:print-function print-variable)) + number + sort) + +(defun initialize-variables () + (setf *variables* (list (make-sparse-vector) (make-hash-table :test #'equal))) + (setf *next-variable-number* $number-of-variables-in-blocks) + nil) + +(defun make-variable (&optional (sort (top-sort)) number) + ;; if number is specified, return canonical variable for that sort and number + ;; if number is not specified, create a new unique variable with that sort + ;; + ;; variable identity must be testable by EQ + ;; this variable representation must also be understood by dereference + ;; + ;; don't create last variable in a block; when incrementing variable numbers, + ;; the following variable would be in the next block creating confusion + (cond + (number + (let ((vars (if (top-sort? sort) + (first *variables*) + (let ((v (second *variables*))) + (or (gethash sort v) (setf (gethash sort v) (make-sparse-vector))))))) + (or (sparef vars number) + (progn + (cl:assert (<= 0 number)) + (cl:assert (< number $number-of-variables-in-blocks)) + (cl:assert (/= 0 (mod (+ number 1) $number-of-variables-per-block))) + (setf (sparef vars number) (make-variable0 sort number)))))) + (t + (setf *next-variable-number* (+ (setf number *next-variable-number*) 1)) + (make-variable0 sort number)))) + + +(defun variable-block (n) + (declare (fixnum n)) + (cl:assert (< 0 n $number-of-variable-blocks)) + (* $number-of-variables-per-block n)) + +(defun variable-block-0-p (varnum) + (declare (fixnum varnum)) + (> $number-of-variables-per-block varnum)) + +;;; variables.lisp EOF diff --git a/src/variant.lisp b/src/variant.lisp new file mode 100644 index 0000000..8dab1b8 --- /dev/null +++ b/src/variant.lisp @@ -0,0 +1,148 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: variant.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defvar *extended-variant* nil) + +(defun variant (cc x y &optional subst matches) + (macrolet + ((variant1 (x y) + `(let ((v (assoc ,x matches))) + (cond + ((null v) + (when (null (rassoc ,y matches)) + (setf matches (acons ,x ,y matches)))) + ((eq (cdr v) ,y) + t))))) + (dereference2 + x y subst + :if-constant*constant (cond + (*extended-variant* + (when (and (same-sort? (constant-sort x) (constant-sort y)) + (variant1 x y)) + (funcall cc matches))) + ((eql x y) + (funcall cc matches))) + :if-compound*compound (let ((xhead (head x)) (yhead (head y))) + (cond + ((and *extended-variant* + (not (function-logical-symbol-p xhead)) + (not (function-logical-symbol-p yhead)) + (not (eq *cons* xhead)) + (not (eq *cons* yhead)) + (not (equality-relation-symbol-p xhead)) + (not (equality-relation-symbol-p yhead))) + (when (variant1 xhead yhead) + (variantl cc (argsa x) (argsa y) subst matches))) + ((neq xhead yhead) + ) + ((eq *cons* xhead) + (prog-> + (variant (car x) (car y) subst matches ->* matches) + (variant cc (cdr x) (cdr y) subst matches))) + (t + (let ((funs (function-variant-code xhead))) + (if funs + (dolist (fun funs) + (funcall fun cc x y subst matches)) + (variantl cc (argsa x) (argsa y) subst matches)))))) + :if-variable*variable (when (and (same-sort? (variable-sort x) (variable-sort y)) + (variant1 x y)) + (funcall cc matches))))) + +(defun variantl (cc x y subst matches) + (cond + ((null x) + (when (null y) + (funcall cc matches))) + ((rest x) + (when (rest y) + (prog-> + (variantl (rest x) (rest y) subst matches ->* matches) + (variant cc (first x) (first y) subst matches)))) + ((null (rest y)) + (variant cc (first x) (first y) subst matches)))) + +(defun variant-p (x y &optional subst) + (prog-> + (variant x y subst ->* matches) + (return-from variant-p (or matches t))) + nil) + +(defun variant-bag (cc x y subst matches) + (variant-bag0 cc (args x) (args y) subst matches (head x))) + +(defun variant-bag0 (cc terms1 terms2 subst matches fn) + (let ((counts1 (count-arguments fn terms1 subst)) + (counts2 (count-arguments fn terms2 subst))) + (cond + ((null counts1) + (when (null counts2) + (funcall cc subst))) + ((null counts2) + ) + ((null (cdr counts1)) + (when (null (cdr counts2)) + (variant cc (tc-term (car counts1)) (tc-term (car counts2)) subst matches))) + ((null (cdr counts2)) + ) + ((and (length= (cddr counts1) (cddr counts2)) + (submultisetp (let (w) + (dolist (tc counts1) + (push (tc-count tc) w)) + w) + (let (w) + (dolist (tc counts2) + (push (tc-count tc) w)) + w))) + (variant-bag* cc counts1 counts2 subst matches))))) + +(defun variant-bag* (cc counts1 counts2 subst matches) + (let ((count1 (car counts1))) + (dolist (count2 counts2) + (when (eql (tc-count count1) (tc-count count2)) + (cond + ((null (cdr counts1)) + (variant cc (tc-term count1) (tc-term count2) subst matches)) + (t + (prog-> + (variant (tc-term count1) (tc-term count2) subst matches ->* matches) + (variant-bag* cc (cdr counts1) (remove count2 counts2) subst matches)))))))) + +(defun variant-commute (cc x y subst matches) + ;; It is assumed that commutative functions that are not assocative + ;; have at least two arguments only the first two of which commute. + (let ((terms1 (args x)) + (terms2 (args y))) + (variantl cc terms1 terms2 subst matches) + (variantl cc terms1 (list* (second terms2) (first terms2) (cddr terms2)) subst matches))) + +(defun variant-vector (cc x y subst matches) + (let ((fn (head x)) + (terms1 (args x)) + (terms2 (args y))) + (and (or *extended-variant* (similar-argument-list-ac1-p fn terms1 terms2 subst)) + (variantl cc + (argument-list-a1 fn terms1 subst) + (argument-list-a1 fn terms2 subst) + subst + matches)))) + +;;; variant.lisp EOF diff --git a/src/weight.lisp b/src/weight.lisp new file mode 100644 index 0000000..cdb117a --- /dev/null +++ b/src/weight.lisp @@ -0,0 +1,197 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: weight.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +(defun depth (x &optional subst head-if-associative) + (dereference + x subst + :if-constant 0 + :if-variable 0 + :if-compound-cons (+ 1 (max (depth (carc x) subst) (depth (cdrc x) subst))) + :if-compound-appl (let ((head (heada x))) + (cond + ((eq head head-if-associative) + (loop for x1 in (argsa x) maximize (depth x1 subst head))) + ((function-associative head) + (+ 1 (loop for x1 in (argsa x) maximize (depth x1 subst head)))) + (t + (+ 1 (loop for x1 in (argsa x) maximize (depth x1 subst)))))))) + +(defun mindepth (x &optional subst head-if-associative) + (dereference + x subst + :if-constant 0 + :if-variable 0 + :if-compound-cons (+ 1 (min (mindepth (carc x) subst) (mindepth (cdrc x) subst))) + :if-compound-appl (let ((head (heada x))) + (cond + ((eq head head-if-associative) + (loop for x1 in (argsa x) minimize (mindepth x1 subst head))) + ((function-associative head) + (+ 1 (loop for x1 in (argsa x) minimize (mindepth x1 subst head)))) + (t + (+ 1 (loop for x1 in (argsa x) minimize (mindepth x1 subst)))))))) + +(definline constantly-one (x) + (declare (ignore x)) + 1) + +(definline constantly-nil (x) + (declare (ignore x)) + nil) + +(definline variable-weight1 (variable) + (let ((w (variable-weight?))) + (if (numberp w) w (funcall w variable)))) + +(defmacro weight-macro (weight-fn constant-weight-fn variable-weight-fn function-weight-fn function-weight-code-fn) + `(dereference + x subst + :if-constant (,constant-weight-fn x) + :if-variable (,variable-weight-fn x) + :if-compound-cons (+ (,weight-fn (carc x) subst) (,weight-fn (cdrc x) subst) (,function-weight-fn *cons*)) + :if-compound-appl (let ((head (heada x))) + (dolist (fun (,function-weight-code-fn head) + (cond + ((function-associative head) ;do something different for zero or one args? + (let ((args (argsa x))) + (+ (loop for x1 in args sum (,weight-fn x1 subst)) + (* (,function-weight-fn head) (+ 1 (length (rrest args))))))) + (t + (+ (loop for x1 in (argsa x) sum (,weight-fn x1 subst)) + (,function-weight-fn head))))) + (let ((v (funcall fun x subst))) + (unless (or (null v) (eq none v)) + (return v))))))) + +(defun weight (x &optional subst) + (weight-macro + weight + constant-weight + variable-weight1 + function-weight + function-weight-code)) + +(defun size (x &optional subst) + (weight-macro + size + constantly-one + constantly-one + constantly-one + constantly-nil)) + +(defun weigh-first-two-arguments (x &optional subst) + (dereference + x subst + :if-compound-appl (let ((args (argsa x))) + (and (rest args) + (+ (weight (first args) subst) + (weight (second args) subst) + (function-weight (heada x))))))) + +(defun maximum-argument-weight (args subst head-if-associative) + (loop for arg in args + maximize (if (and head-if-associative + (dereference + arg subst + :if-compound-appl (eq head-if-associative (heada arg)))) + (maximum-argument-weight (argsa arg) subst head-if-associative) + (weight arg subst)))) + +(defun weightm (x &optional subst) + (dereference + x subst + :if-constant (weight x) + :if-variable (weight x) + :if-compound-cons (+ (max (weight (carc x) subst) (weight (cdrc x) subst)) (function-weight *cons*)) + :if-compound-appl (let ((head (heada x))) + (+ (maximum-argument-weight (argsa x) subst (and (function-associative head) head)) + (function-weight head))))) + +(defstruct (symbol-count + (:type list) + (:constructor make-symbol-count ()) + (:copier nil)) + (total 0 :type fixnum) + (alist nil)) + +(defun symbol-count (x &optional subst scount) + ;; computes the total number of symbols in x and + ;; an alist for counts of constants and functions in x + ;; count 2 f's for f(x,y,z)=f(f(x,y),z)=f(x,f(y,z)) + (macrolet + ((symbol-count1 (symbol count) + `(let* ((count ,count) + (alist (symbol-count-alist (or scount (setf scount (make-symbol-count))))) + (v (assoc ,symbol alist))) + (if v + (incf (cdr v) count) + (setf (symbol-count-alist scount) (acons ,symbol count alist))) + (incf (symbol-count-total scount) count)))) + (dereference + x subst + :if-constant (symbol-count1 x 1) + :if-compound-cons (progn + (symbol-count1 *cons* 1) + (symbol-count (carc x) subst scount) + (symbol-count (cdrc x) subst scount)) + :if-compound-appl (let ((head (heada x)) + (args (argsa x))) + (symbol-count1 head (if (function-associative head) + (+ 1 (length (rrest args))) + 1)) + (dolist (x1 args) + (symbol-count x1 subst scount))) + :if-variable (incf (symbol-count-total scount))) + scount)) + +(definline symbol-count-not-greaterp1 (scount1 scount2) + (let ((alist2 (symbol-count-alist scount2))) + (dolist (v1 (symbol-count-alist scount1) t) + (let ((v2 (assoc (carc v1) alist2))) + (when (or (null v2) (> (the fixnum (cdrc v1)) (the fixnum (cdrc v2)))) + (return nil)))))) + +(defun symbol-count-not-greaterp (scount1 scount2) + (and (not (> (symbol-count-total scount1) (symbol-count-total scount2))) + (symbol-count-not-greaterp1 scount1 scount2))) + +(defun wff-symbol-counts (wff &optional subst) + (let ((poscount nil) + (negcount nil)) + (prog-> + (map-atoms-in-wff wff ->* atom polarity) + (unless (eq :neg polarity) + (setf poscount (symbol-count atom subst poscount))) + (unless (eq :pos polarity) + (setf negcount (symbol-count atom subst negcount)))) + (list poscount negcount))) + +(defun wff-symbol-counts-not-greaterp (scounts1 scounts2) + (let ((poscount1 (first scounts1)) + (negcount1 (second scounts1)) + poscount2 + negcount2) + (and (implies poscount1 (and (setf poscount2 (first scounts2)) (not (> (symbol-count-total poscount1) (symbol-count-total poscount2))))) + (implies negcount1 (and (setf negcount2 (second scounts2)) (not (> (symbol-count-total negcount1) (symbol-count-total negcount2))))) + (implies poscount1 (symbol-count-not-greaterp1 poscount1 poscount2)) + (implies negcount1 (symbol-count-not-greaterp1 negcount1 negcount2))))) + +;;; weight.lisp EOF diff --git a/src/wffs.lisp b/src/wffs.lisp new file mode 100644 index 0000000..2468763 --- /dev/null +++ b/src/wffs.lisp @@ -0,0 +1,680 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*- +;;; File: wffs.lisp +;;; The contents of this file are subject to the Mozilla Public License +;;; Version 1.1 (the "License"); you may not use this file except in +;;; compliance with the License. You may obtain a copy of the License at +;;; http://www.mozilla.org/MPL/ +;;; +;;; Software distributed under the License is distributed on an "AS IS" +;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +;;; License for the specific language governing rights and limitations +;;; under the License. +;;; +;;; The Original Code is SNARK. +;;; The Initial Developer of the Original Code is SRI International. +;;; Portions created by the Initial Developer are Copyright (C) 1981-2011. +;;; All Rights Reserved. +;;; +;;; Contributor(s): Mark E. Stickel . + +(in-package :snark) + +;;; wff = well-formed formula +;;; atom = atomic fomula + +(defun map-atoms-in-clause (cc wff0) + (labels + ((map-atoms (wff polarity) + (dereference + wff nil + :if-constant (cond + ((eq true wff) + (when (eq :pos polarity) + (not-clause-error wff0))) + ((eq false wff) + (when (eq :neg polarity) + (not-clause-error wff0))) + (t + (funcall cc wff polarity))) + :if-variable (not-clause-error wff0) + :if-compound-cons (not-clause-error wff0) + :if-compound-appl (case (function-logical-symbol-p (heada wff)) + ((nil) + (funcall cc wff polarity)) + (not + (map-atoms (arg1a wff) (if (eq :pos polarity) :neg :pos))) + (and + (if (eq :pos polarity) + (not-clause-error wff0) + (dolist (arg (argsa wff)) + (map-atoms arg :neg)))) + (or + (if (eq :neg polarity) + (not-clause-error wff0) + (dolist (arg (argsa wff)) + (map-atoms arg :pos)))) + (implies + (if (eq :neg polarity) + (not-clause-error wff0) + (let ((args (argsa wff))) + (map-atoms (first args) :neg) + (map-atoms (second args) :pos)))) + (implied-by + (if (eq :neg polarity) + (not-clause-error wff0) + (let ((args (argsa wff))) + (map-atoms (first args) :pos) + (map-atoms (second args) :neg)))))))) + (map-atoms wff0 :pos))) + +(defun map-atoms-in-wff (cc wff &optional (polarity :pos)) + (dereference + wff nil + :if-constant (unless (or (eq true wff) (eq false wff)) + (funcall cc wff polarity)) + :if-variable (not-wff-error wff) + :if-compound-cons (not-wff-error wff) + :if-compound-appl (let ((head (heada wff))) + (if (function-logical-symbol-p head) + (map-atoms-in-list-of-wffs cc (argsa wff) (function-polarity-map head) polarity) + (funcall cc wff polarity)))) + nil) + +(defun map-atoms-in-wff-and-compose-result (cc wff &optional (polarity :pos)) + (dereference + wff nil + :if-constant (if (or (eq true wff) (eq false wff)) + wff + (funcall cc wff polarity)) + :if-variable (not-wff-error wff) + :if-compound-cons (not-wff-error wff) + :if-compound-appl (prog-> + (heada wff -> head) + (cond + ((function-logical-symbol-p head) + (argsa wff -> args) + (cond + ((null args) + wff) + ((null (rest args)) + (first args -> arg) + (map-atoms-in-wff-and-compose-result cc arg (map-polarity (first (function-polarity-map head)) polarity) -> arg*) + (if (eq arg arg*) wff (fancy-make-compound* head (list arg*)))) + (t + (map-atoms-in-list-of-wffs-and-compose-result cc args (function-polarity-map head) polarity -> args*) + (if (eq args args*) wff (fancy-make-compound* head args*))))) + (t + (funcall cc wff polarity)))))) + +(defun map-terms-in-wff (cc wff &optional subst (polarity :pos)) + (prog-> + (map-atoms-in-wff wff polarity ->* atom polarity) + (map-terms-in-atom cc atom subst polarity))) + +(defun map-terms-in-wff-and-compose-result (cc wff &optional subst (polarity :pos)) + (prog-> + (map-atoms-in-wff-and-compose-result wff polarity ->* atom polarity) + (map-terms-in-atom-and-compose-result cc atom subst polarity))) + +(defun map-terms-in-atom (cc atom &optional subst (polarity :pos)) + (dereference + atom nil + :if-variable (not-wff-error atom) + :if-compound-cons (not-wff-error atom) + :if-compound-appl (map-terms-in-list-of-terms cc nil (argsa atom) subst polarity))) + +(defun map-terms-in-atom-and-compose-result (cc atom &optional subst (polarity :pos)) + (dereference + atom nil + :if-constant atom + :if-variable (not-wff-error atom) + :if-compound-cons (not-wff-error atom) + :if-compound-appl (let* ((args (argsa atom)) + (args* (map-terms-in-list-of-terms-and-compose-result cc nil args subst polarity))) + (if (eq args args*) + atom + (make-compound* (heada atom) args*))))) + +(defun map-terms-in-term (cc term &optional subst (polarity :pos)) + (dereference + term subst + :if-constant (funcall cc term polarity) + :if-variable (funcall cc term polarity) + :if-compound-cons (progn + (map-terms-in-term cc (carc term) subst polarity) + (map-terms-in-term cc (cdrc term) subst polarity) + (funcall cc term polarity)) + :if-compound-appl (let* ((head (heada term)) + (head-if-associative (and (function-associative head) head))) + (map-terms-in-list-of-terms cc head-if-associative (argsa term) subst polarity) + (funcall cc term polarity)))) + +(defun map-terms-in-term-and-compose-result (cc term &optional subst (polarity :pos)) + (dereference + term subst + :if-constant (funcall cc term polarity) + :if-variable (funcall cc term polarity) + :if-compound-cons (lcons (map-terms-in-term-and-compose-result cc (car term) subst polarity) + (map-terms-in-term-and-compose-result cc (cdr term) subst polarity) + term) + :if-compound-appl (let* ((head (heada term)) + (head-if-associative (and (function-associative head) head))) + (funcall cc + (let* ((args (argsa term)) + (args* (map-terms-in-list-of-terms-and-compose-result cc head-if-associative args subst polarity))) + (if (eq args args*) + term + (make-compound* (head term) args*))) + polarity)))) + +(defun map-terms-in-list-of-terms (cc head-if-associative terms subst polarity) + (dolist (term terms) + (dereference + term subst + :if-variable (funcall cc term polarity) + :if-constant (funcall cc term polarity) + :if-compound-cons (progn + (map-terms-in-term cc (carc term) subst polarity) + (map-terms-in-term cc (cdrc term) subst polarity) + (funcall cc term polarity)) + :if-compound-appl (let ((head (heada term))) + (map-terms-in-list-of-terms + cc (and (function-associative head) head) (argsa term) subst polarity) + (unless (and head-if-associative (eq head head-if-associative)) + (funcall cc term polarity)))))) + +(defvar map-atoms-first nil) + +(defun map-atoms-in-list-of-wffs (cc wffs polarity-map polarity) + (cond + (map-atoms-first + (let ((polarity-map polarity-map)) + (dolist (wff wffs) + (let ((polarity-fun (pop polarity-map))) + (unless (head-is-logical-symbol wff) + (map-atoms-in-wff cc wff (map-polarity polarity-fun polarity)))))) + (let ((polarity-map polarity-map)) + (dolist (wff wffs) + (let ((polarity-fun (pop polarity-map))) + (when (head-is-logical-symbol wff) + (map-atoms-in-wff cc wff (map-polarity polarity-fun polarity))))))) + (t + (let ((polarity-map polarity-map)) + (dolist (wff wffs) + (let ((polarity-fun (pop polarity-map))) + (map-atoms-in-wff cc wff (map-polarity polarity-fun polarity)))))))) + +(defun map-terms-in-list-of-terms-and-compose-result (cc head-if-associative terms subst polarity) + (cond + ((null terms) + nil) + (t + (let ((term (first terms))) + (dereference + term subst + :if-constant (lcons (funcall cc term polarity) + (map-terms-in-list-of-terms-and-compose-result + cc head-if-associative (rest terms) subst polarity) + terms) + :if-variable (lcons (funcall cc term polarity) + (map-terms-in-list-of-terms-and-compose-result + cc head-if-associative (rest terms) subst polarity) + terms) + :if-compound (cond + ((and head-if-associative (eq (head term) head-if-associative)) + (append (map-terms-in-list-of-terms-and-compose-result + cc head-if-associative (args term) subst polarity) + (map-terms-in-list-of-terms-and-compose-result + cc head-if-associative (rest terms) subst polarity))) + (t + (lcons (map-terms-in-term-and-compose-result + cc term subst polarity) + (map-terms-in-list-of-terms-and-compose-result + cc head-if-associative (rest terms) subst polarity) + terms)))))))) + +(defun map-atoms-in-list-of-wffs-and-compose-result (cc wffs polarity-map polarity) + ;; always called with at least two wffs + (let* ((x (first wffs)) + (x* (map-atoms-in-wff-and-compose-result + cc x (map-polarity (first polarity-map) polarity))) + (y (rest wffs))) + (cond + ((null (rest y)) + (let* ((z (first y)) + (z* (map-atoms-in-wff-and-compose-result + cc z (map-polarity (second polarity-map) polarity)))) + (cond + ((eq z z*) + (cond + ((eq x x*) + wffs) + (t + (cons x* y)))) + (t + (list x* z*))))) + (t + (lcons x* + (map-atoms-in-list-of-wffs-and-compose-result + cc (rest wffs) (rest polarity-map) polarity) + wffs))))) + +(defun map-atoms-in-alist-of-wffs-and-compose-result (cc alist &optional polarity) + (lcons (let ((p (first alist))) + (lcons (car p) (map-atoms-in-wff-and-compose-result cc (cdr p) polarity) p)) + (map-atoms-in-alist-of-wffs-and-compose-result cc (rest alist) polarity) + alist)) + +(defun map-terms-in-list-of-wffs-and-compose-result (cc wffs subst polarity) + (lcons (map-terms-in-wff-and-compose-result cc (first wffs) subst polarity) + (map-terms-in-list-of-wffs-and-compose-result cc (rest wffs) subst polarity) + wffs)) + +(defun map-conjuncts (cc wff) + (if (conjunction-p wff) + (mapc (lambda (wff) (map-conjuncts cc wff)) (args wff)) + (funcall cc wff)) + nil) + +(defun replace-atom-in-wff (wff atom value) + (let* ((replaced nil) + (wff* (prog-> + (map-atoms-in-wff-and-compose-result wff ->* a p) + (declare (ignore p)) + (if (equal-p atom a) ;would prefer to use eq + (progn (setf replaced t) value) + a)))) + (cl:assert replaced) + wff*)) + +(defun atoms-in-wff (wff &optional subst atoms) + (prog-> + (last atoms -> atoms-last) + (map-atoms-in-wff wff :pos ->* atom polarity) + (declare (ignore polarity)) + (unless (member-p atom atoms subst) + (collect atom atoms))) + atoms) + +(defun atoms-in-wffs (wffs &optional subst atoms) + (prog-> + (dolist wffs ->* wff) + (setf atoms (atoms-in-wff wff subst atoms))) + atoms) + +(defun atoms-in-wff2 (wff &optional subst (polarity :pos) variable-block) + (let ((atoms-and-polarities nil) atoms-and-polarities-last) + (prog-> + (map-atoms-in-wff wff polarity ->* atom polarity) + (when variable-block + (setf atom (instantiate atom variable-block))) + (assoc-p atom atoms-and-polarities subst -> v) + (cond + ((null v) + (collect (list atom polarity) atoms-and-polarities)) + ((neq polarity (second v)) + (setf (second v) :both)))) + atoms-and-polarities)) + +(defun atoms-in-clause2 (clause &optional except-atom renumber) + (let ((atoms-and-polarities nil) atoms-and-polarities-last + (except-atom-found nil) + (rsubst nil)) + (prog-> + (map-atoms-in-clause clause ->* atom polarity) + (cond + ((equal-p except-atom atom) ;would prefer to use eq + (setf except-atom-found t)) + (t + (when renumber + (setf (values atom rsubst) (renumber-new atom nil rsubst))) + (collect (list atom polarity) atoms-and-polarities)))) + (cl:assert (implies except-atom except-atom-found)) + atoms-and-polarities)) + +(defun atoms-to-clause2 (atoms-and-polarities) + ;; inverse of atoms-in-clause2 + (cond + ((null atoms-and-polarities) + false) + ((null (rest atoms-and-polarities)) + (let ((x (first atoms-and-polarities))) + (if (eq :pos (second x)) (first x) (make-compound *not* (first x))))) + (t + (make-compound* + *or* + (mapcar (lambda (x) (if (eq :pos (second x)) (first x) (make-compound *not* (first x)))) + atoms-and-polarities))))) + +(defun atoms-in-clause3 (clause &optional except-atom renumber) + (let ((negatoms nil) negatoms-last + (posatoms nil) posatoms-last + (except-atom-found nil) + (rsubst nil)) + (prog-> + (map-atoms-in-clause clause ->* atom polarity) + (cond + ((equal-p except-atom atom) ;would prefer to use eq + (setf except-atom-found t)) + (t + (when renumber + (setf (values atom rsubst) (renumber-new atom nil rsubst))) + (ecase polarity + (:neg + (collect atom negatoms)) + (:pos + (collect atom posatoms)))))) + (cl:assert (implies except-atom except-atom-found)) + (values negatoms posatoms))) + +(defun atoms-to-clause3 (negatoms posatoms) + ;; inverse of atoms-in-clause3 + (let ((literals nil) literals-last) + (dolist (atom negatoms) + (collect (make-compound *not* atom) literals)) + (dolist (atom posatoms) + (collect atom literals)) + (literals-to-clause literals))) + +(defun literals-in-clause (clause &optional except-atom renumber) + (let ((literals nil) literals-last + (except-atom-found nil) + (rsubst nil)) + (prog-> + (map-atoms-in-clause clause ->* atom polarity) + (cond + ((equal-p except-atom atom) ;would prefer to use eq + (setf except-atom-found t)) + (t + (when renumber + (setf (values atom rsubst) (renumber-new atom nil rsubst))) + (ecase polarity + (:pos + (collect atom literals)) + (:neg + (collect (make-compound *not* atom) literals)))))) + (cl:assert (implies except-atom except-atom-found)) + literals)) + +(defun literals-to-clause (literals) + ;; inverse of literals-in-clause + (cond + ((null literals) + false) + ((null (rest literals)) + (first literals)) + (t + (make-compound* *or* literals)))) + +(defun first-negative-literal-in-wff (wff) + (prog-> + (map-atoms-in-wff wff ->* atom polarity) + (when (eq :neg polarity) + (return-from first-negative-literal-in-wff atom))) + nil) + +(defun first-positive-literal-in-wff (wff) + (prog-> + (map-atoms-in-wff wff ->* atom polarity) + (when (eq :pos polarity) + (return-from first-positive-literal-in-wff atom))) + nil) + +(defun do-not-resolve (atom &optional subst) + (dereference + atom subst + :if-compound (function-do-not-resolve (head atom)) + :if-constant (constant-do-not-resolve atom))) + +(defun do-not-factor (atom &optional subst) + (dereference + atom subst + :if-compound (function-do-not-factor (head atom)))) + +(defun wff-positive-or-negative (wff) + ;; :pos if wff contains at least one atom and all atom occurrences are positive + ;; :neg if wff contains at least one atom and all atom occurrences are negative + ;; nil otherwise + (let ((result nil)) + (prog-> + (map-atoms-in-wff wff ->* atom polarity) + (unless (or (do-not-resolve atom) (eq result polarity)) + (if (and (null result) (or (eq :pos polarity) (eq :neg polarity))) + (setf result polarity) + (return-from wff-positive-or-negative nil)))) + result)) + +(defun atom-satisfies-sequential-restriction-p (atom wff &optional subst) + (dereference + wff nil + :if-constant (equal-p atom wff subst) + :if-compound (if (function-logical-symbol-p (head wff)) + (atom-satisfies-sequential-restriction-p atom (arg1 wff) subst) + (equal-p atom wff subst)))) + +(defun term-satisfies-sequential-restriction-p (term wff &optional subst) + (dereference + wff nil + :if-compound (if (function-logical-symbol-p (head wff)) + (term-satisfies-sequential-restriction-p term (arg1 wff) subst) + (occurs-p term wff subst)))) + +(defun salsify (sat wff interpretation continuation) + #+(or symbolics ti) (declare (sys:downward-funarg continuation)) + ;; SAT = T if trying to satisfy WFF, NIL if trying to falsify WFF + (cond + ((eq true wff) + (when sat + (funcall continuation interpretation))) + ((eq false wff) + (unless sat + (funcall continuation interpretation))) + (t + (let* ((head (and (compound-p wff) (head wff))) + (kind (and head (function-logical-symbol-p head)))) + (ecase kind + (not + (salsify (not sat) (arg1 wff) interpretation continuation)) + (and + (let ((args (args wff))) + (cond + ((null args) + (when sat + (funcall continuation interpretation))) + ((null (rest args)) + (salsify sat (first args) interpretation continuation)) + (sat + (let ((arg2 (if (null (cddr args)) + (second args) + (make-compound* *and* (rest args))))) + (salsify sat (first args) interpretation + (lambda (i) (salsify sat arg2 i continuation))))) + (t + (dolist (arg args) + (salsify sat arg interpretation continuation)))))) + (or + (let ((args (args wff))) + (cond + ((null args) + (unless sat + (funcall continuation interpretation))) + ((null (rest args)) + (salsify sat (first args) interpretation continuation)) + ((not sat) + (let ((arg2 (if (null (cddr args)) + (second args) + (make-compound* *or* (rest args))))) + (salsify sat (first args) interpretation + (lambda (i) (salsify sat arg2 i continuation))))) + (t + (dolist (arg args) + (salsify sat arg interpretation continuation)))))) + (implies + (let ((args (args wff))) + (cond + (sat + (salsify nil (first args) interpretation continuation) + (salsify t (second args) interpretation continuation)) + (t + (salsify t (first args) interpretation + (lambda (i) (salsify nil (second args) i continuation))))))) + (implied-by + (let ((args (args wff))) + (cond + (sat + (salsify nil (second args) interpretation continuation) + (salsify t (first args) interpretation continuation)) + (t + (salsify t (second args) interpretation + (lambda (i) (salsify nil (first args) i continuation))))))) + ((iff xor) + (let* ((args (args wff)) + (arg1 (first args)) + (arg2 (if (null (cddr args)) (second args) (make-compound* head (rest args))))) + (salsify (if (eq 'iff kind) sat (not sat)) + (make-compound *and* + (make-compound *or* (make-compound *not* arg1) arg2) + (make-compound *or* (make-compound *not* arg2) arg1)) + interpretation + continuation))) + ((if answer-if) + (let ((args (args wff))) + (salsify t (first args) interpretation (lambda (i) (salsify sat (second args) i continuation))) + (salsify nil (first args) interpretation (lambda (i) (salsify sat (third args) i continuation))))) + ((nil) ;atomic + (let ((v (assoc wff interpretation :test #'equal-p))) + (cond + ((null v) + (funcall continuation (cons (cons wff (if sat true false)) interpretation))) + ((eq (if sat true false) (cdr v)) + (funcall continuation interpretation)))))))))) + +(defun propositional-contradiction-p (wff) + (salsify t wff nil (lambda (i) + (declare (ignore i)) + (return-from propositional-contradiction-p nil))) + t) + +(defun propositional-tautology-p (wff) + (propositional-contradiction-p (negate wff))) + +(defun flatten-term (term subst) + (dereference + term subst + :if-constant term + :if-variable term + :if-compound (let* ((head (head term)) + (head-if-associative (and (function-associative head) head)) + (args (args term)) + (args* (flatten-list args subst head-if-associative))) + (if (eq args args*) ;CHECK (<= (LENGTH ARGS*) 2)?????? + term + (make-compound* head args*))))) + +(defun flatten-list (terms subst head-if-associative) + (cond + ((null terms) + nil) + (t + (let ((term (first terms))) + (cond + ((and head-if-associative (dereference term subst :if-compound (eq (head term) head-if-associative))) + (flatten-list (append (args term) (rest terms)) subst head-if-associative)) + (t + (lcons (flatten-term term subst) + (flatten-list (rest terms) subst head-if-associative) + terms))))))) + +(defun unflatten-term1 (term subst) + ;; when f is associative, (f a b c) -> (f a (f b c)); leaves (f) and (f a) alone; doesn't unflatten subterms + (dereference + term subst + :if-constant term + :if-variable term + :if-compound (let ((head (head term)) + (args (args term))) + (cond + ((and (function-associative head) (rrest args)) + (let* ((l (reverse args)) + (term* (first l))) + (dolist (x (rest l)) + (setf term* (make-compound head x term*))) + term*)) + (t + term))))) + +(defun unflatten-term (term subst) + ;; when f is associative, (f a b c) -> (f a (f b c)); leaves (f) and (f a) alone; unflattens subterms too + (dereference + term subst + :if-constant term + :if-variable term + :if-compound (labels + ((unflatten-list (terms) + (lcons (unflatten-term (first terms) subst) + (unflatten-list (rest terms)) + terms))) + (let* ((args (args term)) + (args* (unflatten-list args))) + (unflatten-term1 (if (eq args args*) term (make-compound* (head term) args*)) subst))))) + +(defun flatten-args (fn args subst) + (labels + ((fa (args) + (if (null args) + args + (let ((arg (first args))) + (cond + ((dereference arg subst :if-compound-appl (eq fn (heada arg))) + (fa (append (argsa arg) (rest args)))) + (t + (let* ((args1 (rest args)) + (args1* (fa args1))) + (if (eq args1 args1*) args (cons arg args1*))))))))) + (fa args))) + +(defun fn-chain-tail (fn x subst &optional (len 0)) + ;; for a fn chain, return tail and length + ;; (bag a b) = (bag-cons a (bag-cons b empty-bag)) -> empty-bag,2 + ;; (bag* a b) = (bag-cons a b) -> b,1 + (loop + (dereference + x subst + :if-variable (return-from fn-chain-tail (values x len)) + :if-constant (return-from fn-chain-tail (values x len)) + :if-compound (if (eq fn (head x)) + (setf x (second (args x)) len (+ 1 len)) + (return-from fn-chain-tail (values x len)))))) + +(defun fn-chain-items (fn x subst) + ;; (bag a b) = (bag-cons a (bag-cons b empty-bag)) -> (a b) + ;; (bag* a b) = (bag-cons a b) -> (a) + (let ((items nil) items-last) + (loop + (dereference + x subst + :if-variable (return) + :if-constant (return) + :if-compound (if (eq fn (head x)) + (let ((args (args x))) + (collect (first args) items) + (setf x (second args))) + (return)))) + items)) + +(defun make-fn-chain (fn items tail) + (labels + ((mfc (items) + (if (null items) tail (make-compound fn (first items) (mfc (rest items)))))) + (mfc items))) + +(defun make-compound1 (fn identity arg1 arg2) + (cond + ((eql identity arg1) + arg2) + ((eql identity arg2) + arg1) + (t + (make-compound fn arg1 arg2)))) + +;;; wffs.lisp EOF diff --git a/version b/version new file mode 100644 index 0000000..77055cd --- /dev/null +++ b/version @@ -0,0 +1 @@ +20120808r022 \ No newline at end of file