diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..a30d685 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "snark"] + path = snark + url = https://github.com/RAIRLab/snark diff --git a/Dockerfile b/Dockerfile index 324daa9..6b23ac7 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,6 +1,6 @@ FROM maven:3.6.3-jdk-11 ADD ./target/server-jar-with-dependencies.jar ./ -RUN mkdir -p ./snark-20120808r02 -COPY ./snark-20120808r02/ ./snark-20120808r02 +RUN mkdir -p ./snark +COPY ./snark/ ./snark2 EXPOSE 25333 25334 CMD java -jar server-jar-with-dependencies.jar \ No newline at end of file diff --git a/snark b/snark new file mode 160000 index 0000000..1b657ea --- /dev/null +++ b/snark @@ -0,0 +1 @@ +Subproject commit 1b657eadf4e87f3ba46e030c3e549854b2454a4e diff --git a/snark-20120808r02/INSTALL b/snark-20120808r02/INSTALL deleted file mode 100644 index aff6738..0000000 --- a/snark-20120808r02/INSTALL +++ /dev/null @@ -1,53 +0,0 @@ -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/snark-20120808r02/LICENSE b/snark-20120808r02/LICENSE deleted file mode 100644 index 7da89f9..0000000 --- a/snark-20120808r02/LICENSE +++ /dev/null @@ -1,453 +0,0 @@ - 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/snark-20120808r02/README b/snark-20120808r02/README deleted file mode 100644 index 172d903..0000000 --- a/snark-20120808r02/README +++ /dev/null @@ -1,36 +0,0 @@ -(replace "yyyymmdd" by the SNARK version date) - -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. diff --git a/snark-20120808r02/commons.lisp b/snark-20120808r02/commons.lisp deleted file mode 100644 index e69de29..0000000 diff --git a/snark-20120808r02/compile b/snark-20120808r02/compile deleted file mode 100644 index 59884f7..0000000 --- a/snark-20120808r02/compile +++ /dev/null @@ -1,4 +0,0 @@ -(load "snark-system.lisp") -(make-snark-system t) -(make-snark-system :optimize) -(quit) diff --git a/snark-20120808r02/examples/BOO002-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/BOO002-1+rm_eq_rstfp.kif deleted file mode 100644 index 558a5c4..0000000 --- a/snark-20120808r02/examples/BOO002-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,47 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/COL003-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/COL003-1+rm_eq_rstfp.kif deleted file mode 100644 index edc3293..0000000 --- a/snark-20120808r02/examples/COL003-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,53 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/COL049-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/COL049-1+rm_eq_rstfp.kif deleted file mode 100644 index f9b2587..0000000 --- a/snark-20120808r02/examples/COL049-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,52 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/GRP001-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/GRP001-1+rm_eq_rstfp.kif deleted file mode 100644 index f99f349..0000000 --- a/snark-20120808r02/examples/GRP001-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,78 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/GRP002-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/GRP002-1+rm_eq_rstfp.kif deleted file mode 100644 index 650f6e8..0000000 --- a/snark-20120808r02/examples/GRP002-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,98 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/GRP002-3+rm_eq_rstfp.kif b/snark-20120808r02/examples/GRP002-3+rm_eq_rstfp.kif deleted file mode 100644 index e1ec0f8..0000000 --- a/snark-20120808r02/examples/GRP002-3+rm_eq_rstfp.kif +++ /dev/null @@ -1,53 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/GRP014-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/GRP014-1+rm_eq_rstfp.kif deleted file mode 100644 index 8b863e8..0000000 --- a/snark-20120808r02/examples/GRP014-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,38 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/LCL024-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/LCL024-1+rm_eq_rstfp.kif deleted file mode 100644 index 5cbf043..0000000 --- a/snark-20120808r02/examples/LCL024-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,44 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/LCL038-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/LCL038-1+rm_eq_rstfp.kif deleted file mode 100644 index 39b99ef..0000000 --- a/snark-20120808r02/examples/LCL038-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,42 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/LCL109-2+rm_eq_rstfp.kif b/snark-20120808r02/examples/LCL109-2+rm_eq_rstfp.kif deleted file mode 100644 index be3990f..0000000 --- a/snark-20120808r02/examples/LCL109-2+rm_eq_rstfp.kif +++ /dev/null @@ -1,54 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/LCL111-1.tptp b/snark-20120808r02/examples/LCL111-1.tptp deleted file mode 100644 index 19ad2e8..0000000 --- a/snark-20120808r02/examples/LCL111-1.tptp +++ /dev/null @@ -1,55 +0,0 @@ -%------------------------------------------------------------------------------ -% 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/snark-20120808r02/examples/LCL114-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/LCL114-1+rm_eq_rstfp.kif deleted file mode 100644 index 0b064da..0000000 --- a/snark-20120808r02/examples/LCL114-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,53 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/PUZ031+1.kif b/snark-20120808r02/examples/PUZ031+1.kif deleted file mode 100644 index 0e451e4..0000000 --- a/snark-20120808r02/examples/PUZ031+1.kif +++ /dev/null @@ -1,155 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/RNG008-6+rm_eq_rstfp.kif b/snark-20120808r02/examples/RNG008-6+rm_eq_rstfp.kif deleted file mode 100644 index 7bf412e..0000000 --- a/snark-20120808r02/examples/RNG008-6+rm_eq_rstfp.kif +++ /dev/null @@ -1,129 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/RNG009-5+rm_eq_rstfp.kif b/snark-20120808r02/examples/RNG009-5+rm_eq_rstfp.kif deleted file mode 100644 index a15f09e..0000000 --- a/snark-20120808r02/examples/RNG009-5+rm_eq_rstfp.kif +++ /dev/null @@ -1,60 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/RNG010-5+rm_eq_rstfp.kif b/snark-20120808r02/examples/RNG010-5+rm_eq_rstfp.kif deleted file mode 100644 index a2f2f71..0000000 --- a/snark-20120808r02/examples/RNG010-5+rm_eq_rstfp.kif +++ /dev/null @@ -1,117 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/RNG011-5+rm_eq_rstfp.kif b/snark-20120808r02/examples/RNG011-5+rm_eq_rstfp.kif deleted file mode 100644 index 2f0e049..0000000 --- a/snark-20120808r02/examples/RNG011-5+rm_eq_rstfp.kif +++ /dev/null @@ -1,97 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/ROB005-1+rm_eq_rstfp.kif b/snark-20120808r02/examples/ROB005-1+rm_eq_rstfp.kif deleted file mode 100644 index 2b70356..0000000 --- a/snark-20120808r02/examples/ROB005-1+rm_eq_rstfp.kif +++ /dev/null @@ -1,53 +0,0 @@ -;-------------------------------------------------------------------------- -; 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/snark-20120808r02/examples/coder-examples.abcl b/snark-20120808r02/examples/coder-examples.abcl deleted file mode 100644 index 11cfa6c..0000000 Binary files a/snark-20120808r02/examples/coder-examples.abcl and /dev/null differ diff --git a/snark-20120808r02/examples/coder-examples.lisp b/snark-20120808r02/examples/coder-examples.lisp deleted file mode 100644 index 6646063..0000000 --- a/snark-20120808r02/examples/coder-examples.lisp +++ /dev/null @@ -1,362 +0,0 @@ -;;; -*- 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/snark-20120808r02/examples/front-last-example.abcl b/snark-20120808r02/examples/front-last-example.abcl deleted file mode 100644 index 7bbf08e..0000000 Binary files a/snark-20120808r02/examples/front-last-example.abcl and /dev/null differ diff --git a/snark-20120808r02/examples/front-last-example.lisp b/snark-20120808r02/examples/front-last-example.lisp deleted file mode 100644 index 756fb49..0000000 --- a/snark-20120808r02/examples/front-last-example.lisp +++ /dev/null @@ -1,82 +0,0 @@ -;;; -*- 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/snark-20120808r02/examples/hot-drink-example.abcl b/snark-20120808r02/examples/hot-drink-example.abcl deleted file mode 100644 index 25caf6a..0000000 Binary files a/snark-20120808r02/examples/hot-drink-example.abcl and /dev/null differ diff --git a/snark-20120808r02/examples/hot-drink-example.lisp b/snark-20120808r02/examples/hot-drink-example.lisp deleted file mode 100644 index 75d9566..0000000 --- a/snark-20120808r02/examples/hot-drink-example.lisp +++ /dev/null @@ -1,130 +0,0 @@ -;;; -*- 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/snark-20120808r02/examples/latin-squares.abcl b/snark-20120808r02/examples/latin-squares.abcl deleted file mode 100644 index 6170a39..0000000 Binary files a/snark-20120808r02/examples/latin-squares.abcl and /dev/null differ diff --git a/snark-20120808r02/examples/latin-squares.lisp b/snark-20120808r02/examples/latin-squares.lisp deleted file mode 100644 index 01b8452..0000000 --- a/snark-20120808r02/examples/latin-squares.lisp +++ /dev/null @@ -1,121 +0,0 @@ -;;; -*- 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/snark-20120808r02/examples/overbeek-test.abcl b/snark-20120808r02/examples/overbeek-test.abcl deleted file mode 100644 index 5d68af1..0000000 Binary files a/snark-20120808r02/examples/overbeek-test.abcl and /dev/null differ diff --git a/snark-20120808r02/examples/overbeek-test.lisp b/snark-20120808r02/examples/overbeek-test.lisp deleted file mode 100644 index 41e1ea6..0000000 --- a/snark-20120808r02/examples/overbeek-test.lisp +++ /dev/null @@ -1,359 +0,0 @@ -;;; -*- 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/snark-20120808r02/examples/ramsey-examples.lisp b/snark-20120808r02/examples/ramsey-examples.lisp deleted file mode 100644 index ffd551c..0000000 --- a/snark-20120808r02/examples/ramsey-examples.lisp +++ /dev/null @@ -1,191 +0,0 @@ -;;; -*- 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/snark-20120808r02/examples/reverse-example.abcl b/snark-20120808r02/examples/reverse-example.abcl deleted file mode 100644 index e1d7aed..0000000 Binary files a/snark-20120808r02/examples/reverse-example.abcl and /dev/null differ diff --git a/snark-20120808r02/examples/reverse-example.lisp b/snark-20120808r02/examples/reverse-example.lisp deleted file mode 100644 index cd1dc74..0000000 --- a/snark-20120808r02/examples/reverse-example.lisp +++ /dev/null @@ -1,51 +0,0 @@ -;;; -*- 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/snark-20120808r02/examples/snark-test b/snark-20120808r02/examples/snark-test deleted file mode 100644 index ba39d59..0000000 --- a/snark-20120808r02/examples/snark-test +++ /dev/null @@ -1,19 +0,0 @@ -;;; 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/snark-20120808r02/examples/steamroller-example.abcl b/snark-20120808r02/examples/steamroller-example.abcl deleted file mode 100644 index cd512e4..0000000 Binary files a/snark-20120808r02/examples/steamroller-example.abcl and /dev/null differ diff --git a/snark-20120808r02/examples/steamroller-example.lisp b/snark-20120808r02/examples/steamroller-example.lisp deleted file mode 100644 index bb866cc..0000000 --- a/snark-20120808r02/examples/steamroller-example.lisp +++ /dev/null @@ -1,82 +0,0 @@ -;;; -*- 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/snark-20120808r02/make-snark-ccl b/snark-20120808r02/make-snark-ccl deleted file mode 100755 index dec5068..0000000 --- a/snark-20120808r02/make-snark-ccl +++ /dev/null @@ -1,6 +0,0 @@ -ccl < compile >& compile.out -ccl << ENDOFSTDIN -(load "snark-system.lisp") -(make-snark-system) -(save-snark-system) -ENDOFSTDIN diff --git a/snark-20120808r02/make-snark-ccl64 b/snark-20120808r02/make-snark-ccl64 deleted file mode 100755 index 12f6bca..0000000 --- a/snark-20120808r02/make-snark-ccl64 +++ /dev/null @@ -1,6 +0,0 @@ -ccl64 < compile >& compile.out -ccl64 << ENDOFSTDIN -(load "snark-system.lisp") -(make-snark-system) -(save-snark-system) -ENDOFSTDIN diff --git a/snark-20120808r02/make-snark-sbcl b/snark-20120808r02/make-snark-sbcl deleted file mode 100755 index 9e8f4f0..0000000 --- a/snark-20120808r02/make-snark-sbcl +++ /dev/null @@ -1,6 +0,0 @@ -sbcl < compile >& compile.out -sbcl << ENDOFSTDIN -(load "snark-system.lisp") -(make-snark-system) -(save-snark-system :name "snark" :executable t) -ENDOFSTDIN diff --git a/snark-20120808r02/make-snark-sbcl64 b/snark-20120808r02/make-snark-sbcl64 deleted file mode 100755 index 7a2bbf8..0000000 --- a/snark-20120808r02/make-snark-sbcl64 +++ /dev/null @@ -1,6 +0,0 @@ -~/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/snark-20120808r02/run-snark b/snark-20120808r02/run-snark deleted file mode 100755 index a5a274a..0000000 --- a/snark-20120808r02/run-snark +++ /dev/null @@ -1,55 +0,0 @@ -#! /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-20120808r02/snark-interface.fasl b/snark-20120808r02/snark-interface.fasl deleted file mode 100644 index 92c9b13..0000000 Binary files a/snark-20120808r02/snark-interface.fasl and /dev/null differ diff --git a/snark-20120808r02/snark-interface.lisp b/snark-20120808r02/snark-interface.lisp deleted file mode 100644 index 12866e9..0000000 --- a/snark-20120808r02/snark-interface.lisp +++ /dev/null @@ -1,256 +0,0 @@ - - - -(defun snark-verbose () - (snark:print-options-when-starting nil) - (snark:print-agenda-when-finished nil) - (snark:print-clocks-when-finished t) - (snark:print-final-rows nil) - (snark:print-symbol-table-warnings nil) - (snark:print-summary-when-finished t) - (snark:print-row-answers nil) - (snark:print-row-goals nil) - (snark:print-rows-when-derived nil) - (snark:print-row-reasons nil) - (snark:print-row-partitions nil) - (snark:print-rows-prettily nil) - (snark:print-rows :min 0 :max 0)) - - -(defun temp-sorts () - (snark:declare-sort 'Room) - (snark:declare-sort 'Door) - (snark:declare-sort 'Agent) - (snark:declare-sort 'Name) - - - (snark:declare-subsort 'Robot 'Agent :subsorts-incompatible t) - (snark:declare-subsort 'Person 'Agent :subsorts-incompatible t) - (snark:declare-subsort 'Commander 'Person :subsorts-incompatible t) - (snark:declare-subsort 'Prisoner 'Person :subsorts-incompatible t) - - (snark:declare-constant 'guard :sort 'Robot) - (snark:declare-constant 'guide :sort 'Robot) - (snark:declare-constant 'commander :sort 'Commander) - (snark:declare-constant 'prisoner :sort 'Prisoner) - - (snark:declare-constant 'room1 :sort 'Room) - (snark:declare-constant 'room2 :sort 'Room) - (snark:declare-constant 'hallway :sort 'Room) - (snark:declare-constant 'accompany :sort 'Name) - - (snark:declare-function 'door 1 :sort '(Door Room)) - - (snark:declare-relation 'robot 1 :sort '(Robot)) - (snark:declare-relation 'room 1 :sort '(Room)) - (snark:declare-relation 'person 1 :sort '(Person)) - (snark:declare-relation 'commander 1 :sort '(Commander)) - (snark:declare-relation 'prisoner 1 :sort '(Prisoner)) - - (snark:declare-relation 'in 2 :sort '(Agent Room)) - (snark:declare-relation 'sameroom 2 :sort '(Agent Agent)) - - (snark:declare-relation 'interrogate 2 :sort '(Agent Agent)) - - (snark:declare-relation 'can 4 :sort '(Name Agent Agent Agent)) - - - (snark:declare-relation 'accompanies 2 :sort '(Agent Agent)) - (snark:declare-relation 'open 1 :sort '(Door)) - - - (snark:declare-variable '?room :sort 'Room) - (snark:declare-variable '?room1 :sort 'Room) - (snark:declare-variable '?room2 :sort 'Room) - - (snark:declare-variable '?person :sort 'Person) - (snark:declare-variable '?person1 :sort 'Person) - (snark:declare-variable '?person2 :sort 'Person) - - (snark:declare-variable '?actor :sort 'Agent) - - - - ) -(defun snark-deverbose () - (snark:print-options-when-starting nil) - (snark:print-agenda-when-finished nil) - (snark:print-clocks-when-finished nil) - (snark:print-final-rows nil) - (snark:print-symbol-table-warnings nil) - (snark:print-summary-when-finished nil) - (snark:print-row-answers nil) - (snark:print-row-goals nil) - (snark:print-rows-when-derived nil) - (snark:print-row-reasons nil) - (snark:print-row-partitions nil) - (snark:print-rows-prettily nil) - (snark:print-rows :min 0 :max 0)) - -(defun setup-snark (&key (time-limit 5) (verbose nil)) - (snark:initialize :verbose verbose) - (if (not verbose) (snark-deverbose) ) - (snark:run-time-limit 5) - (snark:assert-supported t) - (snark:assume-supported t) - (snark:prove-supported t) - (snark:use-hyperresolution t) - (snark:use-paramodulation t) - (snark:use-term-ordering :recursive-path) - (snark:use-simplification-by-equalities t) - (snark::declare-code-for-lists) - - (snark:allow-skolem-symbols-in-answers nil)) - -(defun row-formula (name)) - - -(defun !@ (x) - "reading logic forms with the symbols in the correct package" - (let ((*package* (find-package :snark))) - (read-from-string (princ-to-string x)))) - -(defun @! (x) - "undo the above" - (let ((*package* (find-package :cl-user))) - (read-from-string (princ-to-string x)))) - - -(defun prove-from-axioms (all-axioms f - &key - (time-limit 5) - (verbose nil) - sortal-setup-fn) - (let ((axioms (remove-duplicates all-axioms :test #'equalp))) - (setup-snark :time-limit time-limit :verbose verbose) - (if sortal-setup-fn (funcall sortal-setup-fn)) - (let* ((n-a (make-hash-table :test #'equalp)) - (a-n (make-hash-table :test #'equalp)) - ) - (mapcar (lambda (axiom) - (let ((name (gensym))) - (setf (gethash (princ-to-string axiom) a-n) name) - (setf (gethash (princ-to-string name) n-a) axiom))) axioms) - (mapcar (lambda (axiom) - (snark::assert axiom)) - (mapcar #'!@ axioms)) - (if (equalp :PROOF-FOUND (snark:prove (!@ f))) - (list t (remove nil - (mapcar - (lambda (row reason) - (if (equalp reason 'snark::ASSERTION) - (gethash (princ-to-string (snark:row-name row)) n-a ))) - (snark:row-ancestry (snark:proof)) - (mapcar 'snark:row-reason (snark:row-ancestry (snark:proof)))))) - (list nil nil))))) - - -(defun prove-from-axioms-yes-no (all-axioms f - &key - (time-limit 5) - (verbose nil) - sortal-setup-fn) - (let ((axioms (remove-duplicates all-axioms :test #'equalp))) - (setup-snark :time-limit time-limit :verbose verbose) - (if sortal-setup-fn (funcall sortal-setup-fn)) - (let* ((n-a (make-hash-table :test #'equalp)) - (a-n (make-hash-table :test #'equalp))) - (mapcar (lambda (axiom) - (let ((name (gensym))) - (setf (gethash (princ-to-string axiom) a-n) name) - (setf (gethash (princ-to-string name) n-a) axiom))) axioms) - (mapcar (lambda (axiom) - (snark::assert axiom)) - (mapcar #'!@ axioms)) - (if (equalp :PROOF-FOUND (snark:prove (!@ f))) - "YES" - "NO")))) - - - - -(defun prove-from-axioms-and-get-answer (all-axioms f var - &key - (time-limit 5) - (verbose nil) - sortal-setup-fn) - (let ((axioms (remove-duplicates all-axioms :test #'equalp))) - (setup-snark :time-limit time-limit :verbose verbose) - (if sortal-setup-fn (funcall sortal-setup-fn)) - (let* ((n-a (make-hash-table :test #'equalp)) - (a-n (make-hash-table :test #'equalp))) - (mapcar (lambda (axiom) - (let ((name (gensym))) - (setf (gethash (princ-to-string axiom) a-n) name) - (setf (gethash (princ-to-string name) n-a) axiom))) axioms) - (mapcar (lambda (axiom) - (snark::assert axiom)) - (mapcar #'!@ axioms)) - - (let ((proof (snark:prove (!@ f) :answer (!@ (list 'ans var)) ))) - (if (equalp :PROOF-FOUND proof) - (string-downcase (princ-to-string (@! (second (snark:answer proof) )))) - ""))))) - - -(defun get-answer-string (proof) - (string-downcase (princ-to-string (@! (rest (snark:answer proof)))))) - -(defun prove-from-axioms-and-get-answers (all-axioms f vars - &key - (time-limit 5) - (verbose nil) - sortal-setup-fn) - (let ((axioms (remove-duplicates all-axioms :test #'equalp))) - (setup-snark :time-limit time-limit :verbose verbose) - (if sortal-setup-fn (funcall sortal-setup-fn)) - (let* ((n-a (make-hash-table :test #'equalp)) - (a-n (make-hash-table :test #'equalp))) - (mapcar (lambda (axiom) - (let ((name (gensym))) - (setf (gethash (princ-to-string axiom) a-n) name) - (setf (gethash (princ-to-string name) n-a) axiom))) axioms) - (mapcar (lambda (axiom) - (snark::assert axiom)) - (mapcar #'!@ axioms)) - - (let ((proof (snark:prove (!@ f) :answer (!@ (cons 'ans vars)) ))) - - (if (equalp :PROOF-FOUND proof) - (get-answer-string proof) - ""))))) - -(defun prove-from-axioms-and-get-multiple-answers (all-axioms f vars - &key - (time-limit 5) - (verbose nil) - sortal-setup-fn) - (let ((axioms (remove-duplicates all-axioms :test #'equalp))) - (setup-snark :time-limit time-limit :verbose verbose) - (if sortal-setup-fn (funcall sortal-setup-fn)) - (let* ((n-a (make-hash-table :test #'equalp)) - (a-n (make-hash-table :test #'equalp))) - (mapcar (lambda (axiom) - (let ((name (gensym))) - (setf (gethash (princ-to-string axiom) a-n) name) - (setf (gethash (princ-to-string name) n-a) axiom))) axioms) - (mapcar (lambda (axiom) - (snark::assert axiom)) - (mapcar #'!@ axioms)) - - (let ((proof (snark:prove (!@ f) :answer (!@ (cons 'ans vars)) ))) - - (if (equalp :PROOF-FOUND proof) - (princ-to-string (cons (get-answer-string proof) (call))) - ""))))) - -(defun call () - (let ((proof (snark:closure))) - (if (equalp :PROOF-FOUND proof) - (cons (get-answer-string proof) (call)) - ()))) - -(defun proved? (ans) (first ans)) -(defun used-premises (ans) (second ans)) -(defun consistent? (statements time) - (not (prove-from-axioms statements '(and P (not P)) :time-limit time))) diff --git a/snark-20120808r02/snark-system.lisp b/snark-20120808r02/snark-system.lisp deleted file mode 100644 index ca6b09b..0000000 --- a/snark-20120808r02/snark-system.lisp +++ /dev/null @@ -1,160 +0,0 @@ -;;; -*- 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-20120808r02/src/ac-rpo.abcl b/snark-20120808r02/src/ac-rpo.abcl deleted file mode 100644 index b1a3fd8..0000000 Binary files a/snark-20120808r02/src/ac-rpo.abcl and /dev/null differ diff --git a/snark-20120808r02/src/ac-rpo.lisp b/snark-20120808r02/src/ac-rpo.lisp deleted file mode 100644 index 75c6231..0000000 --- a/snark-20120808r02/src/ac-rpo.lisp +++ /dev/null @@ -1,304 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/agenda-system.lisp b/snark-20120808r02/src/agenda-system.lisp deleted file mode 100644 index 5460939..0000000 --- a/snark-20120808r02/src/agenda-system.lisp +++ /dev/null @@ -1,36 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/agenda.abcl b/snark-20120808r02/src/agenda.abcl deleted file mode 100644 index cd7ea23..0000000 Binary files a/snark-20120808r02/src/agenda.abcl and /dev/null differ diff --git a/snark-20120808r02/src/agenda.lisp b/snark-20120808r02/src/agenda.lisp deleted file mode 100644 index 0ee9de3..0000000 --- a/snark-20120808r02/src/agenda.lisp +++ /dev/null @@ -1,234 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/alists.abcl b/snark-20120808r02/src/alists.abcl deleted file mode 100644 index 815e8f0..0000000 Binary files a/snark-20120808r02/src/alists.abcl and /dev/null differ diff --git a/snark-20120808r02/src/alists.lisp b/snark-20120808r02/src/alists.lisp deleted file mode 100644 index 646f96f..0000000 --- a/snark-20120808r02/src/alists.lisp +++ /dev/null @@ -1,121 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/argument-bag-ac.abcl b/snark-20120808r02/src/argument-bag-ac.abcl deleted file mode 100644 index aa64d11..0000000 Binary files a/snark-20120808r02/src/argument-bag-ac.abcl and /dev/null differ diff --git a/snark-20120808r02/src/argument-bag-ac.lisp b/snark-20120808r02/src/argument-bag-ac.lisp deleted file mode 100644 index 46c0574..0000000 --- a/snark-20120808r02/src/argument-bag-ac.lisp +++ /dev/null @@ -1,82 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/argument-list-a1.abcl b/snark-20120808r02/src/argument-list-a1.abcl deleted file mode 100644 index 72ab4b7..0000000 Binary files a/snark-20120808r02/src/argument-list-a1.abcl and /dev/null differ diff --git a/snark-20120808r02/src/argument-list-a1.lisp b/snark-20120808r02/src/argument-list-a1.lisp deleted file mode 100644 index 492c297..0000000 --- a/snark-20120808r02/src/argument-list-a1.lisp +++ /dev/null @@ -1,145 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/assertion-analysis.abcl b/snark-20120808r02/src/assertion-analysis.abcl deleted file mode 100644 index 0c507e1..0000000 Binary files a/snark-20120808r02/src/assertion-analysis.abcl and /dev/null differ diff --git a/snark-20120808r02/src/assertion-analysis.lisp b/snark-20120808r02/src/assertion-analysis.lisp deleted file mode 100644 index 4af4545..0000000 --- a/snark-20120808r02/src/assertion-analysis.lisp +++ /dev/null @@ -1,502 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/assertion-file.abcl b/snark-20120808r02/src/assertion-file.abcl deleted file mode 100644 index 6821b81..0000000 Binary files a/snark-20120808r02/src/assertion-file.abcl and /dev/null differ diff --git a/snark-20120808r02/src/assertion-file.lisp b/snark-20120808r02/src/assertion-file.lisp deleted file mode 100644 index 6c00203..0000000 --- a/snark-20120808r02/src/assertion-file.lisp +++ /dev/null @@ -1,262 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/clocks.abcl b/snark-20120808r02/src/clocks.abcl deleted file mode 100644 index d214db1..0000000 Binary files a/snark-20120808r02/src/clocks.abcl and /dev/null differ diff --git a/snark-20120808r02/src/clocks.lisp b/snark-20120808r02/src/clocks.lisp deleted file mode 100644 index 467d85b..0000000 --- a/snark-20120808r02/src/clocks.lisp +++ /dev/null @@ -1,169 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/closure1.lisp b/snark-20120808r02/src/closure1.lisp deleted file mode 100644 index 0ec98c0..0000000 --- a/snark-20120808r02/src/closure1.lisp +++ /dev/null @@ -1,66 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/code-for-bags4.abcl b/snark-20120808r02/src/code-for-bags4.abcl deleted file mode 100644 index e14fe3c..0000000 Binary files a/snark-20120808r02/src/code-for-bags4.abcl and /dev/null differ diff --git a/snark-20120808r02/src/code-for-bags4.lisp b/snark-20120808r02/src/code-for-bags4.lisp deleted file mode 100644 index b27e2c2..0000000 --- a/snark-20120808r02/src/code-for-bags4.lisp +++ /dev/null @@ -1,116 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/code-for-lists2.abcl b/snark-20120808r02/src/code-for-lists2.abcl deleted file mode 100644 index 96c5ce7..0000000 Binary files a/snark-20120808r02/src/code-for-lists2.abcl and /dev/null differ diff --git a/snark-20120808r02/src/code-for-lists2.lisp b/snark-20120808r02/src/code-for-lists2.lisp deleted file mode 100644 index 92a0af7..0000000 --- a/snark-20120808r02/src/code-for-lists2.lisp +++ /dev/null @@ -1,34 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/code-for-numbers3.abcl b/snark-20120808r02/src/code-for-numbers3.abcl deleted file mode 100644 index 23f25b1..0000000 Binary files a/snark-20120808r02/src/code-for-numbers3.abcl and /dev/null differ diff --git a/snark-20120808r02/src/code-for-numbers3.lisp b/snark-20120808r02/src/code-for-numbers3.lisp deleted file mode 100644 index c24a1ef..0000000 --- a/snark-20120808r02/src/code-for-numbers3.lisp +++ /dev/null @@ -1,505 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/code-for-strings2.abcl b/snark-20120808r02/src/code-for-strings2.abcl deleted file mode 100644 index 797f3c7..0000000 Binary files a/snark-20120808r02/src/code-for-strings2.abcl and /dev/null differ diff --git a/snark-20120808r02/src/code-for-strings2.lisp b/snark-20120808r02/src/code-for-strings2.lisp deleted file mode 100644 index c835382..0000000 --- a/snark-20120808r02/src/code-for-strings2.lisp +++ /dev/null @@ -1,62 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/coder.abcl b/snark-20120808r02/src/coder.abcl deleted file mode 100644 index 0e1acf7..0000000 Binary files a/snark-20120808r02/src/coder.abcl and /dev/null differ diff --git a/snark-20120808r02/src/coder.lisp b/snark-20120808r02/src/coder.lisp deleted file mode 100644 index b881465..0000000 --- a/snark-20120808r02/src/coder.lisp +++ /dev/null @@ -1,714 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/collectors.abcl b/snark-20120808r02/src/collectors.abcl deleted file mode 100644 index 5621061..0000000 Binary files a/snark-20120808r02/src/collectors.abcl and /dev/null differ diff --git a/snark-20120808r02/src/collectors.lisp b/snark-20120808r02/src/collectors.lisp deleted file mode 100644 index 8617ce0..0000000 --- a/snark-20120808r02/src/collectors.lisp +++ /dev/null @@ -1,143 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/connectives.abcl b/snark-20120808r02/src/connectives.abcl deleted file mode 100644 index f64bdca..0000000 Binary files a/snark-20120808r02/src/connectives.abcl and /dev/null differ diff --git a/snark-20120808r02/src/connectives.lisp b/snark-20120808r02/src/connectives.lisp deleted file mode 100644 index 1cd1554..0000000 --- a/snark-20120808r02/src/connectives.lisp +++ /dev/null @@ -1,550 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/constants.abcl b/snark-20120808r02/src/constants.abcl deleted file mode 100644 index f424e45..0000000 Binary files a/snark-20120808r02/src/constants.abcl and /dev/null differ diff --git a/snark-20120808r02/src/constants.lisp b/snark-20120808r02/src/constants.lisp deleted file mode 100644 index 6205a91..0000000 --- a/snark-20120808r02/src/constants.lisp +++ /dev/null @@ -1,305 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/constraints.abcl b/snark-20120808r02/src/constraints.abcl deleted file mode 100644 index 13c5014..0000000 Binary files a/snark-20120808r02/src/constraints.abcl and /dev/null differ diff --git a/snark-20120808r02/src/constraints.lisp b/snark-20120808r02/src/constraints.lisp deleted file mode 100644 index aaedf83..0000000 --- a/snark-20120808r02/src/constraints.lisp +++ /dev/null @@ -1,335 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/counters.abcl b/snark-20120808r02/src/counters.abcl deleted file mode 100644 index 359662a..0000000 Binary files a/snark-20120808r02/src/counters.abcl and /dev/null differ diff --git a/snark-20120808r02/src/counters.lisp b/snark-20120808r02/src/counters.lisp deleted file mode 100644 index 85dad20..0000000 --- a/snark-20120808r02/src/counters.lisp +++ /dev/null @@ -1,90 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/date-reasoning2.abcl b/snark-20120808r02/src/date-reasoning2.abcl deleted file mode 100644 index ca06e4c..0000000 Binary files a/snark-20120808r02/src/date-reasoning2.abcl and /dev/null differ diff --git a/snark-20120808r02/src/date-reasoning2.lisp b/snark-20120808r02/src/date-reasoning2.lisp deleted file mode 100644 index 688773e..0000000 --- a/snark-20120808r02/src/date-reasoning2.lisp +++ /dev/null @@ -1,347 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/davis-putnam3.abcl b/snark-20120808r02/src/davis-putnam3.abcl deleted file mode 100644 index c28741c..0000000 Binary files a/snark-20120808r02/src/davis-putnam3.abcl and /dev/null differ diff --git a/snark-20120808r02/src/davis-putnam3.lisp b/snark-20120808r02/src/davis-putnam3.lisp deleted file mode 100644 index 87bc60b..0000000 --- a/snark-20120808r02/src/davis-putnam3.lisp +++ /dev/null @@ -1,2344 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/deque-system.lisp b/snark-20120808r02/src/deque-system.lisp deleted file mode 100644 index 0775d3d..0000000 --- a/snark-20120808r02/src/deque-system.lisp +++ /dev/null @@ -1,38 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/deque2.abcl b/snark-20120808r02/src/deque2.abcl deleted file mode 100644 index eeea2b3..0000000 Binary files a/snark-20120808r02/src/deque2.abcl and /dev/null differ diff --git a/snark-20120808r02/src/deque2.lisp b/snark-20120808r02/src/deque2.lisp deleted file mode 100644 index 7c3021d..0000000 --- a/snark-20120808r02/src/deque2.lisp +++ /dev/null @@ -1,228 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/dp-refute.abcl b/snark-20120808r02/src/dp-refute.abcl deleted file mode 100644 index 62f09e8..0000000 Binary files a/snark-20120808r02/src/dp-refute.abcl and /dev/null differ diff --git a/snark-20120808r02/src/dp-refute.lisp b/snark-20120808r02/src/dp-refute.lisp deleted file mode 100644 index 3ba94ac..0000000 --- a/snark-20120808r02/src/dp-refute.lisp +++ /dev/null @@ -1,250 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/dpll-system.lisp b/snark-20120808r02/src/dpll-system.lisp deleted file mode 100644 index 10ae9df..0000000 --- a/snark-20120808r02/src/dpll-system.lisp +++ /dev/null @@ -1,46 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/equal.abcl b/snark-20120808r02/src/equal.abcl deleted file mode 100644 index 83f84e1..0000000 Binary files a/snark-20120808r02/src/equal.abcl and /dev/null differ diff --git a/snark-20120808r02/src/equal.lisp b/snark-20120808r02/src/equal.lisp deleted file mode 100644 index 2b9e0cb..0000000 --- a/snark-20120808r02/src/equal.lisp +++ /dev/null @@ -1,115 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/eval.abcl b/snark-20120808r02/src/eval.abcl deleted file mode 100644 index c2f7a15..0000000 Binary files a/snark-20120808r02/src/eval.abcl and /dev/null differ diff --git a/snark-20120808r02/src/eval.lisp b/snark-20120808r02/src/eval.lisp deleted file mode 100644 index a007435..0000000 --- a/snark-20120808r02/src/eval.lisp +++ /dev/null @@ -1,350 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/feature-system.lisp b/snark-20120808r02/src/feature-system.lisp deleted file mode 100644 index e213106..0000000 --- a/snark-20120808r02/src/feature-system.lisp +++ /dev/null @@ -1,37 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/feature-vector-index.abcl b/snark-20120808r02/src/feature-vector-index.abcl deleted file mode 100644 index a9cdb52..0000000 Binary files a/snark-20120808r02/src/feature-vector-index.abcl and /dev/null differ diff --git a/snark-20120808r02/src/feature-vector-index.lisp b/snark-20120808r02/src/feature-vector-index.lisp deleted file mode 100644 index 4e48972..0000000 --- a/snark-20120808r02/src/feature-vector-index.lisp +++ /dev/null @@ -1,157 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/feature-vector-trie.abcl b/snark-20120808r02/src/feature-vector-trie.abcl deleted file mode 100644 index 6ff4635..0000000 Binary files a/snark-20120808r02/src/feature-vector-trie.abcl and /dev/null differ diff --git a/snark-20120808r02/src/feature-vector-trie.lisp b/snark-20120808r02/src/feature-vector-trie.lisp deleted file mode 100644 index 2b3ab1e..0000000 --- a/snark-20120808r02/src/feature-vector-trie.lisp +++ /dev/null @@ -1,76 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/feature-vector.abcl b/snark-20120808r02/src/feature-vector.abcl deleted file mode 100644 index c52f093..0000000 Binary files a/snark-20120808r02/src/feature-vector.abcl and /dev/null differ diff --git a/snark-20120808r02/src/feature-vector.lisp b/snark-20120808r02/src/feature-vector.lisp deleted file mode 100644 index 0e51d3e..0000000 --- a/snark-20120808r02/src/feature-vector.lisp +++ /dev/null @@ -1,153 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/feature.abcl b/snark-20120808r02/src/feature.abcl deleted file mode 100644 index 8ab87da..0000000 Binary files a/snark-20120808r02/src/feature.abcl and /dev/null differ diff --git a/snark-20120808r02/src/feature.lisp b/snark-20120808r02/src/feature.lisp deleted file mode 100644 index 17b82c5..0000000 --- a/snark-20120808r02/src/feature.lisp +++ /dev/null @@ -1,831 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/functions.abcl b/snark-20120808r02/src/functions.abcl deleted file mode 100644 index d62d9db..0000000 Binary files a/snark-20120808r02/src/functions.abcl and /dev/null differ diff --git a/snark-20120808r02/src/functions.lisp b/snark-20120808r02/src/functions.lisp deleted file mode 100644 index 084b558..0000000 --- a/snark-20120808r02/src/functions.lisp +++ /dev/null @@ -1,414 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/globals.abcl b/snark-20120808r02/src/globals.abcl deleted file mode 100644 index 2a20880..0000000 Binary files a/snark-20120808r02/src/globals.abcl and /dev/null differ diff --git a/snark-20120808r02/src/globals.lisp b/snark-20120808r02/src/globals.lisp deleted file mode 100644 index c962f23..0000000 --- a/snark-20120808r02/src/globals.lisp +++ /dev/null @@ -1,352 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/infix-operators.abcl b/snark-20120808r02/src/infix-operators.abcl deleted file mode 100644 index 4e756b2..0000000 Binary files a/snark-20120808r02/src/infix-operators.abcl and /dev/null differ diff --git a/snark-20120808r02/src/infix-operators.lisp b/snark-20120808r02/src/infix-operators.lisp deleted file mode 100644 index d9f9490..0000000 --- a/snark-20120808r02/src/infix-operators.lisp +++ /dev/null @@ -1,105 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/infix-reader-system.lisp b/snark-20120808r02/src/infix-reader-system.lisp deleted file mode 100644 index 2ce4ce7..0000000 --- a/snark-20120808r02/src/infix-reader-system.lisp +++ /dev/null @@ -1,31 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/infix-reader.abcl b/snark-20120808r02/src/infix-reader.abcl deleted file mode 100644 index 3e39c78..0000000 Binary files a/snark-20120808r02/src/infix-reader.abcl and /dev/null differ diff --git a/snark-20120808r02/src/infix-reader.lisp b/snark-20120808r02/src/infix-reader.lisp deleted file mode 100644 index 7447b6f..0000000 --- a/snark-20120808r02/src/infix-reader.lisp +++ /dev/null @@ -1,441 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/input.abcl b/snark-20120808r02/src/input.abcl deleted file mode 100644 index cfb59b4..0000000 Binary files a/snark-20120808r02/src/input.abcl and /dev/null differ diff --git a/snark-20120808r02/src/input.lisp b/snark-20120808r02/src/input.lisp deleted file mode 100644 index 0c5f352..0000000 --- a/snark-20120808r02/src/input.lisp +++ /dev/null @@ -1,984 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/jepd-relations-tables.abcl b/snark-20120808r02/src/jepd-relations-tables.abcl deleted file mode 100644 index d86ce2d..0000000 Binary files a/snark-20120808r02/src/jepd-relations-tables.abcl and /dev/null differ diff --git a/snark-20120808r02/src/jepd-relations-tables.lisp b/snark-20120808r02/src/jepd-relations-tables.lisp deleted file mode 100644 index d691d97..0000000 --- a/snark-20120808r02/src/jepd-relations-tables.lisp +++ /dev/null @@ -1,511 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/jepd-relations.abcl b/snark-20120808r02/src/jepd-relations.abcl deleted file mode 100644 index 258fd8b..0000000 Binary files a/snark-20120808r02/src/jepd-relations.abcl and /dev/null differ diff --git a/snark-20120808r02/src/jepd-relations.lisp b/snark-20120808r02/src/jepd-relations.lisp deleted file mode 100644 index d21090c..0000000 --- a/snark-20120808r02/src/jepd-relations.lisp +++ /dev/null @@ -1,731 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/knuth-bendix-ordering2.abcl b/snark-20120808r02/src/knuth-bendix-ordering2.abcl deleted file mode 100644 index a12eb76..0000000 Binary files a/snark-20120808r02/src/knuth-bendix-ordering2.abcl and /dev/null differ diff --git a/snark-20120808r02/src/knuth-bendix-ordering2.lisp b/snark-20120808r02/src/knuth-bendix-ordering2.lisp deleted file mode 100644 index 464b110..0000000 --- a/snark-20120808r02/src/knuth-bendix-ordering2.lisp +++ /dev/null @@ -1,205 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/lisp-system.lisp b/snark-20120808r02/src/lisp-system.lisp deleted file mode 100644 index d1dfdef..0000000 --- a/snark-20120808r02/src/lisp-system.lisp +++ /dev/null @@ -1,102 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/lisp.abcl b/snark-20120808r02/src/lisp.abcl deleted file mode 100644 index 4cc8caa..0000000 Binary files a/snark-20120808r02/src/lisp.abcl and /dev/null differ diff --git a/snark-20120808r02/src/lisp.lisp b/snark-20120808r02/src/lisp.lisp deleted file mode 100644 index 6957ed6..0000000 --- a/snark-20120808r02/src/lisp.lisp +++ /dev/null @@ -1,566 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/loads.lisp b/snark-20120808r02/src/loads.lisp deleted file mode 100644 index 15f7950..0000000 --- a/snark-20120808r02/src/loads.lisp +++ /dev/null @@ -1,30 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/main.abcl b/snark-20120808r02/src/main.abcl deleted file mode 100644 index 1532787..0000000 Binary files a/snark-20120808r02/src/main.abcl and /dev/null differ diff --git a/snark-20120808r02/src/main.lisp b/snark-20120808r02/src/main.lisp deleted file mode 100644 index f3523ac..0000000 --- a/snark-20120808r02/src/main.lisp +++ /dev/null @@ -1,2528 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/map-file.abcl b/snark-20120808r02/src/map-file.abcl deleted file mode 100644 index b664969..0000000 Binary files a/snark-20120808r02/src/map-file.abcl and /dev/null differ diff --git a/snark-20120808r02/src/map-file.lisp b/snark-20120808r02/src/map-file.lisp deleted file mode 100644 index 128b295..0000000 --- a/snark-20120808r02/src/map-file.lisp +++ /dev/null @@ -1,85 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/multiset-ordering.abcl b/snark-20120808r02/src/multiset-ordering.abcl deleted file mode 100644 index 5aed182..0000000 Binary files a/snark-20120808r02/src/multiset-ordering.abcl and /dev/null differ diff --git a/snark-20120808r02/src/multiset-ordering.lisp b/snark-20120808r02/src/multiset-ordering.lisp deleted file mode 100644 index 87a257e..0000000 --- a/snark-20120808r02/src/multiset-ordering.lisp +++ /dev/null @@ -1,349 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/mvlet.abcl b/snark-20120808r02/src/mvlet.abcl deleted file mode 100644 index b3a064d..0000000 Binary files a/snark-20120808r02/src/mvlet.abcl and /dev/null differ diff --git a/snark-20120808r02/src/mvlet.lisp b/snark-20120808r02/src/mvlet.lisp deleted file mode 100644 index 3e9d3c3..0000000 --- a/snark-20120808r02/src/mvlet.lisp +++ /dev/null @@ -1,251 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/nonhorn-magic-set.abcl b/snark-20120808r02/src/nonhorn-magic-set.abcl deleted file mode 100644 index cab9bd5..0000000 Binary files a/snark-20120808r02/src/nonhorn-magic-set.abcl and /dev/null differ diff --git a/snark-20120808r02/src/nonhorn-magic-set.lisp b/snark-20120808r02/src/nonhorn-magic-set.lisp deleted file mode 100644 index f4c1fac..0000000 --- a/snark-20120808r02/src/nonhorn-magic-set.lisp +++ /dev/null @@ -1,131 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/numbering-system.lisp b/snark-20120808r02/src/numbering-system.lisp deleted file mode 100644 index 4249f4c..0000000 --- a/snark-20120808r02/src/numbering-system.lisp +++ /dev/null @@ -1,32 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/numbering.abcl b/snark-20120808r02/src/numbering.abcl deleted file mode 100644 index 873e4b4..0000000 Binary files a/snark-20120808r02/src/numbering.abcl and /dev/null differ diff --git a/snark-20120808r02/src/numbering.lisp b/snark-20120808r02/src/numbering.lisp deleted file mode 100644 index 2eff933..0000000 --- a/snark-20120808r02/src/numbering.lisp +++ /dev/null @@ -1,82 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/options.abcl b/snark-20120808r02/src/options.abcl deleted file mode 100644 index 35402bd..0000000 Binary files a/snark-20120808r02/src/options.abcl and /dev/null differ diff --git a/snark-20120808r02/src/options.lisp b/snark-20120808r02/src/options.lisp deleted file mode 100644 index eabae51..0000000 --- a/snark-20120808r02/src/options.lisp +++ /dev/null @@ -1,395 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/output.abcl b/snark-20120808r02/src/output.abcl deleted file mode 100644 index 9e35144..0000000 Binary files a/snark-20120808r02/src/output.abcl and /dev/null differ diff --git a/snark-20120808r02/src/output.lisp b/snark-20120808r02/src/output.lisp deleted file mode 100644 index 1a5062f..0000000 --- a/snark-20120808r02/src/output.lisp +++ /dev/null @@ -1,506 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/patches.abcl b/snark-20120808r02/src/patches.abcl deleted file mode 100644 index 0f86217..0000000 Binary files a/snark-20120808r02/src/patches.abcl and /dev/null differ diff --git a/snark-20120808r02/src/patches.lisp b/snark-20120808r02/src/patches.lisp deleted file mode 100644 index b15efff..0000000 --- a/snark-20120808r02/src/patches.lisp +++ /dev/null @@ -1,26 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/path-index.abcl b/snark-20120808r02/src/path-index.abcl deleted file mode 100644 index 0779138..0000000 Binary files a/snark-20120808r02/src/path-index.abcl and /dev/null differ diff --git a/snark-20120808r02/src/path-index.lisp b/snark-20120808r02/src/path-index.lisp deleted file mode 100644 index 0794c49..0000000 --- a/snark-20120808r02/src/path-index.lisp +++ /dev/null @@ -1,870 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/pattern-match.abcl b/snark-20120808r02/src/pattern-match.abcl deleted file mode 100644 index 7dd2d27..0000000 Binary files a/snark-20120808r02/src/pattern-match.abcl and /dev/null differ diff --git a/snark-20120808r02/src/pattern-match.lisp b/snark-20120808r02/src/pattern-match.lisp deleted file mode 100644 index efeb6fb..0000000 --- a/snark-20120808r02/src/pattern-match.lisp +++ /dev/null @@ -1,45 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/posets.abcl b/snark-20120808r02/src/posets.abcl deleted file mode 100644 index 6a02a06..0000000 Binary files a/snark-20120808r02/src/posets.abcl and /dev/null differ diff --git a/snark-20120808r02/src/posets.lisp b/snark-20120808r02/src/posets.lisp deleted file mode 100644 index 42dc63a..0000000 --- a/snark-20120808r02/src/posets.lisp +++ /dev/null @@ -1,69 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/progc.abcl b/snark-20120808r02/src/progc.abcl deleted file mode 100644 index 2409bfb..0000000 Binary files a/snark-20120808r02/src/progc.abcl and /dev/null differ diff --git a/snark-20120808r02/src/progc.lisp b/snark-20120808r02/src/progc.lisp deleted file mode 100644 index d208187..0000000 --- a/snark-20120808r02/src/progc.lisp +++ /dev/null @@ -1,288 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/recursive-path-ordering.abcl b/snark-20120808r02/src/recursive-path-ordering.abcl deleted file mode 100644 index 18f0bc6..0000000 Binary files a/snark-20120808r02/src/recursive-path-ordering.abcl and /dev/null differ diff --git a/snark-20120808r02/src/recursive-path-ordering.lisp b/snark-20120808r02/src/recursive-path-ordering.lisp deleted file mode 100644 index 831a73d..0000000 --- a/snark-20120808r02/src/recursive-path-ordering.lisp +++ /dev/null @@ -1,292 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/resolve-code-tables.abcl b/snark-20120808r02/src/resolve-code-tables.abcl deleted file mode 100644 index 12b7a8f..0000000 Binary files a/snark-20120808r02/src/resolve-code-tables.abcl and /dev/null differ diff --git a/snark-20120808r02/src/resolve-code-tables.lisp b/snark-20120808r02/src/resolve-code-tables.lisp deleted file mode 100644 index 798456b..0000000 --- a/snark-20120808r02/src/resolve-code-tables.lisp +++ /dev/null @@ -1,154 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/resolve-code.abcl b/snark-20120808r02/src/resolve-code.abcl deleted file mode 100644 index c6aeb9b..0000000 Binary files a/snark-20120808r02/src/resolve-code.abcl and /dev/null differ diff --git a/snark-20120808r02/src/resolve-code.lisp b/snark-20120808r02/src/resolve-code.lisp deleted file mode 100644 index f1c76ed..0000000 --- a/snark-20120808r02/src/resolve-code.lisp +++ /dev/null @@ -1,193 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/rewrite-code.abcl b/snark-20120808r02/src/rewrite-code.abcl deleted file mode 100644 index a136e7b..0000000 Binary files a/snark-20120808r02/src/rewrite-code.abcl and /dev/null differ diff --git a/snark-20120808r02/src/rewrite-code.lisp b/snark-20120808r02/src/rewrite-code.lisp deleted file mode 100644 index cde5f25..0000000 --- a/snark-20120808r02/src/rewrite-code.lisp +++ /dev/null @@ -1,402 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/rewrite.abcl b/snark-20120808r02/src/rewrite.abcl deleted file mode 100644 index dc3c78f..0000000 Binary files a/snark-20120808r02/src/rewrite.abcl and /dev/null differ diff --git a/snark-20120808r02/src/rewrite.lisp b/snark-20120808r02/src/rewrite.lisp deleted file mode 100644 index cea6f62..0000000 --- a/snark-20120808r02/src/rewrite.lisp +++ /dev/null @@ -1,488 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/row-contexts.abcl b/snark-20120808r02/src/row-contexts.abcl deleted file mode 100644 index 82edefe..0000000 Binary files a/snark-20120808r02/src/row-contexts.abcl and /dev/null differ diff --git a/snark-20120808r02/src/row-contexts.lisp b/snark-20120808r02/src/row-contexts.lisp deleted file mode 100644 index 8e4700d..0000000 --- a/snark-20120808r02/src/row-contexts.lisp +++ /dev/null @@ -1,184 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/rows.abcl b/snark-20120808r02/src/rows.abcl deleted file mode 100644 index 920e40a..0000000 Binary files a/snark-20120808r02/src/rows.abcl and /dev/null differ diff --git a/snark-20120808r02/src/rows.lisp b/snark-20120808r02/src/rows.lisp deleted file mode 100644 index 27b277f..0000000 --- a/snark-20120808r02/src/rows.lisp +++ /dev/null @@ -1,387 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/simplification-ordering.abcl b/snark-20120808r02/src/simplification-ordering.abcl deleted file mode 100644 index e2169ca..0000000 Binary files a/snark-20120808r02/src/simplification-ordering.abcl and /dev/null differ diff --git a/snark-20120808r02/src/simplification-ordering.lisp b/snark-20120808r02/src/simplification-ordering.lisp deleted file mode 100644 index e8d9181..0000000 --- a/snark-20120808r02/src/simplification-ordering.lisp +++ /dev/null @@ -1,356 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/snark-pkg.lisp b/snark-20120808r02/src/snark-pkg.lisp deleted file mode 100644 index 3e50807..0000000 --- a/snark-20120808r02/src/snark-pkg.lisp +++ /dev/null @@ -1,308 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/solve-sum.abcl b/snark-20120808r02/src/solve-sum.abcl deleted file mode 100644 index 46c7452..0000000 Binary files a/snark-20120808r02/src/solve-sum.abcl and /dev/null differ diff --git a/snark-20120808r02/src/solve-sum.lisp b/snark-20120808r02/src/solve-sum.lisp deleted file mode 100644 index e6e53b1..0000000 --- a/snark-20120808r02/src/solve-sum.lisp +++ /dev/null @@ -1,95 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/sorts-functions.abcl b/snark-20120808r02/src/sorts-functions.abcl deleted file mode 100644 index 35ae964..0000000 Binary files a/snark-20120808r02/src/sorts-functions.abcl and /dev/null differ diff --git a/snark-20120808r02/src/sorts-functions.lisp b/snark-20120808r02/src/sorts-functions.lisp deleted file mode 100644 index a421551..0000000 --- a/snark-20120808r02/src/sorts-functions.lisp +++ /dev/null @@ -1,81 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/sorts-interface.abcl b/snark-20120808r02/src/sorts-interface.abcl deleted file mode 100644 index 974ec45..0000000 Binary files a/snark-20120808r02/src/sorts-interface.abcl and /dev/null differ diff --git a/snark-20120808r02/src/sorts-interface.lisp b/snark-20120808r02/src/sorts-interface.lisp deleted file mode 100644 index 340c7bb..0000000 --- a/snark-20120808r02/src/sorts-interface.lisp +++ /dev/null @@ -1,180 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/sorts.abcl b/snark-20120808r02/src/sorts.abcl deleted file mode 100644 index 4df4249..0000000 Binary files a/snark-20120808r02/src/sorts.abcl and /dev/null differ diff --git a/snark-20120808r02/src/sorts.lisp b/snark-20120808r02/src/sorts.lisp deleted file mode 100644 index a927dd1..0000000 --- a/snark-20120808r02/src/sorts.lisp +++ /dev/null @@ -1,284 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/sparse-array-system.lisp b/snark-20120808r02/src/sparse-array-system.lisp deleted file mode 100644 index e9a2504..0000000 --- a/snark-20120808r02/src/sparse-array-system.lisp +++ /dev/null @@ -1,49 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/sparse-array.abcl b/snark-20120808r02/src/sparse-array.abcl deleted file mode 100644 index 4a969ab..0000000 Binary files a/snark-20120808r02/src/sparse-array.abcl and /dev/null differ diff --git a/snark-20120808r02/src/sparse-array.lisp b/snark-20120808r02/src/sparse-array.lisp deleted file mode 100644 index e26668e..0000000 --- a/snark-20120808r02/src/sparse-array.lisp +++ /dev/null @@ -1,465 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/sparse-vector-expression.abcl b/snark-20120808r02/src/sparse-vector-expression.abcl deleted file mode 100644 index a3627e9..0000000 Binary files a/snark-20120808r02/src/sparse-vector-expression.abcl and /dev/null differ diff --git a/snark-20120808r02/src/sparse-vector-expression.lisp b/snark-20120808r02/src/sparse-vector-expression.lisp deleted file mode 100644 index f211788..0000000 --- a/snark-20120808r02/src/sparse-vector-expression.lisp +++ /dev/null @@ -1,343 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/sparse-vector5.abcl b/snark-20120808r02/src/sparse-vector5.abcl deleted file mode 100644 index 4f391d7..0000000 Binary files a/snark-20120808r02/src/sparse-vector5.abcl and /dev/null differ diff --git a/snark-20120808r02/src/sparse-vector5.lisp b/snark-20120808r02/src/sparse-vector5.lisp deleted file mode 100644 index 6f6ca6b..0000000 --- a/snark-20120808r02/src/sparse-vector5.lisp +++ /dev/null @@ -1,982 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/subst.abcl b/snark-20120808r02/src/subst.abcl deleted file mode 100644 index df88f6d..0000000 Binary files a/snark-20120808r02/src/subst.abcl and /dev/null differ diff --git a/snark-20120808r02/src/subst.lisp b/snark-20120808r02/src/subst.lisp deleted file mode 100644 index 109404e..0000000 --- a/snark-20120808r02/src/subst.lisp +++ /dev/null @@ -1,611 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/substitute.abcl b/snark-20120808r02/src/substitute.abcl deleted file mode 100644 index 7986aac..0000000 Binary files a/snark-20120808r02/src/substitute.abcl and /dev/null differ diff --git a/snark-20120808r02/src/substitute.lisp b/snark-20120808r02/src/substitute.lisp deleted file mode 100644 index 5c17818..0000000 --- a/snark-20120808r02/src/substitute.lisp +++ /dev/null @@ -1,201 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/subsume-bag.abcl b/snark-20120808r02/src/subsume-bag.abcl deleted file mode 100644 index 3b973df..0000000 Binary files a/snark-20120808r02/src/subsume-bag.abcl and /dev/null differ diff --git a/snark-20120808r02/src/subsume-bag.lisp b/snark-20120808r02/src/subsume-bag.lisp deleted file mode 100644 index db53cff..0000000 --- a/snark-20120808r02/src/subsume-bag.lisp +++ /dev/null @@ -1,192 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/subsume-clause.abcl b/snark-20120808r02/src/subsume-clause.abcl deleted file mode 100644 index e18c2e5..0000000 Binary files a/snark-20120808r02/src/subsume-clause.abcl and /dev/null differ diff --git a/snark-20120808r02/src/subsume-clause.lisp b/snark-20120808r02/src/subsume-clause.lisp deleted file mode 100644 index 73755cb..0000000 --- a/snark-20120808r02/src/subsume-clause.lisp +++ /dev/null @@ -1,349 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/subsume.abcl b/snark-20120808r02/src/subsume.abcl deleted file mode 100644 index c7988ff..0000000 Binary files a/snark-20120808r02/src/subsume.abcl and /dev/null differ diff --git a/snark-20120808r02/src/subsume.lisp b/snark-20120808r02/src/subsume.lisp deleted file mode 100644 index 8b44136..0000000 --- a/snark-20120808r02/src/subsume.lisp +++ /dev/null @@ -1,503 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/symbol-definitions.abcl b/snark-20120808r02/src/symbol-definitions.abcl deleted file mode 100644 index 97cfb7b..0000000 Binary files a/snark-20120808r02/src/symbol-definitions.abcl and /dev/null differ diff --git a/snark-20120808r02/src/symbol-definitions.lisp b/snark-20120808r02/src/symbol-definitions.lisp deleted file mode 100644 index 27ee0e4..0000000 --- a/snark-20120808r02/src/symbol-definitions.lisp +++ /dev/null @@ -1,184 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/symbol-ordering.abcl b/snark-20120808r02/src/symbol-ordering.abcl deleted file mode 100644 index 60d6859..0000000 Binary files a/snark-20120808r02/src/symbol-ordering.abcl and /dev/null differ diff --git a/snark-20120808r02/src/symbol-ordering.lisp b/snark-20120808r02/src/symbol-ordering.lisp deleted file mode 100644 index ea609bc..0000000 --- a/snark-20120808r02/src/symbol-ordering.lisp +++ /dev/null @@ -1,251 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/symbol-table2.abcl b/snark-20120808r02/src/symbol-table2.abcl deleted file mode 100644 index 6a31f20..0000000 Binary files a/snark-20120808r02/src/symbol-table2.abcl and /dev/null differ diff --git a/snark-20120808r02/src/symbol-table2.lisp b/snark-20120808r02/src/symbol-table2.lisp deleted file mode 100644 index 0b7b7bb..0000000 --- a/snark-20120808r02/src/symbol-table2.lisp +++ /dev/null @@ -1,397 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/term-hash.abcl b/snark-20120808r02/src/term-hash.abcl deleted file mode 100644 index 5ab6dbd..0000000 Binary files a/snark-20120808r02/src/term-hash.abcl and /dev/null differ diff --git a/snark-20120808r02/src/term-hash.lisp b/snark-20120808r02/src/term-hash.lisp deleted file mode 100644 index d494a57..0000000 --- a/snark-20120808r02/src/term-hash.lisp +++ /dev/null @@ -1,250 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/term-memory.abcl b/snark-20120808r02/src/term-memory.abcl deleted file mode 100644 index 07405f8..0000000 Binary files a/snark-20120808r02/src/term-memory.abcl and /dev/null differ diff --git a/snark-20120808r02/src/term-memory.lisp b/snark-20120808r02/src/term-memory.lisp deleted file mode 100644 index 686425c..0000000 --- a/snark-20120808r02/src/term-memory.lisp +++ /dev/null @@ -1,286 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/terms2.abcl b/snark-20120808r02/src/terms2.abcl deleted file mode 100644 index 848885d..0000000 Binary files a/snark-20120808r02/src/terms2.abcl and /dev/null differ diff --git a/snark-20120808r02/src/terms2.lisp b/snark-20120808r02/src/terms2.lisp deleted file mode 100644 index 10f9fcf..0000000 --- a/snark-20120808r02/src/terms2.lisp +++ /dev/null @@ -1,231 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/topological-sort.abcl b/snark-20120808r02/src/topological-sort.abcl deleted file mode 100644 index 997afcb..0000000 Binary files a/snark-20120808r02/src/topological-sort.abcl and /dev/null differ diff --git a/snark-20120808r02/src/topological-sort.lisp b/snark-20120808r02/src/topological-sort.lisp deleted file mode 100644 index 4292a4f..0000000 --- a/snark-20120808r02/src/topological-sort.lisp +++ /dev/null @@ -1,81 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/tptp-symbols.abcl b/snark-20120808r02/src/tptp-symbols.abcl deleted file mode 100644 index 539d079..0000000 Binary files a/snark-20120808r02/src/tptp-symbols.abcl and /dev/null differ diff --git a/snark-20120808r02/src/tptp-symbols.lisp b/snark-20120808r02/src/tptp-symbols.lisp deleted file mode 100644 index e363bfc..0000000 --- a/snark-20120808r02/src/tptp-symbols.lisp +++ /dev/null @@ -1,98 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/tptp.abcl b/snark-20120808r02/src/tptp.abcl deleted file mode 100644 index 0409087..0000000 Binary files a/snark-20120808r02/src/tptp.abcl and /dev/null differ diff --git a/snark-20120808r02/src/tptp.lisp b/snark-20120808r02/src/tptp.lisp deleted file mode 100644 index 9a202d3..0000000 --- a/snark-20120808r02/src/tptp.lisp +++ /dev/null @@ -1,645 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/trie-index.abcl b/snark-20120808r02/src/trie-index.abcl deleted file mode 100644 index 5580c33..0000000 Binary files a/snark-20120808r02/src/trie-index.abcl and /dev/null differ diff --git a/snark-20120808r02/src/trie-index.lisp b/snark-20120808r02/src/trie-index.lisp deleted file mode 100644 index a893a61..0000000 --- a/snark-20120808r02/src/trie-index.lisp +++ /dev/null @@ -1,574 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/trie.abcl b/snark-20120808r02/src/trie.abcl deleted file mode 100644 index ac06a72..0000000 Binary files a/snark-20120808r02/src/trie.abcl and /dev/null differ diff --git a/snark-20120808r02/src/trie.lisp b/snark-20120808r02/src/trie.lisp deleted file mode 100644 index 92f80ce..0000000 --- a/snark-20120808r02/src/trie.lisp +++ /dev/null @@ -1,101 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/unify-bag.abcl b/snark-20120808r02/src/unify-bag.abcl deleted file mode 100644 index 6df0a2b..0000000 Binary files a/snark-20120808r02/src/unify-bag.abcl and /dev/null differ diff --git a/snark-20120808r02/src/unify-bag.lisp b/snark-20120808r02/src/unify-bag.lisp deleted file mode 100644 index 871f701..0000000 --- a/snark-20120808r02/src/unify-bag.lisp +++ /dev/null @@ -1,859 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/unify-vector.abcl b/snark-20120808r02/src/unify-vector.abcl deleted file mode 100644 index 91c6ccd..0000000 Binary files a/snark-20120808r02/src/unify-vector.abcl and /dev/null differ diff --git a/snark-20120808r02/src/unify-vector.lisp b/snark-20120808r02/src/unify-vector.lisp deleted file mode 100644 index eab1dd0..0000000 --- a/snark-20120808r02/src/unify-vector.lisp +++ /dev/null @@ -1,135 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/unify.abcl b/snark-20120808r02/src/unify.abcl deleted file mode 100644 index dc4d05f..0000000 Binary files a/snark-20120808r02/src/unify.abcl and /dev/null differ diff --git a/snark-20120808r02/src/unify.lisp b/snark-20120808r02/src/unify.lisp deleted file mode 100644 index 50e3d27..0000000 --- a/snark-20120808r02/src/unify.lisp +++ /dev/null @@ -1,234 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/useful.abcl b/snark-20120808r02/src/useful.abcl deleted file mode 100644 index 2caf25d..0000000 Binary files a/snark-20120808r02/src/useful.abcl and /dev/null differ diff --git a/snark-20120808r02/src/useful.lisp b/snark-20120808r02/src/useful.lisp deleted file mode 100644 index 4bfb77f..0000000 --- a/snark-20120808r02/src/useful.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/variables.abcl b/snark-20120808r02/src/variables.abcl deleted file mode 100644 index 87f8043..0000000 Binary files a/snark-20120808r02/src/variables.abcl and /dev/null differ diff --git a/snark-20120808r02/src/variables.lisp b/snark-20120808r02/src/variables.lisp deleted file mode 100644 index 0f7794c..0000000 --- a/snark-20120808r02/src/variables.lisp +++ /dev/null @@ -1,77 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/variant.abcl b/snark-20120808r02/src/variant.abcl deleted file mode 100644 index 7cb0ab6..0000000 Binary files a/snark-20120808r02/src/variant.abcl and /dev/null differ diff --git a/snark-20120808r02/src/variant.lisp b/snark-20120808r02/src/variant.lisp deleted file mode 100644 index 8dab1b8..0000000 --- a/snark-20120808r02/src/variant.lisp +++ /dev/null @@ -1,148 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/weight.abcl b/snark-20120808r02/src/weight.abcl deleted file mode 100644 index 1fef2e0..0000000 Binary files a/snark-20120808r02/src/weight.abcl and /dev/null differ diff --git a/snark-20120808r02/src/weight.lisp b/snark-20120808r02/src/weight.lisp deleted file mode 100644 index cdb117a..0000000 --- a/snark-20120808r02/src/weight.lisp +++ /dev/null @@ -1,197 +0,0 @@ -;;; -*- 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/snark-20120808r02/src/wffs.abcl b/snark-20120808r02/src/wffs.abcl deleted file mode 100644 index 099805b..0000000 Binary files a/snark-20120808r02/src/wffs.abcl and /dev/null differ diff --git a/snark-20120808r02/src/wffs.lisp b/snark-20120808r02/src/wffs.lisp deleted file mode 100644 index 2468763..0000000 --- a/snark-20120808r02/src/wffs.lisp +++ /dev/null @@ -1,680 +0,0 @@ -;;; -*- 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