rairlab/Spectra
1
0
Fork 0
mirror of https://github.com/RAIRLab/Spectra.git synced 2024-11-21 16:36:29 -05:00
Code Issues Projects Releases Packages Wiki Activity

First commits.

Browse source
This commit is contained in:
Naveen Sundar Govindarajulu 2017-01-14 22:08:51 -05:00
parent ecd7c00454
commit 8c78a2f8e5
237 changed files with 36267 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
.gitignore vendored Normal file
View file

@ -0,0 +1,34 @@
planner.iml
.idea/compiler.xml
.idea/misc.xml
.idea/modules.xml
.idea/uiDesigner.xml
.idea/workspace.xml
.idea/libraries/Maven__com_beust_jcommander_1_27.xml
.idea/libraries/Maven__com_eclipsesource_j2v8_j2v8_linux_x86_64_3_0_2.xml
.idea/libraries/Maven__com_eclipsesource_j2v8_j2v8_macosx_x86_64_3_0_2.xml
.idea/libraries/Maven__com_eclipsesource_j2v8_j2v8_win32_x86_64_3_0_2.xml
.idea/libraries/Maven__com_kitfox_svg_svg_salamander_1_0.xml
.idea/libraries/Maven__guru_nidi_graphviz_java_0_0_2.xml
.idea/libraries/Maven__junit_junit_4_10.xml
.idea/libraries/Maven__logic_prover_0_09.xml
.idea/libraries/Maven__org_apache_commons_commons_lang3_3_4.xml
.idea/libraries/Maven__org_armedbear_lisp_abcl_1_0_1.xml
.idea/libraries/Maven__org_beanshell_bsh_2_0b4.xml
.idea/libraries/Maven__org_clojure_clojure_1_8_0.xml
.idea/libraries/Maven__org_hamcrest_hamcrest_core_1_1.xml
.idea/libraries/Maven__org_json_json_20160212.xml
.idea/libraries/Maven__org_testng_testng_6_8.xml
.idea/libraries/Maven__org_yaml_snakeyaml_1_6.xml
.idea/libraries/Maven__us_bpsm_edn_java_0_5_0.xml
target/classes/edu/rpi/rair/Action.class
target/classes/edu/rpi/rair/completeness_problems.clj
target/classes/edu/rpi/rair/DepthFirstPlanner.class
target/classes/edu/rpi/rair/Goal.class
target/classes/edu/rpi/rair/GoalTracker.class
target/classes/edu/rpi/rair/Operations.class
target/classes/edu/rpi/rair/Plan.class
target/classes/edu/rpi/rair/Planner.class
target/classes/edu/rpi/rair/State.class
target/classes/edu/rpi/rair/utils/PlanningProblem.class
target/test-classes/edu/rpi/rair/DepthFirstPlannerTest.class

36
pom.xml Normal file
View file

@ -0,0 +1,36 @@
<?xml version="1.0" encoding="UTF-8"?>
<project xmlns="http://maven.apache.org/POM/4.0.0"
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/xsd/maven-4.0.0.xsd">
<modelVersion>4.0.0</modelVersion>
<groupId>edu.rpi.rair</groupId>
<artifactId>planner</artifactId>
<version>0.01</version>
<dependencies>
<dependency>
<groupId>logic</groupId>
<artifactId>prover</artifactId>
<version>0.09</version>
</dependency>
<dependency>
<groupId>org.testng</groupId>
<artifactId>testng</artifactId>
<version>6.8</version>
<scope>test</scope>
</dependency>
<dependency>
<groupId>us.bpsm</groupId>
<artifactId>edn-java</artifactId>
<version>0.5.0</version>
</dependency>
</dependencies>
</project>

53
snark-20120808r02/INSTALL Normal file
View file

@ -0,0 +1,53 @@
SNARK is run regularly in
Macintosh Common Lisp on Mac OS X
Steel Bank Common Lisp (SBCL) on Mac OS X
Clozure Common Lisp (CCL nee OpenMCL) on Mac OS X
and has been run in other ANSI Common Lisp systems
After editing for the correct name and location of the SBCL Lisp system in the appropriate make-xxx file
a 32-bit executable of SNARK in SBCL named snark can be made by ./make-snark-sbcl;
a 64-bit executable of SNARK in SBCL named snark64 can be make by ./make-snark-sbcl64.
After editing for the correct name and location of the CCL Lisp system in the appropriate make-xxx file
a 32-bit executable of SNARK in CCL named snark-ccl can be made by ./make-snark-ccl;
a 64-bit executable of SNARK in CCL named snark-ccl64 can be maded by ./make-snark-ccl64
Older detailed instructions:
(replace "yyyymmdd" by the SNARK version date)
Installing SNARK:
tar xfz snark-yyyymmdd.tar.gz
cd snark-yyyymmdd
lisp
(load "snark-system.lisp")
(make-snark-system t) ;t specifies compilation
(make-snark-system t) ;compile again for more inlining (optional)
;can use :optimize instead of t to compile for
;higher speed at the expense of less error checking
(quit)
Running SNARK:
lisp
(load "snark-system.lisp")
(make-snark-system) ;loads SNARK files compiled above
:
The lengthy load process in running SNARK can be eliminated
for CCL, SBCL, CMUCL, Allegro Common Lisp, or CLISP by doing
lisp
(load "snark-system.lisp")
(make-snark-system)
(save-snark-system)
after installing SNARK as above.
(save-snark-system) will print instructions for running
the resulting Lisp core image with SNARK preloaded.
In the case of SBCL, (save-snark-system) can be replaced by
(save-snark-system :name "snark" :executable t)
to create a standalone SNARK executable. This is done
by the make-snark-sbcl and make-snark-sbcl64 scripts.

453
snark-20120808r02/LICENSE Normal file
View file

@ -0,0 +1,453 @@
MOZILLA PUBLIC LICENSE
Version 1.1
---------------
1. Definitions.
1.0.1. "Commercial Use" means distribution or otherwise making the
Covered Code available to a third party.
1.1. "Contributor" means each entity that creates or contributes to
the creation of Modifications.
1.2. "Contributor Version" means the combination of the Original
Code, prior Modifications used by a Contributor, and the Modifications
made by that particular Contributor.
1.3. "Covered Code" means the Original Code or Modifications or the
combination of the Original Code and Modifications, in each case
including portions thereof.
1.4. "Electronic Distribution Mechanism" means a mechanism generally
accepted in the software development community for the electronic
transfer of data.
1.5. "Executable" means Covered Code in any form other than Source
Code.
1.6. "Initial Developer" means the individual or entity identified
as the Initial Developer in the Source Code notice required by Exhibit
A.
1.7. "Larger Work" means a work which combines Covered Code or
portions thereof with code not governed by the terms of this License.
1.8. "License" means this document.
1.8.1. "Licensable" means having the right to grant, to the maximum
extent possible, whether at the time of the initial grant or
subsequently acquired, any and all of the rights conveyed herein.
1.9. "Modifications" means any addition to or deletion from the
substance or structure of either the Original Code or any previous
Modifications. When Covered Code is released as a series of files, a
Modification is:
A. Any addition to or deletion from the contents of a file
containing Original Code or previous Modifications.
B. Any new file that contains any part of the Original Code or
previous Modifications.
1.10. "Original Code" means Source Code of computer software code
which is described in the Source Code notice required by Exhibit A as
Original Code, and which, at the time of its release under this
License is not already Covered Code governed by this License.
1.10.1. "Patent Claims" means any patent claim(s), now owned or
hereafter acquired, including without limitation, method, process,
and apparatus claims, in any patent Licensable by grantor.
1.11. "Source Code" means the preferred form of the Covered Code for
making modifications to it, including all modules it contains, plus
any associated interface definition files, scripts used to control
compilation and installation of an Executable, or source code
differential comparisons against either the Original Code or another
well known, available Covered Code of the Contributor's choice. The
Source Code can be in a compressed or archival form, provided the
appropriate decompression or de-archiving software is widely available
for no charge.
1.12. "You" (or "Your") means an individual or a legal entity
exercising rights under, and complying with all of the terms of, this
License or a future version of this License issued under Section 6.1.
For legal entities, "You" includes any entity which controls, is
controlled by, or is under common control with You. For purposes of
this definition, "control" means (a) the power, direct or indirect,
to cause the direction or management of such entity, whether by
contract or otherwise, or (b) ownership of more than fifty percent
(50%) of the outstanding shares or beneficial ownership of such
entity.
2. Source Code License.
2.1. The Initial Developer Grant.
The Initial Developer hereby grants You a world-wide, royalty-free,
non-exclusive license, subject to third party intellectual property
claims:
(a) under intellectual property rights (other than patent or
trademark) Licensable by Initial Developer to use, reproduce,
modify, display, perform, sublicense and distribute the Original
Code (or portions thereof) with or without Modifications, and/or
as part of a Larger Work; and
(b) under Patents Claims infringed by the making, using or
selling of Original Code, to make, have made, use, practice,
sell, and offer for sale, and/or otherwise dispose of the
Original Code (or portions thereof).
(c) the licenses granted in this Section 2.1(a) and (b) are
effective on the date Initial Developer first distributes
Original Code under the terms of this License.
(d) Notwithstanding Section 2.1(b) above, no patent license is
granted: 1) for code that You delete from the Original Code; 2)
separate from the Original Code; or 3) for infringements caused
by: i) the modification of the Original Code or ii) the
combination of the Original Code with other software or devices.
2.2. Contributor Grant.
Subject to third party intellectual property claims, each Contributor
hereby grants You a world-wide, royalty-free, non-exclusive license
(a) under intellectual property rights (other than patent or
trademark) Licensable by Contributor, to use, reproduce, modify,
display, perform, sublicense and distribute the Modifications
created by such Contributor (or portions thereof) either on an
unmodified basis, with other Modifications, as Covered Code
and/or as part of a Larger Work; and
(b) under Patent Claims infringed by the making, using, or
selling of Modifications made by that Contributor either alone
and/or in combination with its Contributor Version (or portions
of such combination), to make, use, sell, offer for sale, have
made, and/or otherwise dispose of: 1) Modifications made by that
Contributor (or portions thereof); and 2) the combination of
Modifications made by that Contributor with its Contributor
Version (or portions of such combination).
(c) the licenses granted in Sections 2.2(a) and 2.2(b) are
effective on the date Contributor first makes Commercial Use of
the Covered Code.
(d) Notwithstanding Section 2.2(b) above, no patent license is
granted: 1) for any code that Contributor has deleted from the
Contributor Version; 2) separate from the Contributor Version;
3) for infringements caused by: i) third party modifications of
Contributor Version or ii) the combination of Modifications made
by that Contributor with other software (except as part of the
Contributor Version) or other devices; or 4) under Patent Claims
infringed by Covered Code in the absence of Modifications made by
that Contributor.
3. Distribution Obligations.
3.1. Application of License.
The Modifications which You create or to which You contribute are
governed by the terms of this License, including without limitation
Section 2.2. The Source Code version of Covered Code may be
distributed only under the terms of this License or a future version
of this License released under Section 6.1, and You must include a
copy of this License with every copy of the Source Code You
distribute. You may not offer or impose any terms on any Source Code
version that alters or restricts the applicable version of this
License or the recipients' rights hereunder. However, You may include
an additional document offering the additional rights described in
Section 3.5.
3.2. Availability of Source Code.
Any Modification which You create or to which You contribute must be
made available in Source Code form under the terms of this License
either on the same media as an Executable version or via an accepted
Electronic Distribution Mechanism to anyone to whom you made an
Executable version available; and if made available via Electronic
Distribution Mechanism, must remain available for at least twelve (12)
months after the date it initially became available, or at least six
(6) months after a subsequent version of that particular Modification
has been made available to such recipients. You are responsible for
ensuring that the Source Code version remains available even if the
Electronic Distribution Mechanism is maintained by a third party.
3.3. Description of Modifications.
You must cause all Covered Code to which You contribute to contain a
file documenting the changes You made to create that Covered Code and
the date of any change. You must include a prominent statement that
the Modification is derived, directly or indirectly, from Original
Code provided by the Initial Developer and including the name of the
Initial Developer in (a) the Source Code, and (b) in any notice in an
Executable version or related documentation in which You describe the
origin or ownership of the Covered Code.
3.4. Intellectual Property Matters
(a) Third Party Claims.
If Contributor has knowledge that a license under a third party's
intellectual property rights is required to exercise the rights
granted by such Contributor under Sections 2.1 or 2.2,
Contributor must include a text file with the Source Code
distribution titled "LEGAL" which describes the claim and the
party making the claim in sufficient detail that a recipient will
know whom to contact. If Contributor obtains such knowledge after
the Modification is made available as described in Section 3.2,
Contributor shall promptly modify the LEGAL file in all copies
Contributor makes available thereafter and shall take other steps
(such as notifying appropriate mailing lists or newsgroups)
reasonably calculated to inform those who received the Covered
Code that new knowledge has been obtained.
(b) Contributor APIs.
If Contributor's Modifications include an application programming
interface and Contributor has knowledge of patent licenses which
are reasonably necessary to implement that API, Contributor must
also include this information in the LEGAL file.
(c) Representations.
Contributor represents that, except as disclosed pursuant to
Section 3.4(a) above, Contributor believes that Contributor's
Modifications are Contributor's original creation(s) and/or
Contributor has sufficient rights to grant the rights conveyed by
this License.
3.5. Required Notices.
You must duplicate the notice in Exhibit A in each file of the Source
Code. If it is not possible to put such notice in a particular Source
Code file due to its structure, then You must include such notice in a
location (such as a relevant directory) where a user would be likely
to look for such a notice. If You created one or more Modification(s)
You may add your name as a Contributor to the notice described in
Exhibit A. You must also duplicate this License in any documentation
for the Source Code where You describe recipients' rights or ownership
rights relating to Covered Code. You may choose to offer, and to
charge a fee for, warranty, support, indemnity or liability
obligations to one or more recipients of Covered Code. However, You
may do so only on Your own behalf, and not on behalf of the Initial
Developer or any Contributor. You must make it absolutely clear than
any such warranty, support, indemnity or liability obligation is
offered by You alone, and You hereby agree to indemnify the Initial
Developer and every Contributor for any liability incurred by the
Initial Developer or such Contributor as a result of warranty,
support, indemnity or liability terms You offer.
3.6. Distribution of Executable Versions.
You may distribute Covered Code in Executable form only if the
requirements of Section 3.1-3.5 have been met for that Covered Code,
and if You include a notice stating that the Source Code version of
the Covered Code is available under the terms of this License,
including a description of how and where You have fulfilled the
obligations of Section 3.2. The notice must be conspicuously included
in any notice in an Executable version, related documentation or
collateral in which You describe recipients' rights relating to the
Covered Code. You may distribute the Executable version of Covered
Code or ownership rights under a license of Your choice, which may
contain terms different from this License, provided that You are in
compliance with the terms of this License and that the license for the
Executable version does not attempt to limit or alter the recipient's
rights in the Source Code version from the rights set forth in this
License. If You distribute the Executable version under a different
license You must make it absolutely clear that any terms which differ
from this License are offered by You alone, not by the Initial
Developer or any Contributor. You hereby agree to indemnify the
Initial Developer and every Contributor for any liability incurred by
the Initial Developer or such Contributor as a result of any such
terms You offer.
3.7. Larger Works.
You may create a Larger Work by combining Covered Code with other code
not governed by the terms of this License and distribute the Larger
Work as a single product. In such a case, You must make sure the
requirements of this License are fulfilled for the Covered Code.
4. Inability to Comply Due to Statute or Regulation.
If it is impossible for You to comply with any of the terms of this
License with respect to some or all of the Covered Code due to
statute, judicial order, or regulation then You must: (a) comply with
the terms of this License to the maximum extent possible; and (b)
describe the limitations and the code they affect. Such description
must be included in the LEGAL file described in Section 3.4 and must
be included with all distributions of the Source Code. Except to the
extent prohibited by statute or regulation, such description must be
sufficiently detailed for a recipient of ordinary skill to be able to
understand it.
5. Application of this License.
This License applies to code to which the Initial Developer has
attached the notice in Exhibit A and to related Covered Code.
6. Versions of the License.
6.1. New Versions.
Netscape Communications Corporation ("Netscape") may publish revised
and/or new versions of the License from time to time. Each version
will be given a distinguishing version number.
6.2. Effect of New Versions.
Once Covered Code has been published under a particular version of the
License, You may always continue to use it under the terms of that
version. You may also choose to use such Covered Code under the terms
of any subsequent version of the License published by Netscape. No one
other than Netscape has the right to modify the terms applicable to
Covered Code created under this License.
6.3. Derivative Works.
If You create or use a modified version of this License (which you may
only do in order to apply it to code which is not already Covered Code
governed by this License), You must (a) rename Your license so that
the phrases "Mozilla", "MOZILLAPL", "MOZPL", "Netscape",
"MPL", "NPL" or any confusingly similar phrase do not appear in your
license (except to note that your license differs from this License)
and (b) otherwise make it clear that Your version of the license
contains terms which differ from the Mozilla Public License and
Netscape Public License. (Filling in the name of the Initial
Developer, Original Code or Contributor in the notice described in
Exhibit A shall not of themselves be deemed to be modifications of
this License.)
7. DISCLAIMER OF WARRANTY.
COVERED CODE IS PROVIDED UNDER THIS LICENSE ON AN "AS IS" BASIS,
WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,
WITHOUT LIMITATION, WARRANTIES THAT THE COVERED CODE IS FREE OF
DEFECTS, MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE OR NON-INFRINGING.
THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE COVERED CODE
IS WITH YOU. SHOULD ANY COVERED CODE PROVE DEFECTIVE IN ANY RESPECT,
YOU (NOT THE INITIAL DEVELOPER OR ANY OTHER CONTRIBUTOR) ASSUME THE
COST OF ANY NECESSARY SERVICING, REPAIR OR CORRECTION. THIS DISCLAIMER
OF WARRANTY CONSTITUTES AN ESSENTIAL PART OF THIS LICENSE. NO USE OF
ANY COVERED CODE IS AUTHORIZED HEREUNDER EXCEPT UNDER THIS DISCLAIMER.
8. TERMINATION.
8.1. This License and the rights granted hereunder will terminate
automatically if You fail to comply with terms herein and fail to cure
such breach within 30 days of becoming aware of the breach. All
sublicenses to the Covered Code which are properly granted shall
survive any termination of this License. Provisions which, by their
nature, must remain in effect beyond the termination of this License
shall survive.
8.2. If You initiate litigation by asserting a patent infringement
claim (excluding declatory judgment actions) against Initial Developer
or a Contributor (the Initial Developer or Contributor against whom
You file such action is referred to as "Participant") alleging that:
(a) such Participant's Contributor Version directly or indirectly
infringes any patent, then any and all rights granted by such
Participant to You under Sections 2.1 and/or 2.2 of this License
shall, upon 60 days notice from Participant terminate prospectively,
unless if within 60 days after receipt of notice You either: (i)
agree in writing to pay Participant a mutually agreeable reasonable
royalty for Your past and future use of Modifications made by such
Participant, or (ii) withdraw Your litigation claim with respect to
the Contributor Version against such Participant. If within 60 days
of notice, a reasonable royalty and payment arrangement are not
mutually agreed upon in writing by the parties or the litigation claim
is not withdrawn, the rights granted by Participant to You under
Sections 2.1 and/or 2.2 automatically terminate at the expiration of
the 60 day notice period specified above.
(b) any software, hardware, or device, other than such Participant's
Contributor Version, directly or indirectly infringes any patent, then
any rights granted to You by such Participant under Sections 2.1(b)
and 2.2(b) are revoked effective as of the date You first made, used,
sold, distributed, or had made, Modifications made by that
Participant.
8.3. If You assert a patent infringement claim against Participant
alleging that such Participant's Contributor Version directly or
indirectly infringes any patent where such claim is resolved (such as
by license or settlement) prior to the initiation of patent
infringement litigation, then the reasonable value of the licenses
granted by such Participant under Sections 2.1 or 2.2 shall be taken
into account in determining the amount or value of any payment or
license.
8.4. In the event of termination under Sections 8.1 or 8.2 above,
all end user license agreements (excluding distributors and resellers)
which have been validly granted by You or any distributor hereunder
prior to termination shall survive termination.
9. LIMITATION OF LIABILITY.
UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, WHETHER TORT
(INCLUDING NEGLIGENCE), CONTRACT, OR OTHERWISE, SHALL YOU, THE INITIAL
DEVELOPER, ANY OTHER CONTRIBUTOR, OR ANY DISTRIBUTOR OF COVERED CODE,
OR ANY SUPPLIER OF ANY OF SUCH PARTIES, BE LIABLE TO ANY PERSON FOR
ANY INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES OF ANY
CHARACTER INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF GOODWILL,
WORK STOPPAGE, COMPUTER FAILURE OR MALFUNCTION, OR ANY AND ALL OTHER
COMMERCIAL DAMAGES OR LOSSES, EVEN IF SUCH PARTY SHALL HAVE BEEN
INFORMED OF THE POSSIBILITY OF SUCH DAMAGES. THIS LIMITATION OF
LIABILITY SHALL NOT APPLY TO LIABILITY FOR DEATH OR PERSONAL INJURY
RESULTING FROM SUCH PARTY'S NEGLIGENCE TO THE EXTENT APPLICABLE LAW
PROHIBITS SUCH LIMITATION. SOME JURISDICTIONS DO NOT ALLOW THE
EXCLUSION OR LIMITATION OF INCIDENTAL OR CONSEQUENTIAL DAMAGES, SO
THIS EXCLUSION AND LIMITATION MAY NOT APPLY TO YOU.
10. U.S. GOVERNMENT END USERS.
The Covered Code is a "commercial item," as that term is defined in
48 C.F.R. 2.101 (Oct. 1995), consisting of "commercial computer
software" and "commercial computer software documentation," as such
terms are used in 48 C.F.R. 12.212 (Sept. 1995). Consistent with 48
C.F.R. 12.212 and 48 C.F.R. 227.7202-1 through 227.7202-4 (June 1995),
all U.S. Government End Users acquire Covered Code with only those
rights set forth herein.
11. MISCELLANEOUS.
This License represents the complete agreement concerning subject
matter hereof. If any provision of this License is held to be
unenforceable, such provision shall be reformed only to the extent
necessary to make it enforceable. This License shall be governed by
California law provisions (except to the extent applicable law, if
any, provides otherwise), excluding its conflict-of-law provisions.
With respect to disputes in which at least one party is a citizen of,
or an entity chartered or registered to do business in the United
States of America, any litigation relating to this License shall be
subject to the jurisdiction of the Federal Courts of the Northern
District of California, with venue lying in Santa Clara County,
California, with the losing party responsible for costs, including
without limitation, court costs and reasonable attorneys' fees and
expenses. The application of the United Nations Convention on
Contracts for the International Sale of Goods is expressly excluded.
Any law or regulation which provides that the language of a contract
shall be construed against the drafter shall not apply to this
License.
12. RESPONSIBILITY FOR CLAIMS.
As between Initial Developer and the Contributors, each party is
responsible for claims and damages arising, directly or indirectly,
out of its utilization of rights under this License and You agree to
work with Initial Developer and Contributors to distribute such
responsibility on an equitable basis. Nothing herein is intended or
shall be deemed to constitute any admission of liability.
13. MULTIPLE-LICENSED CODE.
Initial Developer may designate portions of the Covered Code as
"Multiple-Licensed". "Multiple-Licensed" means that the Initial
Developer permits you to utilize portions of the Covered Code under
Your choice of the NPL or the alternative licenses, if any, specified
by the Initial Developer in the file described in Exhibit A.
EXHIBIT A -Mozilla Public License.
``The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/
Software distributed under the License is distributed on an "AS IS"
basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
License for the specific language governing rights and limitations
under the License.
The Original Code is SNARK.
The Initial Developer of the Original Code is SRI International.
Portions created by the Initial Developer are Copyright (C) 1981-2011.
All Rights Reserved.
Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.

36
snark-20120808r02/README Normal file
View file

@ -0,0 +1,36 @@
(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.

4
snark-20120808r02/compile Normal file
View file

@ -0,0 +1,4 @@
(load "snark-system.lisp")
(make-snark-system t)
(make-snark-system :optimize)
(quit)

47
snark-20120808r02/examples/BOO002-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,47 @@
;--------------------------------------------------------------------------
; File : BOO002-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Boolean Algebra (Ternary)
; Problem : In B3 algebra, X * X^-1 * Y = Y
; Version : [OTTER] (equality) axioms : Reduced > Incomplete.
; English :
; Refs : [LO85] Lusk & Overbeek (1985), Reasoning about Equality
; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [Ove90]
; Names : Problem 5 [LO85]
; : CADE-11 Competition Eq-3 [Ove90]
; : THEOREM EQ-3 [LM93]
; : PROBLEM 3 [Zha93]
; Status : unsatisfiable
; Rating : 0.33 v2.2.0, 0.43 v2.1.0, 0.38 v2.0.0
; Syntax : Number of clauses : 5 ( 0 non-Horn; 5 unit; 1 RR)
; Number of literals : 5 ( 5 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 4 ( 2 constant; 0-3 arity)
; Number of variables : 11 ( 2 singleton)
; Maximal term depth : 3 ( 2 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp BOO002-1.p
;--------------------------------------------------------------------------
; associativity, axiom.
(or (= (multiply (multiply ?A ?B ?C) ?D (multiply ?A ?B ?E)) (multiply ?A ?B (multiply ?C ?D ?E))))
; ternary_multiply_1, axiom.
(or (= (multiply ?A ?B ?B) ?B))
; ternary_multiply_2, axiom.
(or (= (multiply ?A ?A ?B) ?A))
; left_inverse, axiom.
(or (= (multiply (inverse ?A) ?A ?B) ?B))
; prove_equation, conjecture.
(or (/= (multiply a (inverse a) b) b))
;--------------------------------------------------------------------------

53
snark-20120808r02/examples/COL003-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,53 @@
;--------------------------------------------------------------------------
; File : COL003-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Combinatory Logic
; Problem : Strong fixed point for B and W
; Version : [WM88] (equality) axioms.
; English : The strong fixed point property holds for the set
; P consisting of the combinators B and W alone, where ((Bx)y)z
; = x(yz) and (Wx)y = (xy)y.
; Refs : [Smu85] Smullyan (1978), To Mock a Mocking Bird and Other Logi
; : [MW87] McCune & Wos (1987), A Case Study in Automated Theorem
; : [WM88] Wos & McCune (1988), Challenge Problems Focusing on Eq
; : [Wos88] Wos (1988), Automated Reasoning - 33 Basic Research Pr
; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [LW92] Lusk & Wos (1992), Benchmark Problems in Which Equalit
; : [Wos93] Wos (1993), The Kernel Strategy and Its Use for the St
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [WM88]
; Names : C2 [WM88]
; : Test Problem 17 [Wos88]
; : Sages and Combinatory Logic [Wos88]
; : CADE-11 Competition Eq-8 [Ove90]
; : CL2 [LW92]
; : THEOREM EQ-8 [LM93]
; : Question 3 [Wos93]
; : Question 5 [Wos93]
; : PROBLEM 8 [Zha93]
; Status : unknown
; Rating : 1.00 v2.0.0
; Syntax : Number of clauses : 3 ( 0 non-Horn; 3 unit; 1 RR)
; Number of literals : 3 ( 3 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 4 ( 2 constant; 0-2 arity)
; Number of variables : 6 ( 0 singleton)
; Maximal term depth : 4 ( 3 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp COL003-1.p
;--------------------------------------------------------------------------
; b_definition, axiom.
(or (= (apply (apply (apply b ?A) ?B) ?C) (apply ?A (apply ?B ?C))))
; w_definition, axiom.
(or (= (apply (apply w ?A) ?B) (apply (apply ?A ?B) ?B)))
; prove_strong_fixed_point, conjecture.
(or (/= (apply ?A (f ?A)) (apply (f ?A) (apply ?A (f ?A)))))
;--------------------------------------------------------------------------

52
snark-20120808r02/examples/COL049-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,52 @@
;--------------------------------------------------------------------------
; File : COL049-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Combinatory Logic
; Problem : Strong fixed point for B, W, and M
; Version : [WM88] (equality) axioms.
; English : The strong fixed point property holds for the set
; P consisting of the combinators B, W, and M, where ((Bx)y)z
; = x(yz), (Wx)y = (xy)y, Mx = xx.
; Refs : [Smu85] Smullyan (1978), To Mock a Mocking Bird and Other Logi
; : [MW87] McCune & Wos (1987), A Case Study in Automated Theorem
; : [WM88] Wos & McCune (1988), Challenge Problems Focusing on Eq
; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [LW92] Lusk & Wos (1992), Benchmark Problems in Which Equalit
; : [Wos93] Wos (1993), The Kernel Strategy and Its Use for the St
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [Ove90]
; Names : Problem 2 [WM88]
; : CADE-11 Competition Eq-6 [Ove90]
; : CL1 [LW92]
; : THEOREM EQ-6 [LM93]
; : Question 2 [Wos93]
; : PROBLEM 6 [Zha93]
; Status : unsatisfiable
; Rating : 0.22 v2.2.0, 0.14 v2.1.0, 0.62 v2.0.0
; Syntax : Number of clauses : 4 ( 0 non-Horn; 4 unit; 1 RR)
; Number of literals : 4 ( 4 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 5 ( 3 constant; 0-2 arity)
; Number of variables : 7 ( 0 singleton)
; Maximal term depth : 4 ( 3 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp COL049-1.p
;--------------------------------------------------------------------------
; b_definition, axiom.
(or (= (apply (apply (apply b ?A) ?B) ?C) (apply ?A (apply ?B ?C))))
; w_definition, axiom.
(or (= (apply (apply w ?A) ?B) (apply (apply ?A ?B) ?B)))
; m_definition, axiom.
(or (= (apply m ?A) (apply ?A ?A)))
; prove_strong_fixed_point, conjecture.
(or (/= (apply ?A (f ?A)) (apply (f ?A) (apply ?A (f ?A)))))
;--------------------------------------------------------------------------

78
snark-20120808r02/examples/GRP001-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,78 @@
;--------------------------------------------------------------------------
; File : GRP001-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Group Theory
; Problem : X^2 = identity => commutativity
; Version : [MOW76] axioms.
; English : If the square of every element is the identity, the system
; is commutative.
; Refs : [Rob63] Robinson (1963), Theorem Proving on the Computer
; : [Wos65] Wos (1965), Unpublished Note
; : [MOW76] McCharen et al. (1976), Problems and Experiments for a
; : [WM76] Wilson & Minker (1976), Resolution, Refinements, and S
; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; Source : [MOW76]
; Names : - [Rob63]
; : wos10 [WM76]
; : G1 [MOW76]
; : CADE-11 Competition 1 [Ove90]
; : THEOREM 1 [LM93]
; : xsquared.ver1.in [ANL]
; Status : unsatisfiable
; Rating : 0.00 v2.0.0
; Syntax : Number of clauses : 11 ( 0 non-Horn; 8 unit; 5 RR)
; Number of literals : 19 ( 1 equality)
; Maximal clause size : 4 ( 1 average)
; Number of predicates : 2 ( 0 propositional; 2-3 arity)
; Number of functors : 6 ( 4 constant; 0-2 arity)
; Number of variables : 23 ( 0 singleton)
; Maximal term depth : 2 ( 1 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp GRP001-1.p
;--------------------------------------------------------------------------
; left_identity, axiom.
(or (product identity ?A ?A))
; right_identity, axiom.
(or (product ?A identity ?A))
; left_inverse, axiom.
(or (product (inverse ?A) ?A identity))
; right_inverse, axiom.
(or (product ?A (inverse ?A) identity))
; total_function1, axiom.
(or (product ?A ?B (multiply ?A ?B)))
; total_function2, axiom.
(or (not (product ?A ?B ?C))
(not (product ?A ?B ?D))
(= ?C ?D))
; associativity1, axiom.
(or (not (product ?A ?B ?C))
(not (product ?B ?D ?E))
(not (product ?C ?D ?F))
(product ?A ?E ?F))
; associativity2, axiom.
(or (not (product ?A ?B ?C))
(not (product ?B ?D ?E))
(not (product ?A ?E ?F))
(product ?C ?D ?F))
; square_element, hypothesis.
(or (product ?A ?A identity))
; a_times_b_is_c, hypothesis.
(or (product a b c))
; prove_b_times_a_is_c, conjecture.
(or (not (product b a c)))
;--------------------------------------------------------------------------

98
snark-20120808r02/examples/GRP002-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,98 @@
;--------------------------------------------------------------------------
; File : GRP002-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Group Theory
; Problem : Commutator equals identity in groups of order 3
; Version : [MOW76] axioms.
; English : In a group, if (for all x) the cube of x is the identity
; (i.e. a group of order 3), then the equation [[x,y],y]=
; identity holds, where [x,y] is the product of x, y, the
; inverse of x and the inverse of y (i.e. the commutator
; of x and y).
; Refs : [MOW76] McCharen et al. (1976), Problems and Experiments for a
; : [OMW76] Overbeek et al. (1976), Complexity and Related Enhance
; : [Wos88] Wos (1988), Automated Reasoning - 33 Basic Research Pr
; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; Source : [MOW76]
; Names : G6 [MOW76]
; : Theorem 1 [OMW76]
; : Test Problem 2 [Wos88]
; : Commutator Theorem [Wos88]
; : CADE-11 Competition 2 [Ove90]
; : THEOREM 2 [LM93]
; : commutator.ver1.in [ANL]
; Status : unsatisfiable
; Rating : 0.67 v2.2.0, 0.71 v2.1.0, 1.00 v2.0.0
; Syntax : Number of clauses : 16 ( 0 non-Horn; 11 unit; 11 RR)
; Number of literals : 26 ( 1 equality)
; Maximal clause size : 4 ( 1 average)
; Number of predicates : 2 ( 0 propositional; 2-3 arity)
; Number of functors : 10 ( 8 constant; 0-2 arity)
; Number of variables : 26 ( 0 singleton)
; Maximal term depth : 2 ( 1 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp GRP002-1.p
;--------------------------------------------------------------------------
; left_identity, axiom.
(or (product identity ?A ?A))
; right_identity, axiom.
(or (product ?A identity ?A))
; left_inverse, axiom.
(or (product (inverse ?A) ?A identity))
; right_inverse, axiom.
(or (product ?A (inverse ?A) identity))
; total_function1, axiom.
(or (product ?A ?B (multiply ?A ?B)))
; total_function2, axiom.
(or (not (product ?A ?B ?C))
(not (product ?A ?B ?D))
(= ?C ?D))
; associativity1, axiom.
(or (not (product ?A ?B ?C))
(not (product ?B ?D ?E))
(not (product ?C ?D ?F))
(product ?A ?E ?F))
; associativity2, axiom.
(or (not (product ?A ?B ?C))
(not (product ?B ?D ?E))
(not (product ?A ?E ?F))
(product ?C ?D ?F))
; x_cubed_is_identity_1, hypothesis.
(or (not (product ?A ?A ?B))
(product ?A ?B identity))
; x_cubed_is_identity_2, hypothesis.
(or (not (product ?A ?A ?B))
(product ?B ?A identity))
; a_times_b_is_c, conjecture.
(or (product a b c))
; c_times_inverse_a_is_d, conjecture.
(or (product c (inverse a) d))
; d_times_inverse_b_is_h, conjecture.
(or (product d (inverse b) h))
; h_times_b_is_j, conjecture.
(or (product h b j))
; j_times_inverse_h_is_k, conjecture.
(or (product j (inverse h) k))
; prove_k_times_inverse_b_is_e, conjecture.
(or (not (product k (inverse b) identity)))
;--------------------------------------------------------------------------

53
snark-20120808r02/examples/GRP002-3+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,53 @@
;--------------------------------------------------------------------------
; File : GRP002-3 : TPTP v2.2.0. Released v1.0.0.
; Domain : Group Theory
; Problem : Commutator equals identity in groups of order 3
; Version : [Ove90] (equality) axioms : Incomplete.
; English : In a group, if (for all x) the cube of x is the identity
; (i.e. a group of order 3), then the equation [[x,y],y]=
; identity holds, where [x,y] is the product of x, y, the
; inverse of x and the inverse of y (i.e. the commutator
; of x and y).
; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [Ove90]
; Names : CADE-11 Competition Eq-1 [Ove90]
; : THEOREM EQ-1 [LM93]
; : PROBLEM 1 [Zha93]
; : comm.in [OTTER]
; Status : unsatisfiable
; Rating : 0.33 v2.2.0, 0.43 v2.1.0, 0.25 v2.0.0
; Syntax : Number of clauses : 6 ( 0 non-Horn; 6 unit; 1 RR)
; Number of literals : 6 ( 6 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 6 ( 3 constant; 0-2 arity)
; Number of variables : 8 ( 0 singleton)
; Maximal term depth : 5 ( 2 average)
; Comments : Uses an explicit formulation of the commutator.
; : tptp2X -f kif -t rm_equality:rstfp GRP002-3.p
;--------------------------------------------------------------------------
; left_identity, axiom.
(or (= (multiply identity ?A) ?A))
; left_inverse, axiom.
(or (= (multiply (inverse ?A) ?A) identity))
; associativity, axiom.
(or (= (multiply (multiply ?A ?B) ?C) (multiply ?A (multiply ?B ?C))))
; commutator, axiom.
(or (= (commutator ?A ?B) (multiply ?A (multiply ?B (multiply (inverse ?A) (inverse ?B))))))
; x_cubed_is_identity, hypothesis.
(or (= (multiply ?A (multiply ?A ?A)) identity))
; prove_commutator, conjecture.
(or (/= (commutator (commutator a b) b) identity))
;--------------------------------------------------------------------------

38
snark-20120808r02/examples/GRP014-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,38 @@
;--------------------------------------------------------------------------
; File : GRP014-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Group Theory
; Problem : Product is associative in this group theory
; Version : [Ove90] (equality) axioms : Incomplete.
; English : The group theory specified by the axiom given implies the
; associativity of multiply.
; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [Ove90]
; Names : CADE-11 Competition Eq-4 [Ove90]
; : THEOREM EQ-4 [LM93]
; : PROBLEM 4 [Zha93]
; Status : unsatisfiable
; Rating : 0.33 v2.2.0, 0.43 v2.1.0, 0.50 v2.0.0
; Syntax : Number of clauses : 2 ( 0 non-Horn; 2 unit; 1 RR)
; Number of literals : 2 ( 2 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 5 ( 3 constant; 0-2 arity)
; Number of variables : 4 ( 0 singleton)
; Maximal term depth : 9 ( 4 average)
; Comments : The group_axiom is in fact a single axiom for group theory
; [LM93].
; : tptp2X -f kif -t rm_equality:rstfp GRP014-1.p
;--------------------------------------------------------------------------
; group_axiom, axiom.
(or (= (multiply ?A (inverse (multiply (multiply (inverse (multiply (inverse ?B) (multiply (inverse ?A) ?C))) ?D) (inverse (multiply ?B ?D))))) ?C))
; prove_associativity, conjecture.
(or (/= (multiply a (multiply b c)) (multiply (multiply a b) c)))
;--------------------------------------------------------------------------

44
snark-20120808r02/examples/LCL024-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,44 @@
;--------------------------------------------------------------------------
; File : LCL024-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Logic Calculi (Equivalential)
; Problem : PYO depends on XGK
; Version : [Ove90] axioms.
; English : Show that Kalman's shortest single axiom for the
; equivalential calculus, XGK, can be derived from the Meredith
; single axiom PYO.
; Refs : [Wos88] Wos (1988), Automated Reasoning - 33 Basic Research Pr
; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; Source : [Ove90]
; Names : Test Problem 16 [Wos88]
; : XGK and Equivalential Calculus [Wos88]
; : CADE-11 Competition 4 [Ove90]
; : THEOREM 4 [LM93]
; Status : unsatisfiable
; Rating : 0.78 v2.2.0, 0.89 v2.1.0, 0.75 v2.0.0
; Syntax : Number of clauses : 3 ( 0 non-Horn; 2 unit; 2 RR)
; Number of literals : 5 ( 0 equality)
; Maximal clause size : 3 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 1-1 arity)
; Number of functors : 4 ( 3 constant; 0-2 arity)
; Number of variables : 5 ( 0 singleton)
; Maximal term depth : 5 ( 2 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp LCL024-1.p
;--------------------------------------------------------------------------
; condensed_detachment, axiom.
(or (not (is_a_theorem (equivalent ?A ?B)))
(not (is_a_theorem ?A))
(is_a_theorem ?B))
; prove_xgk, axiom.
(or (is_a_theorem (equivalent ?A (equivalent (equivalent ?B (equivalent ?C ?A)) (equivalent ?C ?B)))))
; prove_pyo, conjecture.
(or (not (is_a_theorem (equivalent (equivalent (equivalent a (equivalent b c)) c) (equivalent b a)))))
;--------------------------------------------------------------------------

42
snark-20120808r02/examples/LCL038-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,42 @@
;--------------------------------------------------------------------------
; File : LCL038-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Logic Calculi (Implication/Falsehood 2 valued sentential)
; Problem : C0-1 depends on a single axiom
; Version : [McC92] axioms.
; English : An axiomatisation for the Implication/Falsehood 2 valued
; sentential calculus is {C0-1,C0-2,C0-3,C0-4}
; by Tarski-Bernays. Show that C0-1 can be derived from this
; suspected single axiom.
; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; Source : [Ove90]
; Names : CADE-11 Competition 5 [Ove90]
; : THEOREM 5 [LM93]
; Status : unsatisfiable
; Rating : 0.89 v2.2.0, 1.00 v2.0.0
; Syntax : Number of clauses : 3 ( 0 non-Horn; 2 unit; 2 RR)
; Number of literals : 5 ( 0 equality)
; Maximal clause size : 3 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 1-1 arity)
; Number of functors : 4 ( 3 constant; 0-2 arity)
; Number of variables : 6 ( 2 singleton)
; Maximal term depth : 4 ( 2 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp LCL038-1.p
;--------------------------------------------------------------------------
; condensed_detachment, axiom.
(or (not (is_a_theorem (implies ?A ?B)))
(not (is_a_theorem ?A))
(is_a_theorem ?B))
; single_axiom, axiom.
(or (is_a_theorem (implies (implies (implies ?A ?B) ?C) (implies (implies ?C ?A) (implies ?D ?A)))))
; prove_c0_1, conjecture.
(or (not (is_a_theorem (implies (implies a b) (implies (implies b c) (implies a c))))))
;--------------------------------------------------------------------------

54
snark-20120808r02/examples/LCL109-2+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,54 @@
;--------------------------------------------------------------------------
; File : LCL109-2 : TPTP v2.2.0. Released v1.0.0.
; Domain : Logic Calculi (Many valued sentential)
; Problem : MV-4 depends on the Merideth system
; Version : [Ove90] axioms.
; Theorem formulation : Wajsberg algebra formulation.
; English : An axiomatisation of the many valued sentential calculus
; is {MV-1,MV-2,MV-3,MV-5} by Meredith. Wajsberg provided
; a different axiomatisation. Show that MV-4 depends on the
; Wajsberg system.
; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [LM92] Lusk & McCune (1992), Experiments with ROO, a Parallel
; : [LW92] Lusk & Wos (1992), Benchmark Problems in Which Equalit
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [Ove90]
; Names : CADE-11 Competition Eq-5 [Ove90]
; : Luka-5 [LM92]
; : MV4 [LW92]
; : THEOREM EQ-5 [LM93]
; : PROBLEM 5 [Zha93]
; Status : unsatisfiable
; Rating : 0.56 v2.2.0, 0.71 v2.1.0, 1.00 v2.0.0
; Syntax : Number of clauses : 5 ( 0 non-Horn; 5 unit; 1 RR)
; Number of literals : 5 ( 5 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 5 ( 3 constant; 0-2 arity)
; Number of variables : 8 ( 0 singleton)
; Maximal term depth : 4 ( 2 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp LCL109-2.p
; ; 'true' renamed to 'true0' - MES
;--------------------------------------------------------------------------
; wajsberg_1, axiom.
(or (= (implies true0 ?A) ?A))
; wajsberg_2, axiom.
(or (= (implies (implies ?A ?B) (implies (implies ?B ?C) (implies ?A ?C))) true0))
; wajsberg_3, axiom.
(or (= (implies (implies ?A ?B) ?B) (implies (implies ?B ?A) ?A)))
; wajsberg_4, axiom.
(or (= (implies (implies (not ?A) (not ?B)) (implies ?B ?A)) true0))
; prove_wajsberg_mv_4, conjecture.
(or (/= (implies (implies (implies a b) (implies b a)) (implies b a)) true0))
;--------------------------------------------------------------------------

55
snark-20120808r02/examples/LCL111-1.tptp Normal file
View file

@ -0,0 +1,55 @@
%------------------------------------------------------------------------------
% File : LCL111-1 : TPTP v3.0.0. Released v1.0.0.
% Domain : Logic Calculi (Many valued sentential)
% Problem : MV-25 depends on the Merideth system
% Version : [McC92] axioms.
% English : An axiomatisation of the many valued sentential calculus
% is {MV-1,MV-2,MV-3,MV-5} by Meredith. Show that MV-25 depends
% on the Meredith system.
% Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
% : [MW92] McCune & Wos (1992), Experiments in Automated Deductio
% : [McC92] McCune (1992), Email to G. Sutcliffe
% : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
% : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
% Source : [McC92]
% Names : CADE-11 Competition 6 [Ove90]
% : MV-57 [MW92]
% : THEOREM 6 [LM93]
% : mv.in part 2 [OTTER]
% : mv25.in [OTTER]
% : ovb6 [SETHEO]
% Status : Unsatisfiable
% Rating : 0.00 v2.4.0, 0.43 v2.3.0, 0.14 v2.2.1, 0.11 v2.2.0, 0.22 v2.1.0, 0.25 v2.0.0
% Syntax : Number of clauses : 6 ( 0 non-Horn; 5 unit; 2 RR)
% Number of atoms : 8 ( 0 equality)
% Maximal clause size : 3 ( 1 average)
% Number of predicates : 1 ( 0 propositional; 1-1 arity)
% Number of functors : 5 ( 3 constant; 0-2 arity)
% Number of variables : 11 ( 1 singleton)
% Maximal term depth : 4 ( 3 average)
% Comments :
% : tptp2X -f tptp:short LCL111-1.p
%------------------------------------------------------------------------------
cnf(condensed_detachment,axiom,(
~ is_a_theorem(implies(X,Y))
| ~ is_a_theorem(X)
| is_a_theorem(Y) )).
cnf(mv_1,axiom,(
is_a_theorem(implies(X,implies(Y,X))) )).
cnf(mv_2,axiom,(
is_a_theorem(implies(implies(X,Y),implies(implies(Y,Z),implies(X,Z)))) )).
cnf(mv_3,axiom,(
is_a_theorem(implies(implies(implies(X,Y),Y),implies(implies(Y,X),X))) )).
cnf(mv_5,axiom,(
is_a_theorem(implies(implies(not(X),not(Y)),implies(Y,X))) )).
cnf(prove_mv_25,negated_conjecture,(
~ is_a_theorem(implies(implies(a,b),implies(implies(c,a),implies(c,b)))) )).
%------------------------------------------------------------------------------

53
snark-20120808r02/examples/LCL114-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,53 @@
;--------------------------------------------------------------------------
; File : LCL114-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Logic Calculi (Many valued sentential)
; Problem : MV-36 depnds on the Merideth system
; Version : [McC92] axioms.
; English : An axiomatisation of the many valued sentential calculus
; is {MV-1,MV-2,MV-3,MV-5} by Meredith. Show that 36 depends
; on the Meredith system.
; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [MW92] McCune & Wos (1992), Experiments in Automated Deductio
; : [McC92] McCune (1992), Email to G. Sutcliffe
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; Source : [McC92]
; Names : CADE-11 Competition 7 [Ove90]
; : MV-60 [MW92]
; : THEOREM 7 [LM93]
; Status : unsatisfiable
; Rating : 0.89 v2.1.0, 0.88 v2.0.0
; Syntax : Number of clauses : 6 ( 0 non-Horn; 5 unit; 2 RR)
; Number of literals : 8 ( 0 equality)
; Maximal clause size : 3 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 1-1 arity)
; Number of functors : 4 ( 2 constant; 0-2 arity)
; Number of variables : 11 ( 1 singleton)
; Maximal term depth : 4 ( 2 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp LCL114-1.p
;--------------------------------------------------------------------------
; condensed_detachment, axiom.
(or (not (is_a_theorem (implies ?A ?B)))
(not (is_a_theorem ?A))
(is_a_theorem ?B))
; mv_1, axiom.
(or (is_a_theorem (implies ?A (implies ?B ?A))))
; mv_2, axiom.
(or (is_a_theorem (implies (implies ?A ?B) (implies (implies ?B ?C) (implies ?A ?C)))))
; mv_3, axiom.
(or (is_a_theorem (implies (implies (implies ?A ?B) ?B) (implies (implies ?B ?A) ?A))))
; mv_5, axiom.
(or (is_a_theorem (implies (implies (not ?A) (not ?B)) (implies ?B ?A))))
; prove_mv_36, conjecture.
(or (not (is_a_theorem (implies (implies a b) (implies (not b) (not a))))))
;--------------------------------------------------------------------------

155
snark-20120808r02/examples/PUZ031+1.kif Normal file
View file

@ -0,0 +1,155 @@
;--------------------------------------------------------------------------
; File : PUZ031+1 : TPTP v2.2.0. Released v2.0.0.
; Domain : Puzzles
; Problem : Schubert's Steamroller
; Version : Especial.
; English : Wolves, foxes, birds, caterpillars, and snails are animals, and
; there are some of each of them. Also there are some grains, and
; grains are plants. Every animal either likes to eat all plants
; or all animals much smaller than itself that like to eat some
; plants. Caterpillars and snails are much smaller than birds,
; which are much smaller than foxes, which in turn are much
; smaller than wolves. Wolves do not like to eat foxes or grains,
; while birds like to eat caterpillars but not snails.
; Caterpillars and snails like to eat some plants. Therefore
; there is an animal that likes to eat a grain eating animal.
; Refs : [Pel86] Pelletier (1986), Seventy-five Problems for Testing Au
; : [Hah94] Haehnle (1994), Email to G. Sutcliffe
; Source : [Hah94]
; Names : Pelletier 47 [Pel86]
; Status : theorem
; Rating : 0.00 v2.1.0
; Syntax : Number of formulae : 21 ( 6 unit)
; Number of atoms : 55 ( 0 equality)
; Maximal formula depth : 9 ( 3 average)
; Number of connectives : 36 ( 2 ~ ; 4 |; 14 &)
; ( 0 <=>; 16 =>; 0 <=)
; ( 0 <~>; 0 ~|; 0 ~&)
; Number of predicates : 10 ( 0 propositional; 1-2 arity)
; Number of functors : 0 ( 0 constant; --- arity)
; Number of variables : 33 ( 0 singleton; 22 !; 11 ?)
; Maximal term depth : 1 ( 1 average)
; Comments : This problem is named after Len Schubert.
; : tptp2X -f kif PUZ031+1.p
;--------------------------------------------------------------------------
; pel47_1_1, axiom.
(forall (?A)
(=> (wolf ?A)
(animal ?A) ) )
; pel47_1_2, axiom.
(exists (?A)(wolf ?A) )
; pel47_2_1, axiom.
(forall (?A)
(=> (fox ?A)
(animal ?A) ) )
; pel47_2_2, axiom.
(exists (?A)(fox ?A) )
; pel47_3_1, axiom.
(forall (?A)
(=> (bird ?A)
(animal ?A) ) )
; pel47_3_2, axiom.
(exists (?A)(bird ?A) )
; pel47_4_1, axiom.
(forall (?A)
(=> (caterpillar ?A)
(animal ?A) ) )
; pel47_4_2, axiom.
(exists (?A)(caterpillar ?A) )
; pel47_5_1, axiom.
(forall (?A)
(=> (snail ?A)
(animal ?A) ) )
; pel47_5_2, axiom.
(exists (?A)(snail ?A) )
; pel47_6_1, axiom.
(exists (?A)(grain ?A) )
; pel47_6_2, axiom.
(forall (?A)
(=> (grain ?A)
(plant ?A) ) )
; pel47_7, axiom.
(forall (?A)
(=> (animal ?A)
(or (forall (?B)
(=> (plant ?B)
(eats ?A ?B) ) )
(forall (?C)
(=> (and (and (animal ?C)
(much_smaller ?C ?A) )
(exists (?D)
(and (plant ?D)
(eats ?C ?D) ) ) )
(eats ?A ?C) ) ) ) ) )
; pel47_8, axiom.
(forall (?A ?B)
(=> (and (bird ?B)
(or (snail ?A)
(caterpillar ?A) ) )
(much_smaller ?A ?B) ) )
; pel47_9, axiom.
(forall (?A ?B)
(=> (and (bird ?A)
(fox ?B) )
(much_smaller ?A ?B) ) )
; pel47_10, axiom.
(forall (?A ?B)
(=> (and (fox ?A)
(wolf ?B) )
(much_smaller ?A ?B) ) )
; pel47_11, axiom.
(forall (?A ?B)
(=> (and (wolf ?A)
(or (fox ?B)
(grain ?B) ) )
(not (eats ?A ?B) ) ) )
; pel47_12, axiom.
(forall (?A ?B)
(=> (and (bird ?A)
(caterpillar ?B) )
(eats ?A ?B) ) )
; pel47_13, axiom.
(forall (?A ?B)
(=> (and (bird ?A)
(snail ?B) )
(not (eats ?A ?B) ) ) )
; pel47_14, axiom.
(forall (?A)
(=> (or (caterpillar ?A)
(snail ?A) )
(exists (?B)
(and (plant ?B)
(eats ?A ?B) ) ) ) )
; pel47, conjecture.
(not (exists (?A ?B)
(and (and (animal ?A)
(animal ?B) )
(exists (?C)
(and (and (grain ?C)
(eats ?B ?C) )
(eats ?A ?B) ) ) ) ) )
;--------------------------------------------------------------------------

129
snark-20120808r02/examples/RNG008-6+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,129 @@
;--------------------------------------------------------------------------
; File : RNG008-6 : TPTP v2.2.0. Released v1.0.0.
; Domain : Ring Theory
; Problem : Boolean rings are commutative
; Version : [MOW76] axioms : Augmented.
; English : Given a ring in which for all x, x * x = x, prove that for
; all x and y, x * y = y * x.
; Refs : [MOW76] McCharen et al. (1976), Problems and Experiments for a
; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; Source : [Ove90]
; Names : CADE-11 Competition 3 [Ove90]
; : THEOREM 3 [LM93]
; Status : unsatisfiable
; Rating : 0.67 v2.2.0, 0.71 v2.1.0, 0.75 v2.0.0
; Syntax : Number of clauses : 22 ( 0 non-Horn; 11 unit; 13 RR)
; Number of literals : 55 ( 2 equality)
; Maximal clause size : 5 ( 2 average)
; Number of predicates : 3 ( 0 propositional; 2-3 arity)
; Number of functors : 7 ( 4 constant; 0-2 arity)
; Number of variables : 74 ( 2 singleton)
; Maximal term depth : 2 ( 1 average)
; Comments : Supplies multiplication to identity as lemmas
; : tptp2X -f kif -t rm_equality:rstfp RNG008-6.p
;--------------------------------------------------------------------------
; additive_identity1, axiom.
(or (sum additive_identity ?A ?A))
; additive_identity2, axiom.
(or (sum ?A additive_identity ?A))
; closure_of_multiplication, axiom.
(or (product ?A ?B (multiply ?A ?B)))
; closure_of_addition, axiom.
(or (sum ?A ?B (add ?A ?B)))
; left_inverse, axiom.
(or (sum (additive_inverse ?A) ?A additive_identity))
; right_inverse, axiom.
(or (sum ?A (additive_inverse ?A) additive_identity))
; associativity_of_addition1, axiom.
(or (not (sum ?A ?B ?C))
(not (sum ?B ?D ?E))
(not (sum ?C ?D ?F))
(sum ?A ?E ?F))
; associativity_of_addition2, axiom.
(or (not (sum ?A ?B ?C))
(not (sum ?B ?D ?E))
(not (sum ?A ?E ?F))
(sum ?C ?D ?F))
; commutativity_of_addition, axiom.
(or (not (sum ?A ?B ?C))
(sum ?B ?A ?C))
; associativity_of_multiplication1, axiom.
(or (not (product ?A ?B ?C))
(not (product ?B ?D ?E))
(not (product ?C ?D ?F))
(product ?A ?E ?F))
; associativity_of_multiplication2, axiom.
(or (not (product ?A ?B ?C))
(not (product ?B ?D ?E))
(not (product ?A ?E ?F))
(product ?C ?D ?F))
; distributivity1, axiom.
(or (not (product ?A ?B ?C))
(not (product ?A ?D ?E))
(not (sum ?B ?D ?F))
(not (product ?A ?F ?G))
(sum ?C ?E ?G))
; distributivity2, axiom.
(or (not (product ?A ?B ?C))
(not (product ?A ?D ?E))
(not (sum ?B ?D ?F))
(not (sum ?C ?E ?G))
(product ?A ?F ?G))
; distributivity3, axiom.
(or (not (product ?A ?B ?C))
(not (product ?D ?B ?E))
(not (sum ?A ?D ?F))
(not (product ?F ?B ?G))
(sum ?C ?E ?G))
; distributivity4, axiom.
(or (not (product ?A ?B ?C))
(not (product ?D ?B ?E))
(not (sum ?A ?D ?F))
(not (sum ?C ?E ?G))
(product ?F ?B ?G))
; addition_is_well_defined, axiom.
(or (not (sum ?A ?B ?C))
(not (sum ?A ?B ?D))
(= ?C ?D))
; multiplication_is_well_defined, axiom.
(or (not (product ?A ?B ?C))
(not (product ?A ?B ?D))
(= ?C ?D))
; x_times_identity_x_is_identity, axiom.
(or (product ?A additive_identity additive_identity))
; identity_times_x_is_identity, axiom.
(or (product additive_identity ?A additive_identity))
; x_squared_is_x, hypothesis.
(or (product ?A ?A ?A))
; a_times_b_is_c, hypothesis.
(or (product a b c))
; prove_b_times_a_is_c, conjecture.
(or (not (product b a c)))
;--------------------------------------------------------------------------

60
snark-20120808r02/examples/RNG009-5+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,60 @@
;--------------------------------------------------------------------------
; File : RNG009-5 : TPTP v2.2.0. Released v1.0.0.
; Domain : Ring Theory
; Problem : If X*X*X = X then the ring is commutative
; Version : [Peterson & Stickel,1981] (equality) axioms :
; Reduced > Incomplete.
; English : Given a ring in which for all x, x * x * x = x, prove that
; for all x and y, x * y = y * x.
; Refs : [PS81] Peterson & Stickel (1981), Complete Sets of Reductions
; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [Ove90]
; Names : CADE-11 Competition Eq-7 [Ove90]
; : THEOREM EQ-7 [LM93]
; : PROBLEM 7 [Zha93]
; Status : unsatisfiable
; Rating : 0.67 v2.2.0, 0.71 v2.1.0, 1.00 v2.0.0
; Syntax : Number of clauses : 9 ( 0 non-Horn; 9 unit; 1 RR)
; Number of literals : 9 ( 9 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 6 ( 3 constant; 0-2 arity)
; Number of variables : 17 ( 0 singleton)
; Maximal term depth : 3 ( 2 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp RNG009-5.p
;--------------------------------------------------------------------------
; right_identity, axiom.
(or (= (add ?A additive_identity) ?A))
; right_additive_inverse, axiom.
(or (= (add ?A (additive_inverse ?A)) additive_identity))
; distribute1, axiom.
(or (= (multiply ?A (add ?B ?C)) (add (multiply ?A ?B) (multiply ?A ?C))))
; distribute2, axiom.
(or (= (multiply (add ?A ?B) ?C) (add (multiply ?A ?C) (multiply ?B ?C))))
; associative_addition, axiom.
(or (= (add (add ?A ?B) ?C) (add ?A (add ?B ?C))))
; commutative_addition, axiom.
(or (= (add ?A ?B) (add ?B ?A)))
; associative_multiplication, axiom.
(or (= (multiply (multiply ?A ?B) ?C) (multiply ?A (multiply ?B ?C))))
; x_cubed_is_x, hypothesis.
(or (= (multiply ?A (multiply ?A ?A)) ?A))
; prove_commutativity, conjecture.
(or (/= (multiply a b) (multiply b a)))
;--------------------------------------------------------------------------

117
snark-20120808r02/examples/RNG010-5+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,117 @@
;--------------------------------------------------------------------------
; File : RNG010-5 : TPTP v2.2.0. Released v1.0.0.
; Domain : Ring Theory (Right alternative)
; Problem : Skew symmetry of the auxilliary function
; Version : [Ove90] (equality) axioms :
; Incomplete > Augmented > Incomplete.
; English : The three Moufang identities imply the skew symmetry
; of s(W,X,Y,Z) = (W*X,Y,Z) - X*(W,Y,Z) - (X,Y,Z)*W.
; Recall that skew symmetry means that the function sign
; changes when any two arguments are swapped. This problem
; proves the case for swapping the first two arguments.
; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [Ove90]
; Names : CADE-11 Competition Eq-9 [Ove90]
; : THEOREM EQ-9 [LM93]
; : PROBLEM 9 [Zha93]
; Status : unknown
; Rating : 1.00 v2.0.0
; Syntax : Number of clauses : 27 ( 0 non-Horn; 27 unit; 2 RR)
; Number of literals : 27 ( 27 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 11 ( 5 constant; 0-4 arity)
; Number of variables : 52 ( 2 singleton)
; Maximal term depth : 6 ( 2 average)
; Comments : I copied this directly. I think the Moufang identities may
; be wrong. At least they're in another form.
; : tptp2X -f kif -t rm_equality:rstfp RNG010-5.p
;--------------------------------------------------------------------------
; commutative_addition, axiom.
(or (= (add ?A ?B) (add ?B ?A)))
; associative_addition, axiom.
(or (= (add (add ?A ?B) ?C) (add ?A (add ?B ?C))))
; right_identity, axiom.
(or (= (add ?A additive_identity) ?A))
; left_identity, axiom.
(or (= (add additive_identity ?A) ?A))
; right_additive_inverse, axiom.
(or (= (add ?A (additive_inverse ?A)) additive_identity))
; left_additive_inverse, axiom.
(or (= (add (additive_inverse ?A) ?A) additive_identity))
; additive_inverse_identity, axiom.
(or (= (additive_inverse additive_identity) additive_identity))
; property_of_inverse_and_add, axiom.
(or (= (add ?A (add (additive_inverse ?A) ?B)) ?B))
; distribute_additive_inverse, axiom.
(or (= (additive_inverse (add ?A ?B)) (add (additive_inverse ?A) (additive_inverse ?B))))
; additive_inverse_additive_inverse, axiom.
(or (= (additive_inverse (additive_inverse ?A)) ?A))
; multiply_additive_id1, axiom.
(or (= (multiply ?A additive_identity) additive_identity))
; multiply_additive_id2, axiom.
(or (= (multiply additive_identity ?A) additive_identity))
; product_of_inverse, axiom.
(or (= (multiply (additive_inverse ?A) (additive_inverse ?B)) (multiply ?A ?B)))
; multiply_additive_inverse1, axiom.
(or (= (multiply ?A (additive_inverse ?B)) (additive_inverse (multiply ?A ?B))))
; multiply_additive_inverse2, axiom.
(or (= (multiply (additive_inverse ?A) ?B) (additive_inverse (multiply ?A ?B))))
; distribute1, axiom.
(or (= (multiply ?A (add ?B ?C)) (add (multiply ?A ?B) (multiply ?A ?C))))
; distribute2, axiom.
(or (= (multiply (add ?A ?B) ?C) (add (multiply ?A ?C) (multiply ?B ?C))))
; right_alternative, axiom.
(or (= (multiply (multiply ?A ?B) ?B) (multiply ?A (multiply ?B ?B))))
; associator, axiom.
(or (= (associator ?A ?B ?C) (add (multiply (multiply ?A ?B) ?C) (additive_inverse (multiply ?A (multiply ?B ?C))))))
; commutator, axiom.
(or (= (commutator ?A ?B) (add (multiply ?B ?A) (additive_inverse (multiply ?A ?B)))))
; middle_associator, axiom.
(or (= (multiply (multiply (associator ?A ?A ?B) ?A) (associator ?A ?A ?B)) additive_identity))
; left_alternative, axiom.
(or (= (multiply (multiply ?A ?A) ?B) (multiply ?A (multiply ?A ?B))))
; defines_s, axiom.
(or (= (s ?A ?B ?C ?D) (add (add (associator (multiply ?A ?B) ?C ?D) (additive_inverse (multiply ?B (associator ?A ?C ?D)))) (additive_inverse (multiply (associator ?B ?C ?D) ?A)))))
; right_moufang, hypothesis.
(or (= (multiply ?A (multiply ?B (multiply ?C ?B))) (multiply (commutator (multiply ?A ?B) ?C) ?B)))
; left_moufang, hypothesis.
(or (= (multiply (multiply ?A (multiply ?B ?A)) ?C) (multiply ?A (commutator ?B (multiply ?A ?C)))))
; middle_moufang, hypothesis.
(or (= (multiply (multiply ?A ?B) (multiply ?C ?A)) (multiply (multiply ?A (multiply ?B ?C)) ?A)))
; prove_skew_symmetry, conjecture.
(or (/= (s a b c d) (additive_inverse (s b a c d))))
;--------------------------------------------------------------------------

97
snark-20120808r02/examples/RNG011-5+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,97 @@
;--------------------------------------------------------------------------
; File : RNG011-5 : TPTP v2.2.0. Released v1.0.0.
; Domain : Ring Theory
; Problem : In a right alternative ring (((X,X,Y)*X)*(X,X,Y)) = Add Id
; Version : [Ove90] (equality) axioms :
; Incomplete > Augmented > Incomplete.
; English :
; Refs : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [Ove90]
; Names : CADE-11 Competition Eq-10 [Ove90]
; : THEOREM EQ-10 [LM93]
; : PROBLEM 10 [Zha93]
; Status : unsatisfiable
; Rating : 0.00 v2.0.0
; Syntax : Number of clauses : 22 ( 0 non-Horn; 22 unit; 2 RR)
; Number of literals : 22 ( 22 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 8 ( 3 constant; 0-3 arity)
; Number of variables : 37 ( 2 singleton)
; Maximal term depth : 5 ( 2 average)
; Comments :
; : tptp2X -f kif -t rm_equality:rstfp RNG011-5.p
;--------------------------------------------------------------------------
; commutative_addition, axiom.
(or (= (add ?A ?B) (add ?B ?A)))
; associative_addition, axiom.
(or (= (add (add ?A ?B) ?C) (add ?A (add ?B ?C))))
; right_identity, axiom.
(or (= (add ?A additive_identity) ?A))
; left_identity, axiom.
(or (= (add additive_identity ?A) ?A))
; right_additive_inverse, axiom.
(or (= (add ?A (additive_inverse ?A)) additive_identity))
; left_additive_inverse, axiom.
(or (= (add (additive_inverse ?A) ?A) additive_identity))
; additive_inverse_identity, axiom.
(or (= (additive_inverse additive_identity) additive_identity))
; property_of_inverse_and_add, axiom.
(or (= (add ?A (add (additive_inverse ?A) ?B)) ?B))
; distribute_additive_inverse, axiom.
(or (= (additive_inverse (add ?A ?B)) (add (additive_inverse ?A) (additive_inverse ?B))))
; additive_inverse_additive_inverse, axiom.
(or (= (additive_inverse (additive_inverse ?A)) ?A))
; multiply_additive_id1, axiom.
(or (= (multiply ?A additive_identity) additive_identity))
; multiply_additive_id2, axiom.
(or (= (multiply additive_identity ?A) additive_identity))
; product_of_inverse, axiom.
(or (= (multiply (additive_inverse ?A) (additive_inverse ?B)) (multiply ?A ?B)))
; multiply_additive_inverse1, axiom.
(or (= (multiply ?A (additive_inverse ?B)) (additive_inverse (multiply ?A ?B))))
; multiply_additive_inverse2, axiom.
(or (= (multiply (additive_inverse ?A) ?B) (additive_inverse (multiply ?A ?B))))
; distribute1, axiom.
(or (= (multiply ?A (add ?B ?C)) (add (multiply ?A ?B) (multiply ?A ?C))))
; distribute2, axiom.
(or (= (multiply (add ?A ?B) ?C) (add (multiply ?A ?C) (multiply ?B ?C))))
; right_alternative, axiom.
(or (= (multiply (multiply ?A ?B) ?B) (multiply ?A (multiply ?B ?B))))
; associator, axiom.
(or (= (associator ?A ?B ?C) (add (multiply (multiply ?A ?B) ?C) (additive_inverse (multiply ?A (multiply ?B ?C))))))
; commutator, axiom.
(or (= (commutator ?A ?B) (add (multiply ?B ?A) (additive_inverse (multiply ?A ?B)))))
; middle_associator, axiom.
(or (= (multiply (multiply (associator ?A ?A ?B) ?A) (associator ?A ?A ?B)) additive_identity))
; prove_equality, conjecture.
(or (/= (multiply (multiply (associator a a b) a) (associator a a b)) additive_identity))
;--------------------------------------------------------------------------

53
snark-20120808r02/examples/ROB005-1+rm_eq_rstfp.kif Normal file
View file

@ -0,0 +1,53 @@
;--------------------------------------------------------------------------
; File : ROB005-1 : TPTP v2.2.0. Released v1.0.0.
; Domain : Robbins Algebra
; Problem : c + c=c => Boolean
; Version : [Win90] (equality) axioms.
; English : If there is an element c such that c+c=c, then the algebra
; is Boolean.
; Refs : [HMT71] Henkin et al. (1971), Cylindrical Algebras
; : [Win90] Winker (1990), Robbins Algebra: Conditions that make a
; : [Ove90] Overbeek (1990), ATP competition announced at CADE-10
; : [LW92] Lusk & Wos (1992), Benchmark Problems in Which Equalit
; : [Ove93] Overbeek (1993), The CADE-11 Competitions: A Personal
; : [LM93] Lusk & McCune (1993), Uniform Strategies: The CADE-11
; : [Zha93] Zhang (1993), Automated Proofs of Equality Problems in
; Source : [Ove90]
; Names : CADE-11 Competition Eq-2 [Ove90]
; : Lemma 2.4 [Win90]
; : RA3 [LW92]
; : THEOREM EQ-2 [LM93]
; : PROBLEM 2 [Zha93]
; : robbins.occ.in [OTTER]
; Status : unsatisfiable
; Rating : 0.67 v2.2.0, 0.71 v2.1.0, 0.88 v2.0.0
; Syntax : Number of clauses : 5 ( 0 non-Horn; 5 unit; 2 RR)
; Number of literals : 5 ( 5 equality)
; Maximal clause size : 1 ( 1 average)
; Number of predicates : 1 ( 0 propositional; 2-2 arity)
; Number of functors : 5 ( 3 constant; 0-2 arity)
; Number of variables : 7 ( 0 singleton)
; Maximal term depth : 6 ( 2 average)
; Comments : Commutativity, associativity, and Huntington's axiom
; axiomatize Boolean algebra.
; : tptp2X -f kif -t rm_equality:rstfp ROB005-1.p
;--------------------------------------------------------------------------
; commutativity_of_add, axiom.
(or (= (add ?A ?B) (add ?B ?A)))
; associativity_of_add, axiom.
(or (= (add (add ?A ?B) ?C) (add ?A (add ?B ?C))))
; robbins_axiom, axiom.
(or (= (negate (add (negate (add ?A ?B)) (negate (add ?A (negate ?B))))) ?A))
; idempotence, hypothesis.
(or (= (add c c) c))
; prove_huntingtons_axiom, conjecture.
(or (/= (add (negate (add a (negate b))) (negate (add (negate a) (negate b)))) b))
;--------------------------------------------------------------------------

BIN
snark-20120808r02/examples/coder-examples.abcl Normal file
View file

Binary file not shown.

362
snark-20120808r02/examples/coder-examples.lisp Normal file
View file

@ -0,0 +1,362 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
;;; File: coder-examples.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2004.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/examples/front-last-example.abcl Normal file
View file

Binary file not shown.

82
snark-20120808r02/examples/front-last-example.lisp Normal file
View file

@ -0,0 +1,82 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
;;; File: front-last-example.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2002.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/examples/hot-drink-example.abcl Normal file
View file

Binary file not shown.

130
snark-20120808r02/examples/hot-drink-example.lisp Normal file
View file

@ -0,0 +1,130 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
;;; File: hot-drink-example.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2005.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/examples/latin-squares.abcl Normal file
View file

Binary file not shown.

121
snark-20120808r02/examples/latin-squares.lisp Normal file
View file

@ -0,0 +1,121 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
;;; File: latin-squares.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2006.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/examples/overbeek-test.abcl Normal file
View file

Binary file not shown.

359
snark-20120808r02/examples/overbeek-test.lisp Normal file
View file

@ -0,0 +1,359 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
;;; File: overbeek-test.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2008.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

191
snark-20120808r02/examples/ramsey-examples.lisp Normal file
View file

@ -0,0 +1,191 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
;;; File: ramsey-examples.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2006.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/examples/reverse-example.abcl Normal file
View file

Binary file not shown.

51
snark-20120808r02/examples/reverse-example.lisp Normal file
View file

@ -0,0 +1,51 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
;;; File: reverse-example.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2006.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

19
snark-20120808r02/examples/snark-test Normal file
View file

@ -0,0 +1,19 @@
;;; a script to run some SNARK examples
;;; usage:
;;; cd snark
;;; lisp < examples/snark-test >& examples/snark-test.out &
#-snark (load "snark-system.lisp")
#-snark (make-snark-system)
(in-package :snark-user)
(default-print-row-wffs-prettily nil)
(overbeek-test)
(time (steamroller-example))
(time (front-last-example))
(time (reverse-example))
(time (reverse-example :magic t))
(time (hot-drink-example))
(coder-test)
(time (snark-dpll::queens-problem 8 :find-all-models -1))
(generate-latin-squares 7)
(quit)

BIN
snark-20120808r02/examples/steamroller-example.abcl Normal file
View file

Binary file not shown.

82
snark-20120808r02/examples/steamroller-example.lisp Normal file
View file

@ -0,0 +1,82 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
;;; File: steamroller-example.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

6
snark-20120808r02/make-snark-ccl Executable file
View file

@ -0,0 +1,6 @@
ccl < compile >& compile.out
ccl << ENDOFSTDIN
(load "snark-system.lisp")
(make-snark-system)
(save-snark-system)
ENDOFSTDIN

6
snark-20120808r02/make-snark-ccl64 Executable file
View file

@ -0,0 +1,6 @@
ccl64 < compile >& compile.out
ccl64 << ENDOFSTDIN
(load "snark-system.lisp")
(make-snark-system)
(save-snark-system)
ENDOFSTDIN

6
snark-20120808r02/make-snark-sbcl Executable file
View file

@ -0,0 +1,6 @@
sbcl < compile >& compile.out
sbcl << ENDOFSTDIN
(load "snark-system.lisp")
(make-snark-system)
(save-snark-system :name "snark" :executable t)
ENDOFSTDIN

6
snark-20120808r02/make-snark-sbcl64 Executable file
View file

@ -0,0 +1,6 @@
~/sbcl-1.0.29-x86_64-darwin/run-sbcl.sh < compile >& compile.out
~/sbcl-1.0.29-x86_64-darwin/run-sbcl.sh << ENDOFSTDIN
(load "snark-system.lisp")
(make-snark-system)
(save-snark-system :name "snark64" :executable t)
ENDOFSTDIN

55
snark-20120808r02/run-snark Executable file
View file

@ -0,0 +1,55 @@
#! /bin/tcsh
# this is Geoff's run-snark script for SystemOnTPTP as of 2012-08-21
if (! -f $1) then
echo "Missing filename"
exit
endif
echo $1
if ($2 == "") then
set runtimelimit = nil
else
set runtimelimit = $2
endif
set this_directory=`dirname $0`
$this_directory/snark << ENDOFSTDIN
#+sbcl (sb-ext:disable-debugger)
(in-package :snark-user)
(defvar snark-tptp-options)
(setf snark-tptp-options
'(
(agenda-length-limit nil)
(agenda-length-before-simplification-limit nil)
(use-hyperresolution t)
(use-ur-resolution t)
(use-paramodulation t)
(use-factoring :pos)
(use-literal-ordering-with-hyperresolution 'literal-ordering-p)
(use-literal-ordering-with-paramodulation 'literal-ordering-p)
(ordering-functions>constants t)
(assert-context :current)
(run-time-limit $runtimelimit)
(listen-for-commands nil)
(use-closure-when-satisfiable t)
(print-rows-when-given nil)
(print-rows-when-derived nil)
(print-unorientable-rows nil)
(print-row-wffs-prettily nil)
(print-final-rows :tptp) ;System on TPTP uses value :tptp
(print-options-when-starting nil) ;System on TPTP uses this
(use-variable-name-sorts nil)
(use-purity-test t)
(use-relevance-test t)
(declare-tptp-symbols1)
(declare-tptp-symbols2)
))
(setf *tptp-environment-variable* "$TPTP")
(refute-file "$1" :options snark-tptp-options :format :tptp)
(quit)
ENDOFSTDIN

BIN
snark-20120808r02/snark-interface.fasl Normal file
View file

Binary file not shown.

167
snark-20120808r02/snark-interface.lisp Normal file
View file

@ -0,0 +1,167 @@
(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 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 time-limit)
(snark:assert-supported t)
(snark:assume-supported t)
(snark:prove-supported t)
(snark:use-hyperresolution t)
(snark:use-paramodulation t)
(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 :name (gethash (princ-to-string axiom) a-n)
))
(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 :name (gethash (princ-to-string axiom) a-n)
))
(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 :name (gethash (princ-to-string axiom) a-n)
))
(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 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 :name (gethash (princ-to-string axiom) a-n)
))
(mapcar #'!@ axioms))
(let ((proof (snark:prove (!@ f) :answer (!@ (cons 'ans vars)) )))
(if (equalp :PROOF-FOUND proof)
(string-downcase (princ-to-string (@! (rest (snark:answer proof) ))))
"")))))
(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)))

160
snark-20120808r02/snark-system.lisp Normal file
View file

@ -0,0 +1,160 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
;;; File: snark-system.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/ac-rpo.abcl Normal file
View file

Binary file not shown.

304
snark-20120808r02/src/ac-rpo.lisp Normal file
View file

@ -0,0 +1,304 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: ac-rpo.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

36
snark-20120808r02/src/agenda-system.lisp Normal file
View file

@ -0,0 +1,36 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
;;; File: agenda-system.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2009.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/agenda.abcl Normal file
View file

Binary file not shown.

234
snark-20120808r02/src/agenda.lisp Normal file
View file

@ -0,0 +1,234 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-agenda -*-
;;; File: agenda.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2008.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/alists.abcl Normal file
View file

Binary file not shown.

121
snark-20120808r02/src/alists.lisp Normal file
View file

@ -0,0 +1,121 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: alists.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/argument-bag-ac.abcl Normal file
View file

Binary file not shown.

82
snark-20120808r02/src/argument-bag-ac.lisp Normal file
View file

@ -0,0 +1,82 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: argument-bag-ac.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/argument-list-a1.abcl Normal file
View file

Binary file not shown.

145
snark-20120808r02/src/argument-list-a1.lisp Normal file
View file

@ -0,0 +1,145 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: argument-list-a1.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/assertion-analysis.abcl Normal file
View file

Binary file not shown.

502
snark-20120808r02/src/assertion-analysis.lisp Normal file
View file

@ -0,0 +1,502 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: assertion-analysis.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
;;; 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

BIN
snark-20120808r02/src/assertion-file.abcl Normal file
View file

Binary file not shown.

262
snark-20120808r02/src/assertion-file.lisp Normal file
View file

@ -0,0 +1,262 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: assertion-file.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/clocks.abcl Normal file
View file

Binary file not shown.

169
snark-20120808r02/src/clocks.lisp Normal file
View file

@ -0,0 +1,169 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
;;; File: clocks.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

66
snark-20120808r02/src/closure1.lisp Normal file
View file

@ -0,0 +1,66 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: closure1.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/code-for-bags4.abcl Normal file
View file

Binary file not shown.

116
snark-20120808r02/src/code-for-bags4.lisp Normal file
View file

@ -0,0 +1,116 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: code-for-bags4.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/code-for-lists2.abcl Normal file
View file

Binary file not shown.

34
snark-20120808r02/src/code-for-lists2.lisp Normal file
View file

@ -0,0 +1,34 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: code-for-lists2.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/code-for-numbers3.abcl Normal file
View file

Binary file not shown.

505
snark-20120808r02/src/code-for-numbers3.lisp Normal file
View file

@ -0,0 +1,505 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: code-for-numbers3.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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 -> ~(b<a)
;; a>b -> b<a
;; a>=b -> ~(a<b)
(declare (ignorable subst))
(let* ((args (args atom))
(atom* (make-compound* (input-relation-symbol newhead (length args)) (if reverse (reverse args) args))))
(if negate (negate atom*) atom*)))
(defun arithmetic-term-rewriter1 (term subst pred operator)
(let ((args (arithmetic-expr-args term subst pred)))
(if (eq none args) none (declare-constant (apply operator args)))))
(defun arithmetic-term-rewriter2 (term subst pred operator)
;; like arithmetic-term-rewriter1 but last argument must be nonzero
(let ((args (arithmetic-expr-args term subst pred)))
(if (or (eq none args) (eql 0 (first (last args)))) none (declare-constant (apply operator args)))))
(defun arithmetic-term-rewriter3 (term subst operator identity absorber)
;; combines numerical arguments in sum and product terms
(let* ((head (head term))
(args (args term))
(args* (argument-list-a1 head args subst identity)))
(cond
((null args*)
identity)
((null (rest args*))
(first args*))
(t
(mvlet (((values nums nonnums) (split-if #'rnumberp args* subst)))
(cond
((null nums)
(if (eq args args*) none (make-compound* head args*)))
(t
(let ((num (if (null (rest nums)) (first nums) (declare-constant (apply operator nums)))))
(cond
((eql absorber num)
num)
((eql identity num)
(make-a1-compound* head identity nonnums))
((and (eq args args*) (null (rest nums)) (let ((arg1 (first args))) (dereference arg1 subst :if-constant (eql num arg1))))
none)
(t
(make-a1-compound* head identity num nonnums)))))))))))
(defun arithmetic-term-rewriter4 (term subst operator)
;; for floor, ceiling, truncate, and round
(let ((arg (first (args term))))
(cond
((dereference arg subst :if-constant (realp arg))
(declare-constant (funcall operator arg)))
((subsort? (term-sort arg subst) (the-sort 'integer))
arg)
(t
none))))
(defun arithmetic-term-rewriter5 (term subst op2 op1)
;; ($$difference a b) -> ($$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

BIN
snark-20120808r02/src/code-for-strings2.abcl Normal file
View file

Binary file not shown.

62
snark-20120808r02/src/code-for-strings2.lisp Normal file
View file

@ -0,0 +1,62 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: code-for-strings2.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/coder.abcl Normal file
View file

Binary file not shown.

714
snark-20120808r02/src/coder.lisp Normal file
View file

@ -0,0 +1,714 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
;;; File: coder.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/collectors.abcl Normal file
View file

Binary file not shown.

143
snark-20120808r02/src/collectors.lisp Normal file
View file

@ -0,0 +1,143 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
;;; File: collectors.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/connectives.abcl Normal file
View file

Binary file not shown.

550
snark-20120808r02/src/connectives.lisp Normal file
View file

@ -0,0 +1,550 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: connectives.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/constants.abcl Normal file
View file

Binary file not shown.

305
snark-20120808r02/src/constants.lisp Normal file
View file

@ -0,0 +1,305 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: constants.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/constraints.abcl Normal file
View file

Binary file not shown.

335
snark-20120808r02/src/constraints.lisp Normal file
View file

@ -0,0 +1,335 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: constraints.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/counters.abcl Normal file
View file

Binary file not shown.

90
snark-20120808r02/src/counters.lisp Normal file
View file

@ -0,0 +1,90 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
;;; File: counters.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/date-reasoning2.abcl Normal file
View file

Binary file not shown.

347
snark-20120808r02/src/date-reasoning2.lisp Normal file
View file

@ -0,0 +1,347 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: date-reasoning2.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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<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<i))
((>= 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

BIN
snark-20120808r02/src/davis-putnam3.abcl Normal file
View file

Binary file not shown.

2344
snark-20120808r02/src/davis-putnam3.lisp Normal file
View file

File diff suppressed because it is too large Load diff

38
snark-20120808r02/src/deque-system.lisp Normal file
View file

@ -0,0 +1,38 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
;;; File: deque-system.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/deque2.abcl Normal file
View file

Binary file not shown.

228
snark-20120808r02/src/deque2.lisp Normal file
View file

@ -0,0 +1,228 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-deque -*-
;;; File: deque2.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/dp-refute.abcl Normal file
View file

Binary file not shown.

250
snark-20120808r02/src/dp-refute.lisp Normal file
View file

@ -0,0 +1,250 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: dp-refute.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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 formula: ")
(prin1 (context-formula context) stream)
(format stream "; assignment: ")
(prin1 (context-assignment context) stream)
(format stream "; substitution: ")
(prin1 (context-substitution context) stream)
(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

46
snark-20120808r02/src/dpll-system.lisp Normal file
View file

@ -0,0 +1,46 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
;;; File: dpll-system.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/equal.abcl Normal file
View file

Binary file not shown.

115
snark-20120808r02/src/equal.lisp Normal file
View file

@ -0,0 +1,115 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: equal.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

BIN
snark-20120808r02/src/eval.abcl Normal file
View file

Binary file not shown.

350
snark-20120808r02/src/eval.lisp Normal file
View file

@ -0,0 +1,350 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
;;; File: eval.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(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

Some files were not shown because too many files have changed in this diff Show more