p i>p i_di_p i_si_p)
+ (di ip i>p i_di_p i_si_p)
+ (o i
p i>p)
+ (oi i
p i_di_p i_si_p)
+ (oi i_si_p i>p)
+ (oi i_fi_p i_di_p)
+ (m i>p i>p i_di_p i_si_p)
+ (m i
p i>p)
+ (mi i
p)
+ (mi i_si_p i>p)
+ (mi i_fi_p i_si_p)
+ (s i>p i>p)
+ (s i
p i>p)
+ (si i
p i>p)
+ (f i
p i_di_p i_si_p)
+ (f i_si_p i>p)
+ (f i_fi_p i_fi_p)
+ (fi i>p i>p i_di_p i_si_p)
+ (fi i
p i>p)
+ (= i
p p
p i
p p>p i>p)
+ (i>p p=p i>p)
+ (i
p i>p i
p i>p i_di_p i_si_p)
+ (i_di_p p=p i_di_p)
+ (i_si_p p
p i>p)
+ (i_si_p p=p i_si_p)
+ (i_fi_p p
p i>p i_di_p i_si_p)
+ (i_fi_p p=p i_fi_p)))
+
+;;; jepd-relations-tables.lisp
diff --git a/snark-20120808r02/src/jepd-relations.abcl b/snark-20120808r02/src/jepd-relations.abcl
new file mode 100644
index 0000000..258fd8b
Binary files /dev/null and b/snark-20120808r02/src/jepd-relations.abcl differ
diff --git a/snark-20120808r02/src/jepd-relations.lisp b/snark-20120808r02/src/jepd-relations.lisp
new file mode 100644
index 0000000..d21090c
--- /dev/null
+++ b/snark-20120808r02/src/jepd-relations.lisp
@@ -0,0 +1,731 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: jepd-relations.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; reasoning facilities for jointly-exhaustive and pairwise-disjoint sets of binary relations
+;;; including
+;;; spatial regions (RCC8)
+;;; time intervals (Allen)
+;;; time points
+;;; that use composition tables to derive consequences and determine local consistency
+
+;;; for theories implemented here, the main functions are
+;;; declare-rcc8-relations
+;;; declare-time-relations
+;;; these declare the appropriate relation symbols
+;;; (determined by the values of rcc8-jepd-relation-names, rcc8-more-relation-names, etc.)
+;;; and declare procedural attachments for composing and intersecting disjunctions of
+;;; jepd binary relations
+
+;;; in the following encodings,
+;;; a primitive relation allowed to be true is signified by the constant 1
+;;; a primitive relation required to be false is signified by a variable
+;;; encoding "no" by variables this way makes factoring and subsumption do the right thing
+
+;;; for example, here is the encoding of time interval-interval relations
+;;; they are all translated to positive occurrences of time-ii-relation
+;;; 0 (before a b) ($$time-ii a b (list 1 ? ? ? ? ? ? ? ? ? ? ? ?))
+;;; 1 (during a b) ($$time-ii a b (list ? 1 ? ? ? ? ? ? ? ? ? ? ?))
+;;; 2 (overlaps a b) ($$time-ii a b (list ? ? 1 ? ? ? ? ? ? ? ? ? ?))
+;;; 3 (meets a b) ($$time-ii a b (list ? ? ? 1 ? ? ? ? ? ? ? ? ?))
+;;; 4 (starts a b) ($$time-ii a b (list ? ? ? ? 1 ? ? ? ? ? ? ? ?))
+;;; 5 (finishes a b) ($$time-ii a b (list ? ? ? ? ? 1 ? ? ? ? ? ? ?))
+;;; 6 (equal a b) ($$time-ii a b (list ? ? ? ? ? ? 1 ? ? ? ? ? ?))
+;;; 7 (finished-by a b) ($$time-ii a b (list ? ? ? ? ? ? ? 1 ? ? ? ? ?))
+;;; 8 (started-by a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? 1 ? ? ? ?))
+;;; 9 (met-by a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? ? 1 ? ? ?))
+;;; 10 (overlapped-by a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? ? ? 1 ? ?))
+;;; 11 (contains a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? ? ? ? 1 ?))
+;;; 12 (after a b) ($$time-ii a b (list ? ? ? ? ? ? ? ? ? ? ? ? 1))
+;;; (disjoint a b) ($$time-ii a b (list 1 ? ? 1 ? ? ? ? ? 1 ? ? 1))
+;;; (not (before a b)) ($$time-ii a b (list ? 1 1 1 1 1 1 1 1 1 1 1 1))
+;;; (not (during a b)) ($$time-ii a b (list 1 ? 1 1 1 1 1 1 1 1 1 1 1))
+;;; etc.
+
+;;; these SNARK options can be used to specify the sort and relation names to be used
+;;; by setting them BEFORE executing (declare-rcc8-relations) or (declare-time-relations)
+
+(declare-snark-option rcc8-region-sort-name 'region 'region)
+(declare-snark-option time-interval-sort-name 'time-interval 'time-interval)
+(declare-snark-option time-point-sort-name 'time-point 'time-point)
+
+(defparameter rcc8-jepd-relation-names
+ '($$rcc8-tpp ;0 tangential proper part - inverse of 7
+ $$rcc8-ntpp ;1 nontangential proper part - inverse of 6
+ $$rcc8-dc ;2 disconnected - self inverse
+ $$rcc8-ec ;3 externally connected - self inverse
+ $$rcc8-po ;4 partially overlaps - self inverse
+ $$rcc8-eq ;5 equality - self inverse
+ $$rcc8-ntppi ;6 nontangential proper part inverse
+ $$rcc8-tppi)) ;7 tangential proper part inverse
+
+(defparameter rcc8-more-relation-names ;composite relations and aliases
+ '($$rcc8-dr (2 3) ; discrete (complement of overlaps)
+ $$rcc8-pp (0 1) ; proper part
+ $$rcc8-p (0 1 5) ; part
+ $$rcc8-ppi (6 7) ; proper part inverse
+ $$rcc8-pi (5 6 7) ; part inverse
+ $$rcc8-o (0 1 4 5 6 7) ; overlaps (complement of discrete)
+ $$rcc8-c (0 1 3 4 5 6 7) ; connected (complement of disconnected)
+ $$rcc8-tp (0 5) ; tangential part
+ $$rcc8-tpi (5 7) ; tangential part inverse
+
+ ;; rcc8-not-tpp etc. are unnecessary for input
+ ;; since (not (rcc8-tpp ...)) etc. can be written instead
+ ;; they are used to improve output using only positive literals
+ $$rcc8-not-tpp (1 2 3 4 5 6 7)
+ $$rcc8-not-ntpp (0 2 3 4 5 6 7)
+ $$rcc8-not-ec (0 1 2 4 5 6 7)
+ $$rcc8-not-po (0 1 2 3 5 6 7)
+ $$rcc8-not-eq (0 1 2 3 4 6 7)
+ $$rcc8-not-ntppi (0 1 2 3 4 5 7)
+ $$rcc8-not-tppi (0 1 2 3 4 5 6)
+ $$rcc8-not-pp (2 3 4 5 6 7)
+ $$rcc8-not-p (2 3 4 6 7)
+ $$rcc8-not-ppi (0 1 2 3 4 5)
+ $$rcc8-not-pi (0 1 2 3 4)
+ $$rcc8-not-tp (1 2 3 4 6 7)
+ $$rcc8-not-tpi (0 1 2 3 4 6)
+ ))
+
+(defparameter time-ii-jepd-relation-names
+ '($$time-ii-before ;0 - inverse of 12
+ $$time-ii-during ;1 - inverse of 11
+ $$time-ii-overlaps ;2 - inverse of 10
+ $$time-ii-meets ;3 - inverse of 9
+ $$time-ii-starts ;4 - inverse of 8
+ $$time-ii-finishes ;5 - inverse of 7
+ $$time-ii-equal ;6 - self inverse
+ $$time-ii-finished-by ;7
+ $$time-ii-started-by ;8
+ $$time-ii-met-by ;9
+ $$time-ii-overlapped-by ;10
+ $$time-ii-contains ;11
+ $$time-ii-after)) ;12
+
+(defparameter time-ii-more-relation-names ;composite relations and aliases
+ '($$time-ii-starts-before (0 2 3 7 11)
+ $$time-ii-starts-equal (4 6 8)
+ $$time-ii-starts-after (1 5 9 10 12)
+ $$time-ii-finishes-before (0 1 2 3 4)
+ $$time-ii-finishes-equal (5 6 7)
+ $$time-ii-finishes-after (8 9 10 11 12)
+ $$time-ii-subsumes (6 7 8 11)
+ $$time-ii-subsumed-by (1 4 5 6)
+ $$time-ii-disjoint (0 3 9 12)
+ $$time-ii-intersects (1 2 4 5 6 7 8 10 11) ;complement of disjoint
+
+ ;; time-ii-not-before etc. are unnecessary for input
+ ;; since (not (before ...)) etc. can be written instead
+ ;; they are used to improve output using only positive literals
+ $$time-ii-not-before (1 2 3 4 5 6 7 8 9 10 11 12)
+ $$time-ii-not-during (0 2 3 4 5 6 7 8 9 10 11 12)
+ $$time-ii-not-overlaps (0 1 3 4 5 6 7 8 9 10 11 12)
+ $$time-ii-not-meets (0 1 2 4 5 6 7 8 9 10 11 12)
+ $$time-ii-not-starts (0 1 2 3 5 6 7 8 9 10 11 12)
+ $$time-ii-not-finishes (0 1 2 3 4 6 7 8 9 10 11 12)
+ $$time-ii-not-equal (0 1 2 3 4 5 7 8 9 10 11 12)
+ $$time-ii-not-finished-by (0 1 2 3 4 5 6 8 9 10 11 12)
+ $$time-ii-not-started-by (0 1 2 3 4 5 6 7 9 10 11 12)
+ $$time-ii-not-met-by (0 1 2 3 4 5 6 7 8 10 11 12)
+ $$time-ii-not-overlapped-by (0 1 2 3 4 5 6 7 8 9 11 12)
+ $$time-ii-not-contains (0 1 2 3 4 5 6 7 8 9 10 12)
+ $$time-ii-not-after (0 1 2 3 4 5 6 7 8 9 10 11)
+ $$time-ii-not-starts-before (1 4 5 6 8 9 10 12)
+ $$time-ii-not-starts-equal (0 1 2 3 5 7 9 10 11 12)
+ $$time-ii-not-starts-after (0 2 3 4 6 7 8 11)
+ $$time-ii-not-finishes-before (5 6 7 8 9 10 11 12)
+ $$time-ii-not-finishes-equal (0 1 2 3 4 8 9 10 11 12)
+ $$time-ii-not-finishes-after (0 1 2 3 4 5 7 7)
+ $$time-ii-not-subsumes (0 1 2 3 4 5 9 10 12)
+ $$time-ii-not-subsumed-by (0 2 3 7 8 9 10 11 12)
+
+ $$time-ii-contained-by (1) ;alias of time-ii-during
+ ))
+
+(defparameter time-pp-jepd-relation-names
+ '($$time-pp-before ;0 - inverse of 2
+ $$time-pp-equal ;1 - self inverse
+ $$time-pp-after)) ;2
+
+(defparameter time-pp-more-relation-names ;composite relations and aliases
+ '($$time-pp-not-before (1 2)
+ $$time-pp-not-equal (0 2)
+ $$time-pp-not-after (0 1)
+ ))
+
+(defparameter time-pi-jepd-relation-names
+ '($$time-pi-before ;0
+ $$time-pi-starts ;1
+ $$time-pi-during ;2
+ $$time-pi-finishes ;3
+ $$time-pi-after)) ;4
+
+(defparameter time-pi-more-relation-names ;composite relations and aliases
+ '($$time-pi-disjoint (0 4)
+ $$time-pi-intersects (1 2 3) ;complement of disjoint
+ $$time-pi-not-before (1 2 3 4)
+ $$time-pi-not-starts (0 2 3 4)
+ $$time-pi-not-during (0 1 3 4)
+ $$time-pi-not-finishes (0 1 2 4)
+ $$time-pi-not-after (0 1 2 3)
+ $$time-pi-contained-by (2) ;alias of time-pi-during
+ ))
+
+;;; interval-point relations are converted to point-interval relations
+
+(defparameter time-ip-jepd-relation-names
+ '($$time-ip-after ;0
+ $$time-ip-started-by ;1
+ $$time-ip-contains ;2
+ $$time-ip-finished-by ;3
+ $$time-ip-before)) ;4
+
+(defparameter time-ip-more-relation-names ;composite relations and aliases
+ '($$time-ip-disjoint (0 4)
+ $$time-ip-intersects (1 2 3) ;complement of disjoint
+ $$time-ip-not-after (1 2 3 4)
+ $$time-ip-not-started-by (0 2 3 4)
+ $$time-ip-not-contains (0 1 3 4)
+ $$time-ip-not-finished-by (0 1 2 4)
+ $$time-ip-not-before (0 1 2 3)
+ ))
+
+(defun jepd-relation-input-function (head args polarity rel reverse n i)
+ (cond
+ ((eq :both polarity)
+ (throw 'needs-strict-polarity nil))
+ (t
+ (require-n-arguments head args polarity 2)
+ (let ((atom `(,rel ,@(if reverse (reverse args) args) ($$list ,@(1-or-?s n i polarity)))))
+ (input-wff1 (if (eq :pos polarity) atom `(not ,atom)) polarity)))))
+
+(defun 1-or-?s (n i &optional (polarity :pos))
+ (let ((l nil) l-last)
+ (dotimes (k n)
+ (collect (if (if (consp i) (member k i) (eql i k))
+ (if (eq :pos polarity) 1 (make-variable))
+ (if (eq :pos polarity) (make-variable) 1))
+ l))
+ l))
+
+(defun 1s-count (x &optional subst)
+ (dereference
+ x subst
+ :if-variable 0
+ :if-constant 0
+ :if-compound-appl 0
+ :if-compound-cons (let ((x1 (carc x)))
+ (if (dereference x1 subst :if-constant (eql 1 x1))
+ (+ (1s-count (cdrc x)) 1)
+ (1s-count (cdrc x))))))
+
+(defun 1-indexes (x &optional subst (n 0))
+ (dereference
+ x subst
+ :if-variable nil
+ :if-constant nil
+ :if-compound-appl nil
+ :if-compound-cons (let ((x1 (carc x)))
+ (if (dereference x1 subst :if-constant (eql 1 x1))
+ (cons n (1-indexes (cdrc x) subst (+ n 1)))
+ (1-indexes (cdrc x) subst (+ n 1))))))
+
+(defun jepd-relation-composition-rewriter (atom subst fun)
+ (let* ((args (args atom))
+ (l1 (pop args))
+ (l2 (pop args))
+ (x (pop args))
+ (y (pop args))
+ (z (first args)))
+ (cond
+ ((or (equal-p x y subst) ;don't compose (r1 a a) and (r2 a b)
+ (equal-p y z subst) ;don't compose (r1 a b) and (r2 b b)
+ (and (test-option17?)
+ (equal-p x z subst))) ;don't compose (r1 a b) and (r2 b a)
+ true)
+ ((and (dereference l1 subst :if-compound-cons t)
+ (dereference l2 subst :if-compound-cons t))
+ (funcall fun l1 l2 x y z subst)) ;get result using theory's composition table
+ (t
+ none)))) ;useless consequences of the axioms?
+
+(defun jepd-relation-composition-rewriter1 (atom subst rel table &optional (n (first (array-dimensions table))))
+ (jepd-relation-composition-rewriter
+ atom
+ subst
+ (lambda (l1 l2 x y z subst)
+ (declare (ignore y))
+ (let ((result (make-array n :initial-element nil))
+ (i 0))
+ (dolist (v l1)
+ (when (dereference v subst :if-constant t)
+ (let ((j 0))
+ (dolist (v l2)
+ (when (dereference v subst :if-constant t)
+ (dolist (v (aref table i j))
+ (setf (svref result v) t)))
+ (incf j))))
+ (incf i))
+ (cond
+ ((every #'identity result)
+ true)
+ (t
+ (make-compound
+ rel
+ x
+ z
+ (let ((l nil) l-last)
+ (dotimes (i n)
+ (collect (if (svref result i) 1 (make-and-freeze-variable)) l))
+ l))))))))
+
+(defun reversem (l m &optional (n (length l)))
+ (nconc (nreverse (subseq l (- n m) n))
+ (subseq l m (- n m))
+ (nreverse (subseq l 0 m))))
+
+(defun xx-intersection (l1 l2 subst)
+ ;; fresh variables returned
+ (dereference l1 subst)
+ (dereference l2 subst)
+ (if (null l1)
+ nil
+ (cons (or (let ((x (first l1))) (dereference x subst :if-variable (make-and-freeze-variable)))
+ (let ((x (first l2))) (dereference x subst :if-variable (make-and-freeze-variable)))
+ 1)
+ (xx-intersection (rest l1) (rest l2) subst))))
+
+(defun jepd-relation-intersection-rewriter1 (rel atom subst invert)
+ (let* ((args (args atom))
+ (l1 (pop args))
+ (l2 (pop args)))
+ (cond
+ ((and (dereference l1 subst :if-compound-cons t)
+ (dereference l2 subst :if-compound-cons t))
+ (let ((l (xx-intersection l1 l2 subst)))
+ (cond
+ ((not (member 1 l))
+ false)
+ ((and invert (test-option17?))
+ (make-compound rel (second args) (first args) (reversem l invert)))
+ (t
+ (make-compound rel (first args) (second args) l)))))
+ ((and (dereference l1 subst :if-variable t)
+ (dereference l2 subst :if-variable t)
+ (eq l1 l2))
+ true) ;useless consequences of the axioms?
+ (t
+ none))))
+
+(defun jepd-relation-atom-weight (x &optional subst)
+ (let ((args (args x)))
+ (+ (weight (pop args) subst)
+ (weight (pop args) subst)
+ (1s-count (first args) subst)
+ (function-weight (head x)))))
+
+(defun declare-jepd-relation (relname sort names more-names invert)
+ (let ((use-special-unification (and invert (not (test-option17?)))))
+ (declare-relation1
+ relname 3
+ :rewrite-code 'jepd-relation-atom-rewriter
+ :sort sort
+ :equal-code (and use-special-unification
+ (lambda (x y subst)
+ (equal-jepd-relation-atom-args-p (args x) (args y) subst invert)))
+ :variant-code (and use-special-unification
+ (lambda (cc x y subst matches)
+ (variant-jepd-relation-atom-args cc (args x) (args y) subst matches invert)))
+ :unify-code (and use-special-unification
+ (lambda (cc x y subst)
+ (unify-jepd-relation-atom-args cc (args x) (args y) subst invert)))
+ :index-type (and use-special-unification :jepd)
+ :ordering-status (if use-special-unification :commutative :left-to-right)
+ :to-lisp-code #'(lambda (head args subst) (jepd-atom-to-lisp head args subst names more-names))
+ :weight-code 'jepd-relation-atom-weight)))
+
+(defun declare-jepd-relation-input (relname names more-names n reverse)
+ (let ((i 0))
+ (dolist (name names)
+ (declare-relation1
+ name :any
+ :macro t
+ :input-code (let ((i i))
+ (lambda (head args polarity)
+ (jepd-relation-input-function head args polarity relname reverse n i))))
+ (incf i)))
+ (do ((l more-names (cddr l)))
+ ((endp l)
+ )
+ (declare-relation1
+ (first l) :any
+ :macro t
+ :input-code (let ((i (second l)))
+ (lambda (head args polarity)
+ (jepd-relation-input-function head args polarity relname reverse n i))))))
+
+(defun declare-equality-jepd-relation (relname sort n equality)
+ (when equality
+ (cl:assert (same-sort? (first sort) (second sort)))
+ (assert `(forall ((?x :sort ,(first sort)))
+ (,relname ?x ?x ($$list ,@(1-or-?s n equality))))
+ :name (intern (to-string relname :-equality) :keyword)
+ :supported nil)))
+
+(defun declare-jepd-relation-intersection (relname rel sort invert)
+ (let ((intersection (intern (to-string relname :-intersection) :snark)))
+ (declare-relation1
+ intersection 4
+ :rewrite-code (list
+ (lambda (atom subst)
+ (jepd-relation-intersection-rewriter1 rel atom subst invert))))
+ (assert `(forall ((?x :sort ,(first sort))
+ (?y :sort ,(second sort))
+ ?l1
+ ?l2)
+ (implies (and (,relname ?x ?y ?l1) (,relname ?x ?y ?l2))
+ (,intersection ?l1 ?l2 ?x ?y)))
+ :name (intern (symbol-name intersection) :keyword)
+ :supported nil)))
+
+(defun declare-jepd-relations (relname sort composition invert equality names more-names)
+ ;; three operations may be necessary:
+ ;; intersection: (r1 a b) & (r2 a b) -> (r1&r2 a b)
+ ;; inverse: (r1 a b) -> (r1' b a)
+ ;; composition: (r1 a b) & (r2 b c) -> (r3 a c)
+ ;;
+ ;; if inverse is necessary, it is incorporated into the intersection operation:
+ ;; intersection: (r1 a b) & (r2 a b) -> (r1&r2 b a)
+ ;; so that only composition and (possibly inverting) intersection are used
+ (let ((n (length names))
+ (rel (declare-jepd-relation relname sort names more-names invert)))
+ (declare-jepd-relation-input relname names more-names n nil)
+ (declare-equality-jepd-relation relname sort n equality)
+ (declare-jepd-relation-intersection relname rel sort invert)
+ (let ((table composition)
+ (composition (intern (to-string relname :-composition) :snark)))
+ (declare-relation1
+ composition 5
+ :rewrite-code (list
+ (lambda (atom subst)
+ (jepd-relation-composition-rewriter1 atom subst rel table))))
+ (assert `(forall ((?x :sort ,(first sort))
+ (?y :sort ,(second sort)) ;sorts should be the same
+ (?z :sort ,(second sort))
+ ?l1
+ ?l2)
+ (implies (and (,relname ?x ?y ?l1) (,relname ?y ?z ?l2))
+ (,composition ?l1 ?l2 ?x ?y ?z)))
+ :name (intern (symbol-name composition) :keyword)
+ :supported nil))))
+
+(defun jepd-relation-code (x alist)
+ (let ((v (assoc x alist)))
+ (cl:assert v)
+ (cdr v)))
+
+(defun make-composition-table (tab ocode &optional (icode1 ocode) (icode2 ocode))
+ (let* ((nrows (length icode1))
+ (ncols (length icode2))
+ (table (make-array (list nrows ncols) :initial-element nil)))
+ (dolist (x tab)
+ (let ((i (jepd-relation-code (first x) icode1))
+ (j (jepd-relation-code (second x) icode2)))
+ (cl:assert (null (aref table i j)))
+ (setf (aref table i j) (mapcar (lambda (x) (jepd-relation-code x ocode)) (cddr x)))))
+ (dotimes (i nrows)
+ (dotimes (j ncols)
+ (cl:assert (not (null (aref table i j))))))
+ table))
+
+(defvar *rcc8-composition-table* nil)
+(defvar *time-iii-composition-table* nil)
+(defvar *time-ipi-composition-table* nil)
+(defvar *time-pii-composition-table* nil)
+(defvar *time-pip-composition-table* nil)
+(defvar *time-ppi-composition-table* nil)
+(defvar *time-ppp-composition-table* nil)
+
+(defun firsta (x)
+ (if (consp x) (first x) x))
+
+(defun resta (x)
+ (if (consp x) (rest x) nil))
+
+(defun declare-rcc8-relations ()
+ ;; this function should not be done more than once after (initialize)
+ (let ((region-sort (rcc8-region-sort-name?)))
+ (unless (sort-name? region-sort)
+ (let ((l (resta region-sort)))
+ (apply 'declare-sort (setf region-sort (firsta region-sort)) l)))
+ (declare-jepd-relations
+ '$$rcc8
+ (list region-sort region-sort)
+ (or *rcc8-composition-table*
+ (setf *rcc8-composition-table* (make-composition-table
+ $rcc8-composition-table
+ $rcc8-relation-code)))
+ 2
+ (jepd-relation-code 'eq $rcc8-relation-code)
+ rcc8-jepd-relation-names
+ rcc8-more-relation-names)))
+
+(defun declare-time-relations (&key intervals points dates)
+ ;; this function should not be done more than once after (initialize)
+ (unless (or intervals points)
+ (setf intervals t points t))
+ (when dates
+ (setf points t))
+ (let ((interval-sort (time-interval-sort-name?))
+ (point-sort (time-point-sort-name?)))
+ (when intervals
+ (unless (sort-name? interval-sort)
+ (let ((l (resta interval-sort)))
+ (apply 'declare-sort (setf interval-sort (firsta interval-sort)) l)))
+ (declare-jepd-relations
+ '$$time-ii
+ (list interval-sort interval-sort)
+ (or *time-iii-composition-table*
+ (setf *time-iii-composition-table* (make-composition-table
+ $time-iii-composition-table
+ $time-ii-relation-code)))
+ 6
+ (jepd-relation-code '= $time-ii-relation-code)
+ time-ii-jepd-relation-names
+ time-ii-more-relation-names))
+ (when points
+ (unless (sort-name? point-sort)
+ (let ((l (resta point-sort)))
+ (apply 'declare-sort (setf point-sort (firsta point-sort)) l)))
+ (declare-jepd-relations
+ '$$time-pp
+ (list point-sort point-sort)
+ (or *time-ppp-composition-table*
+ (setf *time-ppp-composition-table* (make-composition-table
+ $time-ppp-composition-table
+ $time-pp-relation-code)))
+ 1
+ (jepd-relation-code 'p=p $time-pp-relation-code)
+ time-pp-jepd-relation-names
+ time-pp-more-relation-names))
+ (when (and intervals points)
+ (unless (or (top-sort-name? interval-sort) (top-sort-name? point-sort))
+ (declare-sorts-incompatible interval-sort point-sort))
+ (let* ((relname '$$time-pi)
+ (sort (list point-sort interval-sort))
+ (names time-pi-jepd-relation-names)
+ (more-names time-pi-more-relation-names)
+ (n (length names))
+ (rel (declare-jepd-relation relname sort names more-names nil)))
+ (declare-jepd-relation-input relname names more-names n nil)
+ ;; convert interval-point relations to point-interval relations
+ (setf names time-ip-jepd-relation-names)
+ (cl:assert (eql n (length names)))
+ (declare-jepd-relation-input relname names time-ip-more-relation-names n t)
+ (declare-jepd-relation-intersection relname rel sort nil)
+ ;;; PI * II -> PI composition
+ (let ((composition (intern (to-string relname :-ii-composition) :snark)))
+ (declare-relation1
+ composition 5
+ :rewrite-code (let ((table (or *time-pii-composition-table*
+ (setf *time-pii-composition-table* (make-composition-table
+ $time-pii-composition-table
+ $time-pi-relation-code
+ $time-pi-relation-code
+ $time-ii-relation-code))))
+ (n (length $time-pi-relation-code)))
+ (list
+ (lambda (atom subst)
+ (jepd-relation-composition-rewriter1 atom subst rel table n)))))
+ (assert `(forall ((?x :sort ,point-sort)
+ (?y :sort ,interval-sort)
+ (?z :sort ,interval-sort)
+ ?l1
+ ?l2)
+ (implies (and (,relname ?x ?y ?l1) ($$time-ii ?y ?z ?l2))
+ (,composition ?l1 ?l2 ?x ?y ?z)))
+ :name (intern (symbol-name composition) :keyword)
+ :supported nil))
+ ;;; PP * PI -> PI composition
+ (let ((composition (intern (to-string relname :-pp-composition) :snark)))
+ (declare-relation1
+ composition 5
+ :rewrite-code (let ((table (or *time-ppi-composition-table*
+ (setf *time-ppi-composition-table* (make-composition-table
+ $time-ppi-composition-table
+ $time-pi-relation-code
+ $time-pp-relation-code
+ $time-pi-relation-code))))
+ (n (length $time-pi-relation-code)))
+ (list
+ (lambda (atom subst)
+ (jepd-relation-composition-rewriter1 atom subst rel table n)))))
+ (assert `(forall ((?x :sort ,point-sort)
+ (?y :sort ,point-sort)
+ (?z :sort ,interval-sort)
+ ?l1
+ ?l2)
+ (implies (and ($$time-pp ?x ?y ?l1) (,relname ?y ?z ?l2))
+ (,composition ?l1 ?l2 ?x ?y ?z)))
+ :name (intern (symbol-name composition) :keyword)
+ :supported nil))
+ ;;; PI * IP -> PP composition
+ (let ((composition (intern (to-string relname :-pi-composition) :snark)))
+ (declare-relation1
+ composition 5
+ :rewrite-code (let ((rel (input-relation-symbol '$$time-pp 3))
+ (table (or *time-pip-composition-table*
+ (setf *time-pip-composition-table* (make-composition-table
+ $time-pip-composition-table
+ $time-pp-relation-code
+ $time-pi-relation-code
+ $time-ip-relation-code))))
+ (n (length $time-pp-relation-code)))
+ (list
+ (lambda (atom subst)
+ (jepd-relation-composition-rewriter1 atom subst rel table n)))))
+ (assert `(forall ((?x :sort ,point-sort)
+ (?y :sort ,interval-sort)
+ (?z :sort ,point-sort)
+ ?l1
+ ?l2)
+ (implies (and (,relname ?x ?y ?l1) (,relname ?z ?y ?l2))
+ (,composition ?l1 ?l2 ?x ?y ?z)))
+ :name (intern (symbol-name composition) :keyword)
+ :supported nil))
+ ;;; IP * PI -> II composition
+ (let ((composition (intern (to-string relname :-pi-composition2) :snark)))
+ (declare-relation1
+ composition 5
+ :rewrite-code (let ((rel (input-relation-symbol '$$time-ii 3))
+ (table (or *time-ipi-composition-table*
+ (setf *time-ipi-composition-table* (make-composition-table
+ $time-ipi-composition-table
+ $time-ii-relation-code
+ $time-ip-relation-code
+ $time-pi-relation-code))))
+ (n (length $time-ii-relation-code)))
+ (list
+ (lambda (atom subst)
+ (jepd-relation-composition-rewriter1 atom subst rel table n)))))
+ (assert `(forall ((?x :sort ,interval-sort)
+ (?y :sort ,point-sort)
+ (?z :sort ,interval-sort)
+ ?l1
+ ?l2)
+ (implies (and (,relname ?y ?x ?l1) (,relname ?y ?z ?l2))
+ (,composition ?l1 ?l2 ?x ?y ?z)))
+ :name (intern (symbol-name composition) :keyword)
+ :supported nil))))
+ (when dates
+ (declare-date-functions :intervals intervals :points points))
+ nil))
+
+(defun jepd-atom-to-lisp (head args subst &optional names more-names)
+ (let* ((arg1 (term-to-lisp (pop args) subst))
+ (arg2 (term-to-lisp (pop args) subst))
+ (arg3 (first args))
+ (rels (and names (1-indexes arg3 subst))))
+ (cond
+ ((null rels)
+ (list (function-name head) arg1 arg2 (term-to-lisp arg3 subst)))
+ ((null (rest rels))
+ (list (function-name (input-relation-symbol (nth (first rels) names) 2)) arg1 arg2))
+ ((do ((l more-names (cddr l)))
+ ((null l)
+ nil)
+ (when (equal rels (second l))
+ (return (list (function-name (input-relation-symbol (first l) 2)) arg1 arg2)))))
+ (t
+ (let ((l nil) l-last)
+ (dolist (rel rels)
+ (collect (list (function-name (input-relation-symbol (nth rel names) 2)) arg1 arg2) l))
+ (cons 'or-jepd l))))))
+
+(defun equal-jepd-relation-atom-args-p (args1 args2 subst invert)
+ ;; lists of possible relations in third argument are compared by variant-p instead of equal-p
+ ;; after inversion; all the variables in a list of possible relations are required to be unique,
+ ;; so their exact identity is unimportant
+ (let ((x1 (pop args1)) (y1 (pop args1)) (rels1 (first args1))
+ (x2 (pop args2)) (y2 (pop args2)) (rels2 (first args2)))
+ (or (and (equal-p x1 x2 subst)
+ (equal-p y1 y2 subst)
+ (equal-p rels1 rels2 subst))
+ (and (dereference rels1 subst :if-compound-cons t)
+ (dereference rels2 subst :if-compound-cons t)
+ (and (equal-p x1 y2 subst)
+ (equal-p y1 x2 subst)
+ (variant-p rels1 (reversem rels2 invert) subst))))))
+
+(defun variant-jepd-relation-atom-args (cc args1 args2 subst matches invert)
+ (let ((x1 (pop args1)) (y1 (pop args1)) (rels1 (first args1))
+ (x2 (pop args2)) (y2 (pop args2)) (rels2 (first args2)))
+ (prog->
+ (variant x1 x2 subst matches ->* matches)
+ (variant y1 y2 subst matches ->* matches)
+ (variant rels1 rels2 subst matches ->* matches)
+ (funcall cc matches))
+ (when (and (dereference rels1 subst :if-compound-cons t)
+ (dereference rels2 subst :if-compound-cons t))
+ (prog->
+ (quote nil -> rels2*)
+ (variant x1 y2 subst matches ->* matches)
+ (variant y1 x2 subst matches ->* matches)
+ (variant rels1 (or rels2* (setf rels2* (reversem rels2 invert))) subst matches ->* matches)
+ (funcall cc matches)))))
+
+(defun unify-jepd-relation-atom-args (cc args1 args2 subst invert)
+ (let ((x1 (pop args1)) (y1 (pop args1)) (rels1 (first args1))
+ (x2 (pop args2)) (y2 (pop args2)) (rels2 (first args2)))
+ (prog->
+ (unify x1 x2 subst ->* subst)
+ (unify y1 y2 subst ->* subst)
+ (unify rels1 rels2 subst ->* subst)
+ (funcall cc subst))
+ (cond
+ ((dereference rels2 subst :if-compound-cons t)
+ (prog->
+ (quote nil -> rels2*)
+ (unify x1 y2 subst ->* subst)
+ (unify y1 x2 subst ->* subst)
+ (unify rels1 (or rels2* (setf rels2* (reversem rels2 invert))) subst ->* subst)
+ (funcall cc subst)))
+ ((dereference rels1 subst :if-compound-cons t)
+ (prog->
+ (quote nil -> rels1*)
+ (unify y1 x2 subst ->* subst)
+ (unify x1 y2 subst ->* subst)
+ (unify (or rels1* (setf rels1* (reversem rels1 invert))) rels2 subst ->* subst)
+ (funcall cc subst))))))
+
+(defun jepd-relation-atom-rewriter (atom subst)
+ ;; replace by true
+ ;; atoms like (time-pp-relation a b (list 1 1 1))
+ ;; that can be produced by factoring
+ (let ((v (third (args atom))))
+ (if (dereference
+ v subst
+ :if-compound-cons (dolist (x v t)
+ (dereference x subst :if-variable (return nil))))
+ true
+ none)))
+
+;;; jepd-relations.lisp
diff --git a/snark-20120808r02/src/knuth-bendix-ordering2.abcl b/snark-20120808r02/src/knuth-bendix-ordering2.abcl
new file mode 100644
index 0000000..a12eb76
Binary files /dev/null and b/snark-20120808r02/src/knuth-bendix-ordering2.abcl differ
diff --git a/snark-20120808r02/src/knuth-bendix-ordering2.lisp b/snark-20120808r02/src/knuth-bendix-ordering2.lisp
new file mode 100644
index 0000000..464b110
--- /dev/null
+++ b/snark-20120808r02/src/knuth-bendix-ordering2.lisp
@@ -0,0 +1,205 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: knuth-bendix-ordering2.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; this implementation is inspired by
+;;; Bernd L\"{o}chner's "Things to Know When Implementing KBO" in JAR (2006)
+;;;
+;;; extensions:
+;;; status to allow not just left-to-right lexical ordering
+;;; weight multipliers (must be >= 1) for arguments of ordinary fixed arity functions for linear polynomial ordering
+;;; (declare-function 'commutator 2 :kbo-weight '(5 3 3)) etc. in overbeek1e example
+;;; flattening of argument lists for associative functions
+;;; argument lists are greater in ordering than their prefixes
+;;;
+;;; should use integer or rational weights (not floats) for exact arithmetic
+;;;
+;;; re :multiset status
+;;; even if (f 2) exceeds (f 1 1), it cannot exceed (f 1 1 ... 1) for arbitrary number of 1s
+
+(definline variable-kbo-weight (var)
+ (let ((w (kbo-variable-weight?)))
+ (if (numberp w) w (funcall w var))))
+
+(defun kbo-evaluate-term (term subst mult weight vars)
+ (dereference
+ term subst
+ :if-variable (values (+ weight (* mult (variable-kbo-weight term))) (acons+ term mult vars))
+ :if-constant (values (+ weight (* mult (constant-kbo-weight term))) vars)
+ :if-compound (let* ((head (head term))
+ (args (args term))
+ (w (function-kbo-weight head))
+ (ws (if (consp w) (rest w) nil))
+ (w (if (consp w) (first w) w)))
+ (cond
+ ((function-associative head)
+ (setf weight (+ weight (* mult w (max 1 (- (length args) 1))))))
+ (t
+ (setf weight (+ weight (* mult w)))))
+ (kbo-evaluate-terms args subst mult weight vars ws))))
+
+(defun kbo-evaluate-terms (terms subst mult weight vars ws)
+ (dolist (term terms)
+ (setf (values weight vars) (kbo-evaluate-term term subst (if (null ws) mult (* mult (pop ws))) weight vars)))
+ (values weight vars))
+
+(defun kbo-compare-terms (x y &optional subst testval (mult 1))
+ (dereference2
+ x y subst
+ :if-variable*variable (if (eq x y)
+ (values '= 0 nil)
+ (values '? (* mult (- (variable-kbo-weight x) (variable-kbo-weight y))) (acons+ x mult (acons+ y (- mult) nil))))
+ :if-constant*constant (if (eql x y)
+ (values '= 0 nil)
+ (let ((weight (* mult (- (constant-kbo-weight x) (constant-kbo-weight y)))))
+ (values
+ (cond
+ ((> weight 0) '>)
+ ((< weight 0) '<)
+ (t (symbol-ordering-compare x y)))
+ weight
+ nil)))
+ :if-variable*constant (values '? (* mult (- (variable-kbo-weight x) (constant-kbo-weight y))) (acons+ x mult nil))
+ :if-constant*variable (values '? (* mult (- (constant-kbo-weight x) (variable-kbo-weight y))) (acons+ y (- mult) nil))
+ :if-variable*compound (mvlet (((values weight vars) (kbo-evaluate-term y subst (- mult) (* mult (variable-kbo-weight x)) (acons+ x mult nil))))
+ (values (if (alist-notany-plusp vars) '< '?) weight vars))
+ :if-compound*variable (mvlet (((values weight vars) (kbo-evaluate-term x subst mult (* mult (- (variable-kbo-weight y))) (acons+ y (- mult) nil))))
+ (values (if (alist-notany-minusp vars) '> '?) weight vars))
+ :if-constant*compound (mvlet (((values weight vars) (kbo-evaluate-term y subst (- mult) (* mult (constant-kbo-weight x)) nil)))
+ (values
+ (cond
+ ((> weight 0) (if (alist-notany-minusp vars) '> '?))
+ ((< weight 0) '<)
+ (t (ecase (symbol-ordering-compare x (head y))
+ (> (if (alist-notany-minusp vars) '> '?))
+ (< '<)
+ (? '?))))
+ weight
+ vars))
+ :if-compound*constant (mvlet (((values weight vars) (kbo-evaluate-term x subst mult (* mult (- (constant-kbo-weight y))) nil)))
+ (values
+ (cond
+ ((> weight 0) '>)
+ ((< weight 0) (if (alist-notany-plusp vars) '< '?))
+ (t (ecase (symbol-ordering-compare (head x) y)
+ (> '>)
+ (< (if (alist-notany-plusp vars) '< '?))
+ (? '?))))
+ weight
+ vars))
+ :if-compound*compound (cond
+ ((eq x y)
+ (values '= 0 nil))
+ (t
+ (let ((head (head x)))
+ (cond
+ ((not (eq head (head y)))
+ (mvlet* (((values weight vars) (kbo-evaluate-term x subst mult 0 nil))
+ ((values weight vars) (kbo-evaluate-term y subst (- mult) weight vars)))
+ (values
+ (cond
+ ((> weight 0) (if (alist-notany-minusp vars) '> '?))
+ ((< weight 0) (if (alist-notany-plusp vars) '< '?))
+ (t (ecase (symbol-ordering-compare head (head y))
+ (> (if (alist-notany-minusp vars) '> '?))
+ (< (if (alist-notany-plusp vars) '< '?))
+ (? '?))))
+ weight
+ vars)))
+ (t
+ (let* ((xargs (args x))
+ (yargs (args y))
+ (status (function-kbo-status head))
+ (w (function-kbo-weight head))
+ (ws (if (consp w) (rest w) nil))
+ (w (if (consp w) (first w) w))
+ (weight 0)
+ (vars nil)
+ com)
+ (cond
+ ((function-associative head)
+ (setf xargs (flatten-args head xargs subst))
+ (setf yargs (flatten-args head yargs subst))))
+ (ecase status
+ ((:left-to-right :right-to-left)
+ (let ((xargs (if (eq :right-to-left status) (reverse xargs) xargs))
+ (yargs (if (eq :right-to-left status) (reverse yargs) yargs))
+ (ws (if (null ws) nil (if (eq :right-to-left status) (reverse ws) ws))))
+ (loop
+ (cond
+ ((or (null xargs) (null yargs))
+ (cond
+ (xargs
+ (setf com '>)
+ (setf (values weight vars) (kbo-evaluate-terms xargs subst mult weight vars ws)))
+ (yargs
+ (setf com '<)
+ (setf (values weight vars) (kbo-evaluate-terms yargs subst (- mult) weight vars ws)))
+ (t
+ (setf com '=)))
+ (return))
+ ((not (eq '= (setf (values com weight vars) (kbo-compare-terms (first xargs) (first yargs) subst nil (if (null ws) mult (* mult (pop ws)))))))
+ (setf (values weight vars) (kbo-evaluate-terms (rest xargs) subst mult weight vars ws))
+ (setf (values weight vars) (kbo-evaluate-terms (rest yargs) subst (- mult) weight vars ws))
+ (return))
+ (t
+ (setf xargs (rest xargs))
+ (setf yargs (rest yargs)))))))
+ ((:commutative :multiset)
+ (cond
+ ((and (eq :commutative status) (or (rrest xargs) (rrest yargs)))
+ (setf (values com weight vars)
+ (kbo-compare-terms (make-compound* *a-function-with-left-to-right-ordering-status*
+ (make-compound *a-function-with-multiset-ordering-status* (first xargs) (second xargs))
+ (rrest xargs))
+ (make-compound* *a-function-with-left-to-right-ordering-status*
+ (make-compound *a-function-with-multiset-ordering-status* (first yargs) (second yargs))
+ (rrest yargs))
+ subst
+ testval
+ mult)))
+ (t
+ (unless (eq '= (setf com (compare-term-multisets #'kbo-compare-terms xargs yargs subst nil)))
+ (setf (values weight vars) (kbo-evaluate-terms xargs subst mult weight vars ws))
+ (setf (values weight vars) (kbo-evaluate-terms yargs subst (- mult) weight vars ws))))))
+ ((:ac :none)
+ ;; (unimplemented)
+ (cond
+ ((equal-p x y subst)
+ (setf com '=))
+ (t
+ (setf com '?)
+ (setf (values weight vars) (kbo-evaluate-terms xargs subst mult weight vars ws))
+ (setf (values weight vars) (kbo-evaluate-terms yargs subst (- mult) weight vars ws))))))
+ (cond
+ ((function-associative head)
+ (setf weight (+ weight (* mult w (- (max 1 (- (length xargs) 1)) (max 1 (- (length yargs) 1))))))))
+ (values
+ (cond
+ ((eq '= com) '=)
+ ((> weight 0) (if (alist-notany-minusp vars) '> '?))
+ ((< weight 0) (if (alist-notany-plusp vars) '< '?))
+ ((eq '> com) (if (alist-notany-minusp vars) '> '?))
+ ((eq '< com) (if (alist-notany-plusp vars) '< '?))
+ (t '?))
+ weight
+ vars)))))))))
+
+;;; knuth-bendix-ordering2.lisp EOF
diff --git a/snark-20120808r02/src/lisp-system.lisp b/snark-20120808r02/src/lisp-system.lisp
new file mode 100644
index 0000000..d1dfdef
--- /dev/null
+++ b/snark-20120808r02/src/lisp-system.lisp
@@ -0,0 +1,102 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
+;;; File: lisp-system.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :common-lisp-user)
+
+(defpackage :snark-lisp
+ (:use :common-lisp)
+ (:export
+
+ ;; defined in mvlet.lisp
+ #:mvlet #:mvlet*
+
+ ;; defined in progc.lisp
+ #:prog->
+ #:*prog->-function-second-forms*
+ #:*prog->-special-forms*
+
+ ;; defined in lisp.lisp
+ #:none
+ #:true #:false
+ #:definline
+ #:neq #:neql #:nequal #:nequalp
+ #:if-let #:when-let
+ #:iff #:implies
+ #:kwote #:unquote
+ #:rrest #:rrrest #:rrrrest
+ #:mklist #:firstn #:consn #:leafp
+ #:naturalp #:ratiop
+ #:carc #:cdrc #:caarcc #:cadrcc #:cdarcc #:cddrcc
+ #:lcons
+ #:cons-unless-nil #:push-unless-nil #:pushnew-unless-nil
+ #:dotails #:dopairs
+ #:choose
+ #:integers-between #:ints
+ #:length= #:length< #:length<= #:length> #:length>=
+ #:acons+ #:alist-notany-plusp #:alist-notany-minusp
+ #:cons-count
+ #:char-invert-case
+ #:to-string
+ #:find-or-make-package
+ #:percentage
+ #:print-current-time
+ #:leap-year-p #:days-per-month #:month-number
+ #:print-args
+ #:define-plist-slot-accessor
+ #:*print-pretty2*
+ #:with-standard-io-syntax2
+ #:quit
+
+ ;; defined in collectors.lisp
+ #:make-collector #:collector-value #:collect-item #:collect-list
+ #:make-queue #:queue-empty-p #:enqueue #:dequeue
+ #:collect #:ncollect
+
+ ;; defined in map-file.lisp
+ #:mapnconc-stream-forms #:mapnconc-stream-lines
+ #:mapnconc-file-forms #:mapnconc-file-lines
+ #:read-file #:read-file-lines #:read-file-to-string
+
+ ;; defined in clocks.lisp
+ #:initialize-clocks #:print-clocks
+ #:with-clock-on #:with-clock-off
+ #:total-run-time
+ #:print-incremental-time-used
+
+ ;; defined in counters.lisp
+ #:make-counter
+ #:increment-counter #:decrement-counter
+ #:counter-value #:counter-values
+ #:princf
+
+ ;; defined in pattern-match.lisp
+ #:pattern-match
+
+ ;; defined in topological-sort.lisp
+ #:topological-sort* #:topological-sort
+
+ ;; undefined symbols used by snark
+ #:implied-by #:xor #:nand #:nor
+ #:forall #:exists
+ #:$$cons #:$$list #:$$list*
+ ))
+
+(loads "mvlet" "progc" "lisp" "collectors" "map-file" "clocks" "counters" "pattern-match" "topological-sort")
+
+;;; lisp-system.lisp EOF
diff --git a/snark-20120808r02/src/lisp.abcl b/snark-20120808r02/src/lisp.abcl
new file mode 100644
index 0000000..4cc8caa
Binary files /dev/null and b/snark-20120808r02/src/lisp.abcl differ
diff --git a/snark-20120808r02/src/lisp.lisp b/snark-20120808r02/src/lisp.lisp
new file mode 100644
index 0000000..6957ed6
--- /dev/null
+++ b/snark-20120808r02/src/lisp.lisp
@@ -0,0 +1,566 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
+;;; File: lisp.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-lisp)
+
+(defconstant none '$$none) ;special null value to use when NIL won't do
+(defconstant true '$$true)
+(defconstant false '$$false)
+
+(defmacro definline (name lambda-list &body body)
+ #-clisp
+ `(progn
+ (defun ,name ,lambda-list ,@body)
+ (define-compiler-macro ,name (&rest arg-list)
+ (cons '(lambda ,lambda-list ,@body) arg-list)))
+ #+clisp
+ `(defun ,name ,lambda-list ,@body))
+
+(definline neq (x y)
+ (not (eq x y)))
+
+(definline neql (x y)
+ (not (eql x y)))
+
+(definline nequal (x y)
+ (not (equal x y)))
+
+(definline nequalp (x y)
+ (not (equalp x y)))
+
+(definline iff (x y)
+ (eq (not x) (not y)))
+
+(defmacro implies (x y)
+ ;; implies is a macro so that y is not evaluated if x is false
+ `(if ,x ,y t))
+
+(defmacro if-let (binding thenform elseform)
+ (let ((block (gensym)) (temp (gensym)))
+ `(block ,block
+ (let ((,temp ,(second binding)))
+ (when ,temp
+ (return-from ,block
+ (let ((,(first binding) ,temp))
+ ,thenform))))
+ ,elseform)))
+
+(defmacro when-let (binding &rest forms)
+ `(if-let ,binding (progn ,@forms) nil))
+
+(defun kwote (x &optional selectively)
+ (if (implies selectively (not (constantp x)))
+ (list 'quote x)
+ x))
+
+(defun unquote (x)
+ (if (and (consp x) (eq 'quote (first x)))
+ (second x)
+ x))
+
+(definline rrest (list)
+ (cddr list))
+
+(definline rrrest (list)
+ (cdddr list))
+
+(definline rrrrest (list)
+ (cddddr list))
+
+(definline mklist (x)
+ (if (listp x) x (list x)))
+
+(defun firstn (list num)
+ ;; return a new list that contains the first num elements of list
+ (declare (type integer num))
+ (cond
+ ((or (eql 0 num) (atom list))
+ nil)
+ (t
+ (cons (first list) (firstn (rest list) (- num 1))))))
+
+(defun consn (x y num)
+ ;; cons x and y n times
+ ;; (cons 'a '(b) 3) = (a a a b)
+ (declare (type integer num))
+ (dotimes (dummy num)
+ (declare (type integer dummy) (ignorable dummy))
+ (push x y))
+ y)
+
+(defun leafp (x y)
+ (if (atom y)
+ (eql x y)
+ (or (leafp x (car y)) (leafp x (cdr y)))))
+
+(defun naturalp (x)
+ (and (integerp x) (not (minusp x))))
+
+(defun ratiop (x)
+ (and (rationalp x) (not (integerp x))))
+
+(defmacro carc (x)
+ `(car (the cons ,x)))
+
+(defmacro cdrc (x)
+ `(cdr (the cons ,x)))
+
+(defmacro caarcc (x)
+ `(carc (carc ,x)))
+
+(defmacro cadrcc (x)
+ `(carc (cdrc ,x)))
+
+(defmacro cdarcc (x)
+ `(cdrc (carc ,x)))
+
+(defmacro cddrcc (x)
+ `(cdrc (cdrc ,x)))
+
+(defmacro lcons (a* b* ab)
+ ;; (lcons a* b* ab) does lazy cons of a* and b*
+ ;; lcons does not evaluate a* or b* and returns nil if ab is nil
+ ;; lcons does not evaluate b* and treats it as nil if (cdr ab) is nil
+ ;; lcons returns ab if a* = (car ab) and b* = (cdr ab)
+ ;; otherwise, lcons conses a* and b*
+ ;;
+ ;; lcons is useful for writing functions that map over lists
+ ;; and return a modified list without unnecessary consing
+ ;; for example, the following applies a substitution to a list of terms
+ ;; (defun instantiate-list (terms subst)
+ ;; (lcons (instantiate-term (first terms) subst)
+ ;; (instantiate-list (rest terms) subst)
+ ;; terms))
+ (assert (symbolp ab))
+ (let ((tempa (gensym)) (tempb (gensym)) (tempa* (gensym)) (tempb* (gensym)))
+ (setf a* (sublis (list (cons `(car ,ab) tempa)
+ (cons `(carc ,ab) tempa)
+ (cons `(first ,ab) tempa)
+ (cons `(nth 0 ,ab) tempa))
+ a*
+ :test #'equal))
+ (setf b* (sublis (list (cons `(cdr ,ab) tempb)
+ (cons `(cdrc ,ab) tempb)
+ (cons `(rest ,ab) tempb)
+ (cons `(nthcdr 1 ,ab) tempb))
+ b*
+ :test #'equal))
+ `(if (null ,ab)
+ nil
+ (let* ((,tempa (car ,ab))
+ (,tempa* ,a*)
+ (,tempb (cdrc ,ab)))
+ (if (null ,tempb)
+ (if (eql ,tempa ,tempa*)
+ ,ab
+ (cons ,tempa* nil))
+ (let ((,tempb* ,b*))
+ (if (and (eql ,tempb ,tempb*)
+ (eql ,tempa ,tempa*))
+ ,ab
+ (cons ,tempa* ,tempb*))))))))
+
+(definline cons-unless-nil (x &optional y)
+ ;; returns y if x is nil, otherwise returns (cons x y)
+ ;; if y is omitted: returns nil if x is nil, otherwise (list x)
+ (if (null x) y (cons x y)))
+
+(defmacro push-unless-nil (item place)
+ ;; doesn't evaluate place if item is nil
+ ;; always returns nil
+ (let ((v (gensym)))
+ `(let ((,v ,item))
+ (unless (null ,v)
+ (push ,v ,place)
+ nil))))
+
+(defmacro pushnew-unless-nil (item place &rest options)
+ ;; doesn't evaluate place or options if item is nil
+ ;; always returns nil
+ (let ((v (gensym)))
+ `(let ((,v ,item))
+ (unless (null ,v)
+ (pushnew ,v ,place ,@options)
+ nil))))
+
+(defmacro dotails ((var listform &optional resultform) &body body)
+ ;; dotails is just like dolist except the variable is bound
+ ;; to successive tails instead of successive elements of the list
+ `(do ((,var ,listform (rest ,var)))
+ ((endp ,var)
+ ,resultform)
+ ,@body))
+
+(defmacro dopairs ((var1 var2 listform &optional resultform) &body body)
+ ;; (dopairs (x y '(a b c)) (print (list x y))) prints (a b), (a c), and (b c)
+ ;; doesn't handle declarations in body correctly
+ (let ((l1 (gensym)) (l2 (gensym)) (loop (gensym)))
+ `(do ((,l1 ,listform) ,var1 ,var2 ,l2)
+ ((endp ,l1)
+ ,resultform)
+ (setf ,var1 (pop ,l1))
+ (setf ,l2 ,l1)
+ ,loop
+ (unless (endp ,l2)
+ (setf ,var2 (pop ,l2))
+ ,@body
+ (go ,loop)))))
+
+(defun choose (function list k)
+ ;; apply function to lists of k items taken from list
+ (labels
+ ((choose* (cc l k n)
+ (cond
+ ((eql 0 k)
+ (funcall cc nil))
+ ((eql n k)
+ (funcall cc l))
+ (t
+ (prog->
+ (decf n)
+ (pop l -> x)
+ (choose* l (- k 1) n ->* res)
+ (funcall cc (cons x res)))
+ (prog->
+ (choose* l k n ->* res)
+ (funcall cc res))))))
+ (let ((len (length list)))
+ (when (minusp k)
+ (incf k len))
+ (cl:assert (<= 0 k len))
+ (choose* function list k len)
+ nil)))
+
+(defun integers-between (low high)
+ ;; list of integers in [low,high]
+ (let ((i high)
+ (result nil))
+ (loop
+ (when (< i low)
+ (return result))
+ (push i result)
+ (decf i))))
+
+(defun ints (low high)
+ ;; list of integers in [low,high]
+ (integers-between low high))
+
+(defun length= (x y)
+ ;; if y is an integer then (= (length x) y)
+ ;; if x is an integer then (= x (length y))
+ ;; otherwise (= (length x) (length y))
+ (cond
+ ((or (not (listp y)) (when (not (listp x)) (psetq x y y x) t))
+ (and (<= 0 y)
+ (loop
+ (cond
+ ((endp x)
+ (return (eql 0 y)))
+ ((eql 0 y)
+ (return nil))
+ (t
+ (setf x (rest x) y (- y 1)))))))
+ (t
+ (loop
+ (cond
+ ((endp x)
+ (return (endp y)))
+ ((endp y)
+ (return nil))
+ (t
+ (setf x (rest x) y (rest y))))))))
+
+(defun length< (x y)
+ ;; if y is an integer then (< (length x) y)
+ ;; if x is an integer then (< x (length y))
+ ;; otherwise (< (length x) (length y))
+ (cond
+ ((not (listp y))
+ (and (<= 1 y)
+ (loop
+ (cond
+ ((endp x)
+ (return t))
+ ((eql 1 y)
+ (return nil))
+ (t
+ (setf x (rest x) y (- y 1)))))))
+ ((not (listp x))
+ (or (> 0 x)
+ (loop
+ (cond
+ ((endp y)
+ (return nil))
+ ((eql 0 x)
+ (return t))
+ (t
+ (setf x (- x 1) y (rest y)))))))
+ (t
+ (loop
+ (cond
+ ((endp x)
+ (return (not (endp y))))
+ ((endp y)
+ (return nil))
+ (t
+ (setf x (rest x) y (rest y))))))))
+
+(defun length<= (x y)
+ ;; if y is an integer then (<= (length x) y)
+ ;; if x is an integer then (<= x (length y))
+ ;; otherwise (<= (length x) (length y))
+ (cond
+ ((not (listp y))
+ (and (<= 0 y)
+ (loop
+ (cond
+ ((endp x)
+ (return t))
+ ((eql 0 y)
+ (return nil))
+ (t
+ (setf x (rest x) y (- y 1)))))))
+ ((not (listp x))
+ (or (> 1 x)
+ (loop
+ (cond
+ ((endp y)
+ (return nil))
+ ((eql 1 x)
+ (return t))
+ (t
+ (setf x (- x 1) y (rest y)))))))
+ (t
+ (loop
+ (cond
+ ((endp x)
+ (return t))
+ ((endp y)
+ (return nil))
+ (t
+ (setf x (rest x) y (rest y))))))))
+
+(definline length> (x y)
+ (length< y x))
+
+(definline length>= (x y)
+ (length<= y x))
+
+(defun acons+ (key delta alist &key test)
+ ;; creates a new association list with datum associated with key adjusted up or down by delta
+ ;; omits pairs with datum 0
+ (labels
+ ((ac+ (alist)
+ (declare (type cons alist))
+ (let ((pair (first alist))
+ (alist1 (rest alist)))
+ (declare (type cons pair))
+ (cond
+ ((if test (funcall test key (car pair)) (eql key (car pair)))
+ (let ((datum (+ (cdr pair) delta)))
+ (if (= 0 datum) alist1 (cons (cons key datum) alist1))))
+ ((null alist1)
+ alist)
+ (t
+ (let ((alist1* (ac+ alist1)))
+ (if (eq alist1 alist1*) alist (cons pair alist1*))))))))
+ (cond
+ ((= 0 delta)
+ alist)
+ ((null alist)
+ (cons (cons key delta) nil))
+ (t
+ (let ((alist* (ac+ alist)))
+ (if (eq alist alist*) (cons (cons key delta) alist) alist*))))))
+
+(defun alist-notany-plusp (alist)
+ (dolist (pair alist t)
+ (declare (type cons pair))
+ (when (plusp (cdr pair))
+ (return nil))))
+
+(defun alist-notany-minusp (alist)
+ (dolist (pair alist t)
+ (declare (type cons pair))
+ (when (minusp (cdr pair))
+ (return nil))))
+
+(defun cons-count (x)
+ (do ((n 0 (+ 1 (cons-count (carc x)) n))
+ (x x (cdrc x)))
+ ((atom x)
+ n)))
+
+(defun char-invert-case (ch)
+ (cond
+ ((lower-case-p ch)
+ (char-upcase ch))
+ ((upper-case-p ch)
+ (char-downcase ch))
+ (t
+ ch)))
+
+(let ((case-preserved-readtable-cache nil))
+ (defun case-preserved-readtable (&optional (readtable *readtable*))
+ (cond
+ ((eq :preserve (readtable-case readtable))
+ readtable)
+ ((cdr (assoc readtable case-preserved-readtable-cache))
+ )
+ (t
+ (let ((new-readtable (copy-readtable readtable)))
+ (setf (readtable-case new-readtable) :preserve)
+ (setf case-preserved-readtable-cache (acons readtable new-readtable case-preserved-readtable-cache))
+ new-readtable)))))
+
+(defun to-string (arg &rest more-args)
+ (declare (dynamic-extent more-args))
+ (flet ((string1 (x)
+ (cond
+ ((stringp x)
+ x)
+ ((symbolp x)
+ (symbol-name x))
+ ((characterp x)
+ (string x))
+ (t
+ (let ((*print-radix* nil))
+ (cond
+ ((numberp x)
+ (princ-to-string x))
+ (t
+ (let ((*readtable* (case-preserved-readtable)))
+ (princ-to-string x)))))))))
+ (if (null more-args)
+ (string1 arg)
+ (apply #'concatenate 'string (string1 arg) (mapcar #'string1 more-args)))))
+
+(defun find-or-make-package (pkg)
+ (cond
+ ((packagep pkg)
+ pkg)
+ ((find-package pkg)
+ )
+ (t
+ (cerror "Make a package named ~A." "There is no package named ~A." (string pkg))
+ (make-package pkg :use '(:common-lisp)))))
+
+(defun percentage (m n)
+ (values (round (* 100 m) n)))
+
+(defun print-time (year month date hour minute second &optional (destination *standard-output*) (basic nil))
+ ;; per the ISO 8601 standard
+ (format destination
+ (if basic
+ "~4D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D" ;20020405T011216
+ "~4D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D") ;2002-04-05T01:12:16
+ year month date hour minute second))
+
+(defun print-universal-time (utime &optional (destination *standard-output*) (basic nil))
+ (mvlet (((values second minute hour date month year) (decode-universal-time utime)))
+ (print-time year month date hour minute second destination basic)))
+
+(defun print-current-time (&optional (destination *standard-output*) (basic nil))
+ (print-universal-time (get-universal-time) destination basic))
+
+(defun leap-year-p (year)
+ (and (eql 0 (mod year 4))
+ (implies (eql 0 (mod year 100))
+ (eql 0 (mod year 400)))))
+
+(defun days-per-month (month year)
+ (let ((month (month-number month)))
+ (cl:assert month)
+ (case month
+ (2
+ (if (leap-year-p year) 29 28))
+ ((4 6 9 11)
+ 30)
+ (otherwise
+ 31))))
+
+(defun month-number (month)
+ (cond
+ ((or (symbolp month) (stringp month))
+ (cdr (assoc (string month)
+ '(("JAN" . 1) ("JANUARY" . 1)
+ ("FEB" . 2) ("FEBRUARY" . 2)
+ ("MAR" . 3) ("MARCH" . 3)
+ ("APR" . 4) ("APRIL" . 4)
+ ("MAY" . 5)
+ ("JUN" . 6) ("JUNE" . 6)
+ ("JUL" . 7) ("JULY" . 7)
+ ("AUG" . 8) ("AUGUST" . 8)
+ ("SEP" . 9) ("SEPTEMBER" . 9)
+ ("OCT" . 10) ("OCTOBER" . 10)
+ ("NOV" . 11) ("NOVEMBER" . 11)
+ ("DEC" . 12) ("DECEMBER" . 12))
+ :test #'string-equal)))
+ ((and (integerp month) (<= 1 month 12))
+ month)
+ (t
+ nil)))
+
+(defun print-args (&rest args)
+ (declare (dynamic-extent args))
+ (print args)
+ nil)
+
+(defmacro define-plist-slot-accessor (type name)
+ (let ((fun (intern (to-string type "-" name) :snark))
+ (plist (intern (to-string type :-plist) :snark)))
+ `(progn
+ (#-(or allegro lispworks) definline #+(or allegro lispworks) defun ,fun (x)
+ (getf (,plist x) ',name))
+ (defun (setf ,fun) (value x)
+ (if (null value)
+ (progn (remf (,plist x) ',name) nil)
+ (setf (getf (,plist x) ',name) value))))))
+
+(defvar *print-pretty2* nil)
+
+#+ignore
+(defmacro with-standard-io-syntax2 (&body forms)
+ (let ((pkg (gensym)))
+ `(let ((,pkg *package*))
+ (with-standard-io-syntax
+ (let ((*package* ,pkg)
+ (*print-case* :downcase)
+ (*print-pretty* *print-pretty2*)
+;; #+ccl (ccl:*print-abbreviate-quote* nil)
+;; #+cmu (pretty-print::*print-pprint-dispatch* (pretty-print::make-pprint-dispatch-table))
+;; #+sbcl (sb-pretty::*print-pprint-dispatch* (sb-pretty::make-pprint-dispatch-table))
+ #+clisp (*print-readably* nil) ;stop clisp from printing decimal points, #1=, etc
+ )
+ ,@forms)))))
+
+(defmacro with-standard-io-syntax2 (&body forms)
+ `(let ((*print-pretty* *print-pretty2*)
+;; #+ccl (ccl:*print-abbreviate-quote* nil)
+;; #+cmu (pretty-print::*print-pprint-dispatch* (pretty-print::make-pprint-dispatch-table))
+;; #+sbcl (sb-pretty::*print-pprint-dispatch* (sb-pretty::make-pprint-dispatch-table))
+ #+clisp (*print-readably* nil) ;stop clisp from printing decimal points, #1=, etc
+ )
+ ,@forms))
+
+(defun quit ()
+ #+(or ccl cmu sbcl clisp lispworks) (common-lisp-user::quit)
+ #+allegro (excl::exit))
+
+;;; lisp.lisp EOF
diff --git a/snark-20120808r02/src/loads.lisp b/snark-20120808r02/src/loads.lisp
new file mode 100644
index 0000000..15f7950
--- /dev/null
+++ b/snark-20120808r02/src/loads.lisp
@@ -0,0 +1,30 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
+;;; File: loads.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2004.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :common-lisp-user)
+
+(defun loads (&rest names)
+ (dolist (name names)
+ (let ((file (make-pathname :name name :defaults *load-truename*)))
+ (declare (special *compile-me*))
+ (load (if (and (boundp '*compile-me*) *compile-me*)
+ (compile-file file)
+ (or (probe-file (compile-file-pathname file)) file))))))
+
+;;; loads.lisp EOF
diff --git a/snark-20120808r02/src/main.abcl b/snark-20120808r02/src/main.abcl
new file mode 100644
index 0000000..1532787
Binary files /dev/null and b/snark-20120808r02/src/main.abcl differ
diff --git a/snark-20120808r02/src/main.lisp b/snark-20120808r02/src/main.lisp
new file mode 100644
index 0000000..f3523ac
--- /dev/null
+++ b/snark-20120808r02/src/main.lisp
@@ -0,0 +1,2528 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: main.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(declaim
+ (special
+ ordering-is-total
+ *printing-deleted-messages*
+ *agenda*
+ ))
+
+(defvar options-print-mode t)
+
+(defvar *snark-is-running* nil)
+(defvar *agenda-of-false-rows-to-process*)
+(defvar *agenda-of-new-embeddings-to-process*)
+(defvar *agenda-of-input-rows-to-give*)
+(defvar *agenda-of-input-rows-to-process*)
+(defvar *agenda-of-backward-simplifiable-rows-to-process*)
+(defvar *agenda-of-rows-to-process*)
+(defvar *agenda-of-rows-to-give*)
+
+(defvar *proof*)
+
+(defvar *false-rows*)
+(defvar *constraint-rows*)
+(defvar *hint-rows*)
+
+(defvar *manual-ordering-results*)
+
+(defvar critique-options t)
+
+(defvar *propositional-abstraction-of-input-wffs*)
+
+(defvar *negative-hyperresolution*)
+
+(defvar *find-else-substitution* nil)
+
+(defvar *processing-row* nil)
+
+(defvar *hints-subsumed*)
+
+(declaim
+ (special
+ rewrite-strategy
+ clause-subsumption
+ subsumption-mark
+ *rewrites-used*
+ ))
+
+(defvar recursive-unstore nil)
+
+(defun critique-options ()
+ (unless options-have-been-critiqued
+ (when (print-options-when-starting?)
+ (print-options))
+ (unless (or (use-resolution?)
+ (use-hyperresolution?)
+ (use-negative-hyperresolution?)
+ (use-ur-resolution?)
+ (use-paramodulation?)
+ (use-ur-pttp?)
+ (use-resolve-code?))
+ (warn "Neither resolution nor paramodulation are specified."))
+ (setf options-have-been-critiqued t))
+ nil)
+
+(defvar *number-of-given-rows* 0)
+(defvar *number-of-backward-eliminated-rows* 0)
+(defvar *number-of-agenda-full-deleted-rows* 0)
+(declaim (type integer *number-of-given-rows* *number-of-backward-eliminated-rows*)
+ (type integer *number-of-agenda-full-deleted-rows*))
+
+(defun clear-statistics ()
+ (setf *row-count* 0)
+ (setf *number-of-rows* 0)
+ (setf *number-of-given-rows* 0)
+ (setf *number-of-backward-eliminated-rows* 0)
+ (setf *number-of-agenda-full-deleted-rows* 0)
+ nil)
+
+(defun print-summary (&key (clocks t) (term-memory t) (agenda t))
+ (format t "~%; Summary of computation:")
+ (let ((total-number-of-rows *row-count*))
+ (format t "~%; ~9D formulas have been input or derived (from ~D formulas)." total-number-of-rows *number-of-given-rows*)
+ (when (< 0 total-number-of-rows)
+ (format t "~%; ~9D (~2D%) were retained." *number-of-rows* (percentage *number-of-rows* total-number-of-rows))
+ (when (< 0 *number-of-rows*)
+ (let ((number-of-still-kept-wffs (rowset-size *rows*))
+ (number-of-reduced-wffs (- *number-of-backward-eliminated-rows* *number-of-agenda-full-deleted-rows*)))
+ (format t " Of these,")
+ (unless (eql 0 number-of-reduced-wffs)
+ (format t "~%; ~12D (~2D%) were simplified or subsumed later," number-of-reduced-wffs (percentage number-of-reduced-wffs *number-of-rows*)))
+ (unless (eql 0 *number-of-agenda-full-deleted-rows*)
+ (format t "~%; ~12D (~2D%) were deleted later because the agenda was full," *number-of-agenda-full-deleted-rows* (percentage *number-of-agenda-full-deleted-rows* *number-of-rows*)))
+ (format t "~%; ~12D (~2D%) are still being kept." number-of-still-kept-wffs (percentage number-of-still-kept-wffs *number-of-rows*))))))
+ (when clocks
+ (format t "~%; ")
+ (print-clocks))
+ (when term-memory
+ (format t "~%; ")
+ (print-term-memory))
+ (when agenda
+ (format t "~%; ")
+ (print-agenda))
+ nil)
+
+(defun print-rewrites (&key ancestry (test (print-rows-test?)))
+ (let ((rowset (make-rowset nil)))
+ (prog->
+ (retrieve-all-entries #'tme-rewrites ->* e rewrites)
+ (declare (ignore e))
+ (dolist rewrites ->* rewrite)
+ (unless (or (null (rewrite-row rewrite))
+ (null (rewrite-condition rewrite)))
+ (rowset-insert (rewrite-row rewrite) rowset)))
+ (let ((*rows* rowset))
+ (print-rows :ancestry ancestry :test test))))
+
+(defvar rewrites-initialized)
+
+(defparameter initialization-functions
+ (list 'clear-statistics
+ 'initialize-features
+ 'initialize-row-contexts
+ 'initialize-term-hash
+ 'initialize-simplification-ordering-compare-equality-arguments-hash-table
+ 'initialize-sort-theory
+ 'initialize-symbol-ordering
+ 'initialize-symbol-table
+ 'initialize-sort-theory2
+ 'initialize-symbol-table2
+ 'initialize-propositional-abstraction-of-input-wffs
+ 'initialize-assertion-analysis
+ 'finalize-options
+ ))
+
+(defun initialize (&key (verbose t))
+ (cond
+ (*snark-is-running*
+ (error "SNARK is already running."))
+ (t
+ (initialize-clocks)
+ (when verbose
+ (format t "~&; Running SNARK from ~A in ~A ~A~:[~; (64-bit)~] on ~A at "
+ cl-user::*snark-system-pathname*
+ (lisp-implementation-type)
+ (lisp-implementation-version)
+ (member :x86-64 *features*)
+ (machine-instance))
+ (print-current-time)
+ (format t "~%")
+ (force-output))
+;; (setf *random-state* (make-random-state t))
+ (setf *szs-conjecture* nil)
+ (initialize-numberings)
+ (initialize-options)
+ (initialize-operator-syntax)
+ (nocomment)
+ (initialize-rows2)
+ (initialize-constants)
+ (initialize-variables)
+ (setf *number-of-new-symbols* 0)
+ (setf *new-symbol-prefix* (newsym-prefix))
+ (setf *new-symbol-table* (make-hash-table))
+
+ (setf clause-subsumption t)
+ (setf subsumption-mark 0)
+
+ (setf *manual-ordering-results* nil)
+;; (dolist (modality modalatomsigns) (intensional (car modality)))
+;; (intensional 'answer) ; ???
+
+ (make-term-memory :indexing-method :path)
+ (make-feature-vector-row-index)
+ (make-feature-vector-term-index)
+ (initialize-agenda)
+ (setf rewrites-initialized nil)
+;; (store-boolean-ring-rewrites)
+ (setf ordering-is-total nil)
+ (setf *proof* nil)
+ (dolist (fn initialization-functions)
+ (funcall fn))
+ nil)))
+
+(defun initialize-rows2 ()
+ (initialize-rows)
+ (setf *false-rows* (make-rowset))
+ (setf *constraint-rows* (make-rowset))
+ (setf *hint-rows* (make-rowset))
+ nil)
+
+(defmacro with-input-functions-disabled (symbols &body body)
+ (let ((symbol-temps (mapcar (lambda (x) (declare (ignore x)) (gensym)) symbols))
+ (value-temps1 (mapcar (lambda (x) (declare (ignore x)) (gensym)) symbols))
+ (value-temps2 (mapcar (lambda (x) (declare (ignore x)) (gensym)) symbols)))
+ `(let ,(mapcar (lambda (symbol symbol-temp) `(,symbol-temp ,symbol)) symbols symbol-temps)
+ (let (,@(mapcan (lambda (symbol-temp value-temp1 value-temp2)
+ (declare (ignorable value-temp2))
+ (list `(,value-temp1 (function-input-code ,symbol-temp))
+;; `(,value-temp2 (function-logical-symbol-p ,symbol-temp))
+ ))
+ symbol-temps value-temps1 value-temps2))
+ (unwind-protect
+ (progn
+ ,@(mapcan (lambda (symbol-temp)
+ (list `(setf (function-input-code ,symbol-temp) nil)
+;; `(setf (function-logical-symbol-p ,symbol-temp) nil)
+ ))
+ symbol-temps)
+ ,@body)
+ ,@(mapcan (lambda (symbol-temp value-temp1 value-temp2)
+ (declare (ignorable value-temp2))
+ (list `(setf (function-input-code ,symbol-temp) ,value-temp1)
+;; `(setf (function-logical-symbol-p ,symbol-temp) ,value-temp2)
+ ))
+ symbol-temps value-temps1 value-temps2))))))
+
+(defun initialize-agenda ()
+ (setf *agenda*
+ (list
+ (setf *agenda-of-false-rows-to-process*
+ (make-agenda :name "false rows to process"
+ :same-item-p #'same-agenda-item-p))
+ (setf *agenda-of-new-embeddings-to-process*
+ (make-agenda :name "new embeddings to process"
+ :same-item-p #'same-agenda-item-p))
+ (setf *agenda-of-input-rows-to-process*
+ (make-agenda :name "input rows to process"
+ :same-item-p #'same-agenda-item-p))
+ (setf *agenda-of-backward-simplifiable-rows-to-process*
+ (make-agenda :name "backward simplifiable rows to process"
+ :same-item-p #'same-agenda-item-p))
+ (setf *agenda-of-rows-to-process*
+ (make-agenda :name "rows to process"
+ :length-limit (agenda-length-before-simplification-limit?)
+ :same-item-p #'same-agenda-item-p))
+ (setf *agenda-of-input-rows-to-give*
+ (make-agenda :name "input rows to give"
+ :same-item-p #'same-agenda-item-p))
+ (setf *agenda-of-rows-to-give*
+ (make-agenda :name "rows to give"
+ :length-limit (agenda-length-limit?)
+ :length-limit-deletion-action #'unstore-agenda-item
+ :same-item-p #'same-agenda-item-p)))))
+
+(defun initialize-rewrites ()
+ (prog->
+ (map-symbol-table ->* name kind symbol)
+ (declare (ignore name kind))
+ (when (function-symbol-p symbol)
+ (dolist (rewrite (function-rewrites symbol))
+ (assert-rewrite rewrite)))))
+
+(defun store-boolean-ring-rewrites ()
+ (declare-logical-symbol '%rewrite)
+ (dolist (rewrite '((%rewrite (or ?x ?y) (xor (and ?x ?y) ?x ?y)) ;translate OR
+ (%rewrite (implies ?x ?y) (xor (and ?x ?y) ?x true)) ;translate IMPLIES
+ (%rewrite (implied-by ?y ?x) (xor (and ?x ?y) ?x true))
+ (%rewrite (iff ?x ?y) (xor ?x ?y true)) ;translate IFF
+ (%rewrite (not ?x) (xor ?x true))
+;; (%rewrite (xor ?x false) ?x)
+;; (%rewrite (xor ?x ?x) false)
+;; (%rewrite (xor ?y ?x ?x) ?y) ;embedding of above
+;; (%rewrite (and ?x true) ?x)
+;; (%rewrite (and ?x false) false)
+;; (%rewrite (and ?x ?x) ?x)
+;; (%rewrite (and ?y ?x ?x) (and ?x ?y)) ;embedding of above
+ (%rewrite (and ?x (xor ?y ?z)) (xor (and ?x ?y) (and ?x ?z)))
+ ))
+ (store-rewrite
+ (renumber
+ (with-input-functions-disabled
+ (*and* *or* *not* *implies* *implied-by* *iff* *xor* *if*)
+ (let ((*input-proposition-variables* t))
+ (input-wff rewrite))))
+ '>)))
+
+(defun renumber-row (row)
+ (let ((rsubst nil))
+ (let ((wff (row-wff row)))
+ (setf (values wff rsubst) (renumber wff nil rsubst))
+ (setf (row-wff row) wff))
+ (let ((constraint-alist (row-constraints row)))
+ (when constraint-alist
+ (setf (values constraint-alist rsubst) (renumber constraint-alist nil rsubst))
+ (setf (row-constraints row) constraint-alist)))
+ (let ((answer (row-answer row)))
+ (unless (eq false answer)
+ (setf (values answer rsubst) (renumber answer nil rsubst))
+ (setf (row-answer row) answer)))
+ rsubst))
+
+(defvar *embedding-variables* nil) ;list of embedding variables
+
+(defun embedding-variable-p (x)
+ (let ((l *embedding-variables*))
+ (and l (member x l :test #'eq))))
+
+(defvar *assert-rewrite-polarity* nil)
+
+(defun assert-rewrite-check (wff)
+ (declare (ignore wff))
+;;(cl:assert (member (instantiating-direction (arg1 wff) (arg2 wff) nil) '(> <>)))
+ )
+
+(defun assert-rewrite (wff &key name (reason 'assertion) (input t) (partitions (use-partitions?)) (conditional nil))
+ (cl:assert (symbolp name))
+ (macrolet
+ ((make-row1 (wff)
+ `(make-row :wff ,wff
+ :number (incf *number-of-rows*)
+ :name name
+ :context context
+ :reason reason
+ :input-wff input-wff)))
+ (prog->
+ (the-row-context2 (ecase reason (assertion (assert-context?)) (assumption :current)) partitions -> context)
+ (if conditional '>? '> -> dir)
+ (if input (input-wff wff) (values wff nil (term-to-lisp wff)) -> wff dp-alist input-wff)
+ (declare (ignore dp-alist))
+ (cond
+ ((or (equality-p wff) (and (equivalence-p wff) (atom-p (arg1 wff))))
+ (renumber wff -> wff rsubst)
+ (declare (ignore rsubst))
+ (assert-rewrite-check wff)
+ (store-rewrite wff dir (make-row1 wff)))
+ ((literal-p wff)
+ (literal-p wff -> atom polarity)
+ (renumber atom -> atom rsubst)
+ (declare (ignore rsubst))
+ (store-rewrite2 atom (if (eq :pos polarity) true false) (make-row1 wff) nil))
+ ((and (implication-p wff)
+ (atom-p (arg1 wff)))
+ (prog->
+ (make-compound *iff* (arg1 wff) (arg2 wff) -> wff1)
+ (renumber wff1 -> wff1 rsubst)
+ (declare (ignore rsubst))
+ (quote :pos -> *assert-rewrite-polarity*)
+ (assert-rewrite-check wff1)
+ (store-rewrite wff1 dir (make-row1 wff))))
+ ((and (implication-p wff)
+ (negation-p (arg1 wff))
+ (atom-p (arg1 (arg1 wff))))
+ (prog->
+ (make-compound *iff* (arg1 (arg1 wff)) (negate (arg2 wff)) -> wff1)
+ (renumber wff1 -> wff1 rsubst)
+ (declare (ignore rsubst))
+ (quote :neg -> *assert-rewrite-polarity*)
+ (assert-rewrite-check wff1)
+ (store-rewrite wff1 dir (make-row1 wff))))
+ ((and (reverse-implication-p wff)
+ (atom-p (arg1 wff)))
+ (prog->
+ (make-compound *iff* (arg1 wff) (arg2 wff) -> wff1)
+ (renumber wff1 -> wff1 rsubst)
+ (declare (ignore rsubst))
+ (quote :neg -> *assert-rewrite-polarity*)
+ (assert-rewrite-check wff1)
+ (store-rewrite wff1 dir (make-row1 wff))))
+ ((and (reverse-implication-p wff)
+ (negation-p (arg1 wff))
+ (atom-p (arg1 (arg1 wff))))
+ (prog->
+ (make-compound *iff* (arg1 (arg1 wff)) (negate (arg2 wff)) -> wff1)
+ (renumber wff1 -> wff1 rsubst)
+ (declare (ignore rsubst))
+ (quote :pos -> *assert-rewrite-polarity*)
+ (assert-rewrite-check wff1)
+ (store-rewrite wff1 dir (make-row1 wff))))
+ ((and (conjunction-p wff)
+ (implication-p (arg1 wff))
+ (implication-p (arg2 wff))
+ (equal-p (arg1 (arg1 wff)) (arg2 (arg2 wff)))
+ (atom-p (arg1 (arg1 wff))))
+ (prog->
+ (make-compound *iff* (arg1 (arg1 wff)) (arg2 (arg1 wff)) -> wff1)
+ (renumber wff1 -> wff1 rsubst)
+ (declare (ignore rsubst))
+ (quote :pos -> *assert-rewrite-polarity*)
+ (assert-rewrite-check wff1)
+ (store-rewrite wff1 dir (make-row1 (arg1 wff))))
+ (prog->
+ (make-compound *iff* (arg2 (arg2 wff)) (arg1 (arg2 wff)) -> wff2)
+ (renumber wff2 -> wff2 rsubst)
+ (declare (ignore rsubst))
+ (quote :neg -> *assert-rewrite-polarity*)
+ (assert-rewrite-check wff2)
+ (store-rewrite wff2 dir (make-row1 (arg2 wff))))) ;same name?
+ ((and (conjunction-p wff)
+ (implication-p (arg1 wff))
+ (reverse-implication-p (arg2 wff))
+ (equal-p (arg1 (arg1 wff)) (arg1 (arg2 wff)))
+ (atom-p (arg1 (arg1 wff))))
+ (prog->
+ (make-compound *iff* (arg1 (arg1 wff)) (arg2 (arg1 wff)) -> wff1)
+ (renumber wff1 -> wff1 rsubst)
+ (declare (ignore rsubst))
+ (quote :pos -> *assert-rewrite-polarity*)
+ (assert-rewrite-check wff1)
+ (store-rewrite wff1 dir (make-row1 (arg1 wff))))
+ (prog->
+ (make-compound *iff* (arg1 (arg2 wff)) (arg2 (arg2 wff)) -> wff2)
+ (renumber wff2 -> wff2 rsubst)
+ (declare (ignore rsubst))
+ (quote :neg -> *assert-rewrite-polarity*)
+ (assert-rewrite-check wff2)
+ (store-rewrite wff2 dir (make-row1 (arg2 wff))))) ;same name?
+ (t
+ (error "Improper form for assert-rewrite."))))
+ nil))
+
+(defmacro assertion (wff &rest keys-and-values)
+ (cond
+ ((getf keys-and-values :ignore)
+ nil)
+ (t
+ `(assertionfun ',wff ',keys-and-values)))) ;don't evaluate wff or options
+
+(defun assertionfun (wff keys-and-values)
+ (apply 'assert wff keys-and-values))
+
+(defun assert (wff
+ &key
+ name
+ conc-name
+ (answer false)
+ constraints ;2-lists of theory name and wff
+ (reason 'assertion)
+ context
+ (partitions (use-partitions?))
+ (supported nil supported-supplied)
+ (sequential nil sequential-supplied)
+ documentation
+ author ;for KIF
+ source ;for KIF
+ (input-wff none)
+ (magic (use-magic-transformation?))
+ closure)
+ (with-clock-on assert
+ (when name
+ (unless (can-be-row-name name 'warn)
+ (setf name nil)))
+ (when (eq 'conjecture reason)
+ (setf wff `(not ,wff))
+ (setf reason 'negated_conjecture)
+ (setf *szs-conjecture* t))
+ (cl:assert (member reason '(assertion assumption negated_conjecture hint)))
+ (unless supported-supplied
+ (setf supported (ecase reason
+ (assertion (assert-supported?))
+ (assumption (assume-supported?))
+ (negated_conjecture (prove-supported?))
+ (hint nil))))
+ (cl:assert (member supported '(nil t :uninherited)))
+ (unless sequential-supplied
+ (setf sequential (ecase reason
+ (assertion (assert-sequential?))
+ (assumption (assume-sequential?))
+ (negated_conjecture (prove-sequential?))
+ (hint nil))))
+ (cl:assert (member sequential '(nil t :uninherited)))
+ (unless context
+ (setf context (ecase reason
+ (assertion (assert-context?))
+ ((assumption negated_conjecture hint) :current))))
+ (when (eq :current context)
+ (setf context (current-row-context)))
+ (let ((n 0))
+ (prog->
+ (not (use-well-sorting?) -> *%check-for-well-sorted-atom%*)
+ (input-wff wff :clausify (use-clausification?) -> wff dp-alist input-wff1 input-wff-subst)
+ (declare (ignore dp-alist))
+ (when *find-else-substitution*
+ (setf wff (instantiate wff *find-else-substitution*)))
+ (mapcar (lambda (x) (cons (first x) (input-wff `(not ,(second x)) :*input-wff-substitution* input-wff-subst))) constraints -> constraint-alist)
+ (when (eq 'from-wff answer)
+ (cond
+ ((and (consp input-wff1) (eq 'forall (first input-wff1)))
+ (setf answer (cons 'values (mapcar (lambda (x) (if (consp x) (first x) x)) (second input-wff1)))))
+ ((and (consp input-wff1) (eq 'not (first input-wff1)) (consp (second input-wff1)) (eq 'exists (first (second input-wff1))))
+ (setf answer (cons 'values (mapcar (lambda (x) (if (consp x) (first x) x)) (second (second input-wff1))))))
+ (t
+ (setf answer false))))
+ (input-wff answer :*input-wff-substitution* input-wff-subst -> answer)
+ ;; (if (use-equality-elimination?) (equality-eliminate-wff wff) wff -> wff)
+ (if (and magic (not (eq 'hint reason))) (magic-transform-wff wff :transform-negative-clauses supported :transform-positive-units (test-option29?)) wff -> wff)
+ (well-sort-wffs (list* wff answer (mapcar #'cdr constraint-alist)) ->* subst)
+ (incf n)
+ (map-conjuncts wff ->* wff)
+ (catch 'fail
+ (let* ((wff (fail-when-true (instantiate wff subst)))
+ (row (make-row :wff wff
+ :constraints (fail-when-constraint-true (instantiate constraint-alist subst))
+ :answer (if (and magic (magic-goal-occurs-p wff))
+ false
+ (fail-when-disallowed (instantiate answer subst)))
+ :context (the-row-context2 context partitions)
+ :reason reason
+ :supported supported
+ :sequential sequential
+ :conc-name (and conc-name (if (stringp conc-name) conc-name (funcall conc-name wff)))
+ :documentation documentation
+ :author author
+ :source source
+ :input-wff (if (neq none input-wff) input-wff input-wff1)
+ :name name)))
+ #+ignore
+ (when (use-constraint-purification?)
+ (setf row (constraint-purify-row row)))
+ (when (use-assertion-analysis?)
+ (assertion-analysis row))
+ (record-new-input-wff row))))
+ (unless (eql 1 n)
+ (with-standard-io-syntax2
+ (warn "Input wff ~A has ~D well-sorted instances." wff n)))))
+ (when closure
+ (closure)))
+
+(defun assume (wff &rest keys-and-values)
+ (apply #'assert wff (append keys-and-values (list :reason 'assumption))))
+
+(defun prove (wff &rest keys-and-values)
+ (apply #'assert wff (append keys-and-values (list :reason 'conjecture :closure (prove-closure?)))))
+
+(defun new-prove (wff &rest keys-and-values)
+ (new-row-context)
+ (apply #'prove wff keys-and-values))
+
+(defun hint (wff &rest keys-and-values)
+ (apply #'assert wff (append keys-and-values (list :reason 'hint))))
+
+(defun fail ()
+ (throw 'fail nil))
+
+(defun fail-when-nil (x)
+ (if (null x)
+ (throw 'fail nil)
+ x))
+
+(defun fail-when-true (x)
+ (if (eq true x)
+ (throw 'fail nil)
+ x))
+
+(defun fail-when-false (x)
+ (if (eq false x)
+ (throw 'fail nil)
+ x))
+
+(defun fail-when-constraint-true (constraint-alist)
+ (dolist (x constraint-alist constraint-alist)
+ (when (eq true (cdr x))
+ (throw 'fail nil))))
+
+(defun fail-when-disallowed (answer)
+ (if (answer-disallowed-p answer)
+ (throw 'fail nil)
+ answer))
+
+(defvar *check-for-disallowed-answer* nil)
+
+(defun answer-disallowed-p (answer)
+ (if (and (rewrite-answers?) (not *check-for-disallowed-answer*))
+ nil
+ (disallowed-symbol-occurs-in-answer-p answer nil)))
+
+(defun make-demodulant (row1 row2 wff2* context1 context2)
+ (cond
+ ((eq true wff2*)
+ :tautology)
+ (t
+ (prog->
+ (context-intersection-p context1 context2 ->nonnil context)
+ (make-row :wff (instantiate wff2* 1)
+ :constraints (instantiate (row-constraints row2) 1)
+ :answer (instantiate (row-answer row2) 1)
+ :supported (row-supported row2)
+ :sequential (row-sequential row2)
+ :context context
+ :reason `(rewrite ,row2 ,row1))))))
+
+(defun make-answer2 (row1 row2 subst cond swap)
+ (let ((answer1 (instantiate (row-answer row1) 1 subst))
+ (answer2 (instantiate (row-answer row2) 2 subst)))
+ (fail-when-disallowed
+ (cond
+ ((eq false answer1)
+ answer2)
+ ((eq false answer2)
+ answer1)
+ ((equal-p answer1 answer2)
+ answer1)
+ ((use-conditional-answer-creation?)
+ (if swap
+ (make-conditional-answer (instantiate cond subst) answer2 answer1 nil)
+ (make-conditional-answer (instantiate cond subst) answer1 answer2 nil)))
+ (t
+ (disjoin answer1 answer2))))))
+
+(defmacro make-resolvent-part (rown atomn atomn* truthvaluen n subst)
+ (let ((wffn (gensym))
+ (atom (gensym))
+ (polarity (gensym))
+ (atom* (gensym)))
+ `(prog->
+ (row-wff ,rown -> ,wffn)
+ (cond
+ ((eq ,wffn ,atomn)
+ ,truthvaluen)
+ (t
+ (map-atoms-in-wff-and-compose-result ,wffn ->* ,atom ,polarity)
+ (declare (ignore ,polarity))
+ (cond
+ ((eq ,atom ,atomn)
+ ,truthvaluen)
+ (t
+ (instantiate ,atom ,n ,subst -> ,atom*)
+ (cond
+ ((equal-p ,atom* ,atomn* subst)
+ ,truthvaluen)
+ (t
+ ,atom*)))))))))
+
+(defun make-resolvent1 (row1 atom1 truthvalue1 row2 atom2 truthvalue2 subst context1 context2)
+ (prog->
+ (context-intersection-p context1 context2 ->nonnil context)
+ (instantiate atom1 1 -> atom1*)
+ (instantiate atom2 2 -> atom2*)
+ (disjoin
+ (make-resolvent-part row1 atom1 atom1* truthvalue1 1 subst)
+ (make-resolvent-part row2 atom2 atom2* truthvalue2 2 subst)
+ -> wff)
+ (cond
+ ((eq true wff)
+ :tautology)
+ (t
+ (make-row :wff wff
+ :constraints (disjoin-alists
+ (instantiate (row-constraints row1) 1 subst)
+ (instantiate (row-constraints row2) 2 subst))
+ :answer (make-answer2 row1 row2 subst atom1* (eq false truthvalue1))
+ :supported (or (row-supported-inheritably row1) (row-supported-inheritably row2))
+ :sequential (or (row-sequential-inheritably row1) (row-sequential-inheritably row2))
+ :context context
+ :reason (if (eq true truthvalue1) `(resolve ,row1 ,row2) `(resolve ,row2 ,row1)))))))
+
+(defun make-resolvent (row1 atom1 atom1* truthvalue1 row2 atom2 atom2* truthvalue2 subst
+ context1 context2)
+ (let ((made nil))
+ (prog->
+ (context-intersection-p context1 context2 ->nonnil context)
+ (catch 'fail
+ (record-new-derived-row
+ (make-row :wff (fail-when-true
+ (if (eq true truthvalue1)
+ (disjoin
+ (make-resolvent-part row2 atom2 atom2* truthvalue2 2 subst)
+ (make-resolvent-part row1 atom1 atom1* truthvalue1 1 subst))
+ (disjoin
+ (make-resolvent-part row1 atom1 atom1* truthvalue1 1 subst)
+ (make-resolvent-part row2 atom2 atom2* truthvalue2 2 subst))))
+ :constraints (fail-when-constraint-true
+ (disjoin-alists
+ (instantiate (row-constraints row1) 1 subst)
+ (instantiate (row-constraints row2) 2 subst)))
+ :answer (make-answer2 row1 row2 subst atom1* (eq false truthvalue1))
+ :supported (or (row-supported-inheritably row1) (row-supported-inheritably row2))
+ :sequential (or (row-sequential-inheritably row1) (row-sequential-inheritably row2))
+ :context context
+ :reason (if (eq true truthvalue1) `(resolve ,row1 ,row2) `(resolve ,row2 ,row1))))
+ (setf made t)))
+ made))
+
+(defun make-resolventa (row1 atom1 atom1* truthvalue1 subst context1 &optional residue)
+ (prog->
+ (catch 'fail
+ (record-new-derived-row
+ (make-row :wff (fail-when-true
+ (let ((wff (make-resolvent-part row1 atom1 atom1* truthvalue1 1 subst)))
+ (if residue (disjoin (instantiate residue subst) wff) wff)))
+ :constraints (fail-when-constraint-true (instantiate (row-constraints row1) 1 subst))
+ :answer (fail-when-disallowed (instantiate (row-answer row1) 1 subst))
+ :supported (row-supported row1)
+ :sequential (row-sequential row1)
+ :context context1
+ :reason `(resolve ,row1 ,(function-code-name (head atom1*))))))))
+
+(defun make-resolventb (row1 residue subst context1)
+ (prog->
+ (catch 'fail
+ (record-new-derived-row
+ (make-row :wff (fail-when-true (instantiate residue subst))
+ :constraints (fail-when-constraint-true (instantiate (row-constraints row1) 1 subst))
+ :answer (fail-when-disallowed (instantiate (row-answer row1) 1 subst))
+ :supported (row-supported row1)
+ :sequential (row-sequential row1)
+ :context context1
+ :reason `(resolve ,row1 :resolve-code))))))
+
+(defun make-resolventc (row subst context constraint-alist*)
+ (prog->
+ (catch 'fail
+ (record-new-derived-row
+ (make-row :wff (fail-when-true (instantiate (row-wff row) 1 subst))
+ :constraints (fail-when-constraint-true (instantiate constraint-alist* 1 subst))
+ :answer (fail-when-disallowed (instantiate (row-answer row) 1 subst))
+ :supported (row-supported row)
+ :sequential (row-sequential row)
+ :context context
+ :reason `(resolve ,row :code-for-$$eq))))))
+
+(defun make-hyperresolvent-nucleus-part (nucleus subst)
+ (prog->
+ (hyperresolution-nucleus-polarity -> nucleus-polarity)
+ (if (eq :pos nucleus-polarity) false true -> truthvalue)
+ (map-atoms-in-wff-and-compose-result (row-wff nucleus) ->* atom polarity)
+ (cond
+ ((and (eq nucleus-polarity polarity) (not (do-not-resolve atom)))
+ truthvalue)
+ (t
+ (instantiate atom 1 subst)))))
+
+(defvar *resolve-functions-used* nil)
+
+(defun make-hyperresolvent (nucleus electrons residues subst)
+ (prog->
+ (row-context-live? nucleus ->nonnil context)
+ (catch 'fail
+ (let ((k (+ (length electrons) 1))
+ (wff (fail-when-true (make-hyperresolvent-nucleus-part nucleus subst)))
+ (constraint-alist (fail-when-constraint-true (instantiate (row-constraints nucleus) 1 subst)))
+ (answer (fail-when-disallowed (instantiate (row-answer nucleus) 1 subst)))
+ (supported (row-supported-inheritably nucleus))
+ (sequential (row-sequential-inheritably nucleus))
+ parents)
+ (dolist (residue residues)
+ (setf wff (fail-when-true (disjoin (instantiate residue subst) wff))))
+ (dolist (x electrons)
+ (mvlet (((list electron+ atom atom*) x))
+ (setf wff (fail-when-true
+ (disjoin
+ (make-resolvent-part electron+ atom atom* (if *negative-hyperresolution* true false) k subst)
+ wff)))
+ (when (row-constraints electron+)
+ (setf constraint-alist (fail-when-constraint-true
+ (disjoin-alists
+ (instantiate (row-constraints electron+) k subst)
+ constraint-alist))))
+ (unless (eq false (row-answer electron+))
+ (setf answer (cond
+ ((eq false answer)
+ (fail-when-disallowed (instantiate (row-answer electron+) k subst)))
+ ((not (use-conditional-answer-creation?))
+ (disjoin
+ (fail-when-disallowed (instantiate (row-answer electron+) k subst))
+ answer))
+ (*negative-hyperresolution*
+ (make-conditional-answer
+ (fail-when-disallowed (instantiate atom* k subst))
+ (fail-when-disallowed (instantiate (row-answer electron+) k subst))
+ answer
+ nil))
+ (t
+ (make-conditional-answer
+ (fail-when-disallowed (instantiate atom* k subst))
+ answer
+ (fail-when-disallowed (instantiate (row-answer electron+) k subst))
+ nil)))))
+ (setf context (fail-when-nil (context-intersection-p
+ context (row-context-live? electron+))))
+ (unless supported
+ (setf supported (row-supported-inheritably electron+)))
+ (unless sequential
+ (setf sequential (row-sequential-inheritably electron+)))
+ (push electron+ parents)
+ (decf k)))
+ (push nucleus parents)
+ (record-new-derived-row
+ (make-row :wff wff
+ :constraints constraint-alist
+ :answer answer
+ :supported supported
+ :sequential sequential
+ :context context
+ :reason (if *negative-hyperresolution*
+ `(negative-hyperresolve ,@parents ,@*resolve-functions-used*)
+ `(hyperresolve ,@parents ,@*resolve-functions-used*))))))))
+
+(defun make-ur-resolvent (nucleus electrons target-atom target-polarity subst)
+ (prog->
+ (row-context-live? nucleus ->nonnil context)
+ (catch 'fail
+ (let ((k (+ (length electrons) 1))
+ (constraint-alist (fail-when-constraint-true (instantiate (row-constraints nucleus) 1 subst)))
+ (answer (fail-when-disallowed (instantiate (row-answer nucleus) 1 subst)))
+ (supported (row-supported-inheritably nucleus))
+ (sequential (row-sequential-inheritably nucleus)))
+ (dolist (electron electrons)
+ (when (row-constraints electron)
+ (setf constraint-alist (fail-when-constraint-true
+ (disjoin-alists
+ (instantiate (row-constraints electron) k subst)
+ constraint-alist))))
+ (unless (eq false (row-answer electron))
+ (setf answer (cond
+ ((eq false answer)
+ (fail-when-disallowed (instantiate (row-answer electron) k subst)))
+ ((not (use-conditional-answer-creation?))
+ (disjoin
+ (fail-when-disallowed (instantiate (row-answer electron) k subst))
+ answer))
+ (t
+ (make-conditional-answer
+ (fail-when-disallowed (instantiate (row-wff electron) k subst))
+ answer
+ (fail-when-disallowed (instantiate (row-answer electron) k subst))
+ nil)))))
+ (setf context (fail-when-nil (context-intersection-p
+ context (row-context-live? electron))))
+ (unless supported
+ (setf supported (row-supported-inheritably electron)))
+ (unless sequential
+ (setf sequential (row-sequential-inheritably electron)))
+ (decf k))
+ (record-new-derived-row
+ (make-row :wff (if target-atom
+ (if (eq :pos target-polarity)
+ (instantiate target-atom subst)
+ (make-compound *not* (instantiate target-atom subst)))
+ false)
+ :constraints constraint-alist
+ :answer answer
+ :supported supported
+ :sequential sequential
+ :context context
+ :reason `(ur-resolve ,nucleus ,@(reverse electrons) ,@*resolve-functions-used*)))))))
+
+(defun make-paramodulant-form (cc value1* term2* wff2* subst)
+ (cond
+ ((not (term-subsort-p value1* term2* subst))
+ )
+ ((use-single-replacement-paramodulation?)
+ (substitute-once cc value1* term2* wff2* subst))
+ (t
+ (funcall cc (substitute value1* term2* wff2* subst)))))
+
+(defun make-paramodulant (row1 equality1 value1* row2 term2* subst context1 context2)
+ (prog->
+ (context-intersection-p context1 context2 ->nonnil context)
+ (catch 'fail
+ (fail-when-constraint-true
+ (disjoin-alists
+ (instantiate (row-constraints row2) 2 subst)
+ (instantiate (row-constraints row1) 1 subst))
+ -> constraint)
+ (instantiate equality1 1 subst -> equality1*)
+ (make-answer2 row1 row2 subst equality1* t -> answer)
+ (or (row-supported-inheritably row1) (row-supported-inheritably row2) -> supported)
+ (or (row-sequential-inheritably row1) (row-sequential-inheritably row2) -> sequential)
+ (list 'paramodulate row2 row1 -> reason)
+ (make-resolvent-part row1 equality1 equality1* false 1 subst -> w1)
+ (instantiate value1* subst -> value1*)
+ (instantiate (row-wff row2) 2 subst -> wff2*)
+ (make-paramodulant-form value1* term2* wff2* subst ->* w2)
+ (catch 'fail
+ (record-new-derived-row
+ (make-row :wff (fail-when-true (disjoin w1 w2))
+ :constraints constraint
+ :answer answer
+ :supported supported
+ :sequential sequential
+ :context context
+ :reason reason))))))
+
+(defun make-paramodulanta (value1* row2 term2* subst context2)
+ (prog->
+ (catch 'fail
+ (fail-when-constraint-true (instantiate (row-constraints row2) 2 subst) -> constraint)
+ (fail-when-disallowed (instantiate (row-answer row2) 2 subst) -> answer)
+ (row-supported-inheritably row2 -> supported)
+ (row-sequential-inheritably row2 -> sequential)
+ (list 'paramodulate row2 (function-code-name (head term2*)) -> reason)
+ (make-paramodulant-form
+ (instantiate value1* subst) term2* (instantiate (row-wff row2) 2 subst) subst ->* w2)
+ (catch 'fail
+ (record-new-derived-row
+ (make-row :wff (fail-when-true w2)
+ :constraints constraint
+ :answer answer
+ :supported supported
+ :sequential sequential
+ :context context2
+ :reason reason))))))
+
+(defun canonicalize-wff (wff)
+ (prog->
+ (map-atoms-in-wff-and-compose-result wff ->* atom polarity)
+ (unless (variable-p atom) ;shouldn't be variable atom
+ (setf atom (hash-term atom))
+ (map-terms-in-atom atom nil polarity ->* term polarity)
+ (declare (ignore polarity))
+ (unless (variable-p term)
+ (tm-store term)))
+ atom))
+
+(defun index-terms-in-atom-of-derived-wff (atom polarity row)
+ (setf atom (hash-term atom))
+ (prog->
+ (map-terms-in-atom atom nil polarity ->* term polarity)
+ (declare (ignore polarity))
+ (dereference
+ term nil
+ :if-constant (unless (constant-constructor term) ;suppress reduction, paramodulation
+ (tm-store term)
+ (insert-into-rows-containing-term row term))
+ :if-compound (progn
+ (tm-store term)
+ (insert-into-rows-containing-term row term))))
+ atom)
+
+(defun dont-make-embedding-p (a b)
+ (declare (ignore b))
+ ;; don't make embedding if ac lhs has a single-occurrence top-level variable
+ (let ((head (head a)))
+ (and
+ (function-associative head)
+ (function-commutative head)
+ (let ((terms-and-counts (count-arguments head (args a) nil)))
+ (loop for tc1 in terms-and-counts
+ thereis (and
+ (eql 1 (tc-count tc1))
+ (variable-p (tc-term tc1))
+ (same-sort? (function-sort head) (variable-sort (tc-term tc1)))
+ (loop for tc2 in terms-and-counts
+ never (and (neq tc1 tc2) (variable-occurs-p (tc-term tc1) (tc-term tc2) nil)))))))))
+
+(defun embedding-types (pattern value)
+ (let ((head (head pattern)))
+ (when (function-associative head)
+ (unless (dont-make-embedding-p pattern value)
+ (cond
+ ((function-commutative head)
+ :l)
+ (t
+ :l&r))))))
+
+(defun store-rewrite2 (pattern value row conditional)
+ (cond
+ ((variable-p pattern)
+ nil)
+ (t
+ (prog->
+ (make-rewrite row
+ pattern
+ value
+ (if conditional 'simplification-ordering-greaterp t)
+ (symbol-count pattern)
+ (new-variables value nil (variables pattern))
+ *assert-rewrite-polarity*
+ -> rewrite)
+ (setf pattern (hash-term pattern))
+ (tm-store pattern)
+ (when (compound-p pattern)
+ (setf (function-rewritable-p (head pattern)) t)
+ (setf (rewrite-embeddings rewrite) (embedding-types pattern value)))
+ (push rewrite (rewrites pattern))
+ (when row
+ (push rewrite (row-rewrites row))))
+ t)))
+
+(defun store-rewrite (equality-or-equivalence &optional dir row)
+ (let ((args (args equality-or-equivalence)) stored)
+ (unless dir
+ (setf dir (simplification-ordering-compare-equality-arguments equality-or-equivalence nil t)))
+ (when (and (or (eq '> dir) (eq '>? dir) (eq '<>? dir))
+ (store-rewrite2 (first args) (second args) row (neq '> dir)))
+ (setf stored t))
+ (when (and (or (eq dir '<) (eq dir '?))
+ (store-rewrite2 (second args) (first args) row (neq '< dir)))
+ (setf stored t))
+ (cond
+ (stored
+ )
+ ((member dir '(> >? < ?))
+ (warn "Cannot use equality or equivalence ~A as rewrite." equality-or-equivalence))
+ (t
+ (when (print-unorientable-rows?)
+ (print-unorientable-wff equality-or-equivalence))))))
+
+(defun maybe-store-atom-rewrite (atom truth-value row)
+ (when (use-simplification-by-units?)
+ (unless (and (test-option43?) (do-not-resolve atom))
+ (store-rewrite (make-compound *iff* atom truth-value) '> row))))
+
+(defun store-given-row (row)
+ (unless (row-given-p row)
+ (prog->
+ (map-atoms-in-wff (row-wff row) ->* atom polarity)
+ (when (and (eq :pos polarity) (equality-p atom))
+ (args atom -> args)
+ (first args -> arg1)
+ (second args -> arg2)
+ (unless (equal-p arg1 arg2)
+ (simplification-ordering-compare-equality-arguments atom nil -> dir)
+ (unless (eq '< dir)
+ (store-given-row-equality row arg1 arg2))
+ (unless (eq '> dir)
+ (store-given-row-equality row arg2 arg1)))))
+ (setf (row-status row) :given))
+ row)
+
+(defun store-given-row-equality (row pattern value)
+ (unless (variable-p pattern)
+ (prog->
+ (setf pattern (hash-term pattern))
+ (tm-store pattern)
+ (pushnew (cons row value)
+ (rows-containing-paramodulatable-equality pattern)
+ :test (lambda (x y) (and (eq (car x) (car y)) (eq (cdr x) (cdr y)))))
+ )))
+
+(defun store-derived-wff (row)
+ ;; indexes atomic formulas of row so they can be retrieved for subsumption
+ ;; indexes terms of row so they can be retrieved for demodulation
+ ;; make rewrite from row if possible
+ (let* ((wff (row-wff row))
+ (answer (row-answer row))
+ (hint (row-hint-p row))
+ (potential-rewrite (and (not hint) (row-bare-unit-p row) (not (row-embedding-p row)))))
+ (setf wff (map-atoms-in-wff-and-compose-result
+ (lambda (atom polarity)
+ (unless hint
+ (setf atom (index-terms-in-atom-of-derived-wff atom polarity row)))
+ (prog->
+ (setf atom (hash-term atom))
+ (tm-store atom)
+ (unless (eq :neg polarity)
+ (insert-into-rows-containing-atom-positively row atom))
+ (unless (eq :pos polarity)
+ (insert-into-rows-containing-atom-negatively row atom))
+ (insert-into-rows-containing-term row atom)
+ (when potential-rewrite
+ (cond
+ ((and (use-simplification-by-equalities?) (eq :pos polarity) (equality-p atom))
+ (let ((args (args atom)))
+ (ecase (simplification-ordering-compare-equality-arguments atom nil t row)
+ (<
+ (store-rewrite atom '< row))
+ (>
+ (store-rewrite atom '> row))
+ (=
+ (unless (and (not (variable-p (first args)))
+ (equal-p (first args) (second args)))
+ (maybe-store-atom-rewrite atom true row)))
+ (?
+ (case (instantiating-direction (first args) (second args) nil)
+ (>
+ (store-rewrite atom '>? row))
+ (<
+ (store-rewrite atom '
+ (if (variant-p (first args) (instantiate (second args) 1))
+ (store-rewrite atom '>? row)
+ (store-rewrite atom '<>? row))))
+ (maybe-store-atom-rewrite atom true row)))))
+ (t
+ (maybe-store-atom-rewrite atom (if (eq :pos polarity) true false) row))))
+ atom))
+ wff))
+ (unless (or (eq false answer) (variable-p answer))
+ (setf answer (canonicalize-wff answer)))
+ (setf (row-wff row) wff)
+ (setf (row-answer row) answer)
+ (unless (row-bare-unit-p row)
+ (feature-vector-index-insert row *feature-vector-row-index*))
+ (dolist (parent (row-parents row))
+ (rowset-insert row (or (row-children parent)
+ (setf (row-children parent) (make-rowset)))))))
+
+(defun recursively-unstore-wff (row msg stop-predicate)
+ (unless (funcall stop-predicate row)
+ (prog->
+ (map-rows :rowset (row-children row) :reverse t ->* child)
+ (recursively-unstore-wff child "Deleted descendant" stop-predicate))
+ (unstore-wff row msg)))
+
+(defun unstore-wff (row msg)
+ (unless (row-deleted-p row)
+ (delete-row-from-agenda row)
+ (when (row-number row)
+ (feature-vector-index-delete row *feature-vector-row-index*)
+ (rowsets-delete row))
+ (let ((rewrites (row-rewrites row)))
+ (when rewrites
+ (dolist (rewrite rewrites)
+ (setf (rewrite-condition rewrite) nil)
+ (let ((e (the-term-memory-entry (rewrite-pattern rewrite))))
+ (setf (tme-rewrites e) (delete rewrite (tme-rewrites e) :count 1))))
+ (setf (row-rewrites row) nil)))
+ (prog->
+ (map-terms-in-term (row-wff row) ->* term polarity)
+ (declare (ignore polarity))
+ (unless (variable-p term)
+ (some-term-memory-entry term -> e)
+ (when e
+ (let ((l (tme-rows-containing-paramodulatable-equality e)))
+ (when l
+ (setf (tme-rows-containing-paramodulatable-equality e) (delete row l :key #'car))))
+ (when (use-term-memory-deletion?)
+ (when (tme-useless-p e)
+ (tm-remove-entry e)))))) ;reinstated deletion 1997-08-16
+ (setf (row-status row) :deleted)
+ (setf (row-wff-symbol-counts0 row) nil) ;not needed for deleted row, reclaim memory
+ (setf (row-selections-alist row) nil) ;not needed for deleted row, reclaim memory
+ (when (row-number row)
+ (incf *number-of-backward-eliminated-rows*)
+ (when (print-rows-when-derived?)
+ (print-deleted-wff row msg))
+ (prog->
+ (map-rows :rowset (row-children row) :reverse t ->* child)
+ (when (row-embedding-p child)
+ (unstore-wff child "Deleted embedding")))
+ (rowsets-delete-column (row-children row))
+ (setf (row-children row) nil))))
+
+(defun delete-row (name-or-number)
+ (prog->
+ (quote 0 -> *number-of-backward-eliminated-rows*)
+ (quote nil -> *printing-deleted-messages*)
+ (row name-or-number 'warn ->nonnil row)
+ (unstore-wff row "Deleted")))
+
+(defun delete-rows (&rest map-rows-options)
+ (prog->
+ (quote 0 -> *number-of-backward-eliminated-rows*)
+ (quote nil -> *printing-deleted-messages*)
+ (apply 'map-rows map-rows-options ->* row)
+ (unstore-wff row "Deleted")))
+
+#+ignore
+(defun constraint-purify-row (row)
+ (prog->
+ (cl:assert (row-clause-p row))
+ (row-wff row -> wff)
+ (constraint-purify-wff wff -> wff* constraint-alist-additions)
+ (unless (and (null constraint-alist-additions) (equal-p wff wff*))
+ (disjoin-alists (row-constraints row) constraint-alist-additions -> constraints*)
+ (fail-when-constraint-true constraints*)
+ (setf row (maybe-new-row row))
+ (setf (row-wff row) wff*)
+ (setf (row-constraints row) constraints*)
+ (setf (row-reason row) `(purify ,(row-reason row)))))
+ row)
+
+(defun make-split (row wff answer polarity)
+ (let* ((constraint-alist (row-constraints row))
+ (suppress-answer (let ((vars (variables answer)))
+ (and vars
+ (dolist (var vars t)
+ (when (or (variable-occurs-p var wff nil)
+ (variable-occurs-p var constraint-alist nil))
+ (return nil)))))))
+ (make-row :wff (if (eq :pos polarity) wff (make-compound *not* wff))
+ :constraints constraint-alist
+ :answer (if suppress-answer false answer)
+ :supported (row-supported row)
+ :sequential (row-sequential row)
+ :context (row-context row)
+ :reason (row-reason row)
+ :conc-name (or (row-conc-name row)
+ (let ((name (row-name row)))
+ (and name (to-string name "-"))))
+ :documentation (row-documentation row)
+ :author (row-author row)
+ :source (row-source row)
+ :input-wff (row-input-wff row))))
+
+(defun factorer (row)
+ (when (row-hint-p row)
+ (return-from factorer nil))
+ (prog->
+ (row-context-live? row ->nonnil context)
+ (dopairs (atoms-in-wff2 (row-wff row) nil :pos 1) ->* x y)
+ (when (and (or (eq (second x) (second y)) (eq :both (second x)) (eq :both (second y)))
+ (not (do-not-factor (first x)))
+ (not (do-not-factor (first y)))
+ (implies (row-sequential row)
+ (or (atom-satisfies-sequential-restriction-p (first x) (row-wff row))
+ (atom-satisfies-sequential-restriction-p (first y) (row-wff row)))))
+ (unify (first x) (first y) ->* subst)
+ (catch 'fail
+ (record-new-derived-row
+ (make-row :wff (fail-when-true (instantiate (row-wff row) 1 subst))
+ :constraints (fail-when-constraint-true (instantiate (row-constraints row) 1 subst))
+ :answer (fail-when-disallowed (instantiate (row-answer row) 1 subst))
+ :supported (row-supported row)
+ :sequential (row-sequential row)
+ :context context
+ :reason `(factor ,row)))))))
+
+(defun resolve-with-x=x (row)
+ (when (row-hint-p row)
+ (return-from resolve-with-x=x nil))
+ (prog->
+ (row-context-live? row ->nonnil context)
+ (when (row-supported row)
+ (map-atoms-in-wff (row-wff row) ->* atom polarity)
+ (when (and (eq :neg polarity) (equality-p atom))
+ (args atom -> args)
+ (when (or (variable-p (first args)) (variable-p (second args)))
+ (instantiate atom 1 -> atom*)
+ (args atom* -> args*)
+ (unify (first args*) (second args*) ->* subst)
+ (when (make-resolventa row atom atom* true subst context)
+ (return-from resolve-with-x=x t))))))
+ nil)
+
+(defun resolve-with-x-eq-x (row)
+ (when (row-hint-p row)
+ (return-from resolve-with-x-eq-x nil))
+ (prog->
+ (row-context-live? row ->nonnil context)
+ (row-wff row -> wff)
+ (when (clause-p wff)
+ (map-atoms-in-wff wff ->* atom polarity)
+ (when (compound-p atom)
+ (head atom -> rel)
+ (when (and (do-not-resolve atom)
+ (member (function-constraint-theory rel) '(arithmetic equality)))
+ (identity nil -> resolved)
+ (prog->
+ (instantiate atom 1 -> atom*)
+ (dolist (function-resolve-code rel polarity) ->* fun)
+ (funcall fun atom* nil ->* subst &optional residue)
+ (unless residue
+ (when (make-resolventa row atom atom* (if (eq :neg polarity) true false) subst context)
+ (setf resolved t))))
+ #+ignore
+ (when resolved
+ (return-from resolve-with-x-eq-x t))))))
+ nil)
+
+(defun resolve-with-x-eq-x2 (row)
+ (when (row-hint-p row)
+ (return-from resolve-with-x-eq-x2 nil))
+ (prog->
+ (row-context-live? row ->nonnil context)
+ (row-constraints row -> constraint-alist)
+ (dolist constraint-alist ->* v)
+ (when (member (car v) '(arithmetic equality))
+ (cdr v -> wff)
+ (when (clause-p wff)
+ (map-atoms-in-wff wff ->* atom polarity)
+ (when (compound-p atom)
+ (head atom -> rel)
+ (identity nil -> resolved)
+ (prog->
+ (instantiate atom 1 -> atom*)
+ (dolist (function-resolve-code rel polarity) ->* fun)
+ (funcall fun atom* nil ->* subst &optional residue)
+ (unless residue
+ (when (make-resolventc row subst context (substitute (if (eq :neg polarity) true false) atom constraint-alist))
+ (setf resolved t))))
+ #+ignore
+ (when resolved
+ (return-from resolve-with-x-eq-x2 t))))))
+ nil)
+
+(defun function-resolve-code2 (fn v)
+ (and (not (function-do-not-resolve fn)) (function-resolve-code fn v)))
+
+(defun resolver (row1)
+ (when (row-hint-p row1)
+ (return-from resolver nil))
+ (prog->
+ (row-context-live? row1 ->nonnil context1)
+ (use-literal-ordering-with-resolution? -> orderfun)
+ (selected-atoms-in-row row1 orderfun -> selected-atoms-in-row1)
+ (flet ((resolver1 (atom1 truthvalue1 truthvalue2 polarity1 polarity2)
+ (prog->
+ (quote nil -> atom1*)
+ ;; apply resolve-code procedural attachments:
+ (when (row-supported row1)
+ (dolist (and (compound-p atom1) (function-resolve-code2 (head atom1) truthvalue1)) ->* fun)
+ (funcall fun (setq-once atom1* (instantiate atom1 1)) nil ->* subst &optional residue)
+ (when (selected-atom-p atom1 polarity1 selected-atoms-in-row1 orderfun subst 1 atom1*)
+ (make-resolventa row1 atom1 atom1* truthvalue1 subst context1 residue)))
+ ;; resolve row1 with other rows:
+ (retrieve-resolvable-entries
+ atom1
+ nil
+ (if (eq false truthvalue2)
+ #'tme-rows-containing-atom-positively
+ #'tme-rows-containing-atom-negatively)
+ ->* atom2-entry row2s)
+ (tme-term atom2-entry -> atom2)
+ (quote nil -> atom2*)
+ (map-rows :rowset row2s :reverse t ->* row2)
+ (row-context-live? row2 ->nonnil context2)
+ (selected-atoms-in-row row2 orderfun -> selected-atoms-in-row2)
+ (when (and (row-given-p row2)
+ (not (row-hint-p row2))
+ (or (and (row-unit-p row1) (row-unit-p row2))
+ (meets-binary-restrictions-p row1 row2))
+ (selected-atom-p atom2 polarity2 selected-atoms-in-row2 orderfun))
+ (setq-once atom1* (instantiate atom1 1))
+ (setq-once atom2* (instantiate atom2 2))
+ (unify atom1* atom2* nil ->* subst)
+ (when (and (selected-atom-p atom1 polarity1 selected-atoms-in-row1 orderfun subst 1 atom1*)
+ (selected-atom-p atom2 polarity2 selected-atoms-in-row2 orderfun subst 2 atom2*))
+ (make-resolvent row1 atom1 atom1* truthvalue1
+ row2 atom2 atom2* truthvalue2
+ subst context1 context2))))))
+ (prog->
+ (dolist selected-atoms-in-row1 ->* x)
+ (values-list x -> atom1 polarity1)
+ (unless (eq :neg polarity1)
+ (resolver1 atom1 false true :pos :neg))
+ (unless (eq :pos polarity1)
+ (resolver1 atom1 true false :neg :pos))))))
+
+(defun code-resolver (row1)
+ (when (row-hint-p row1)
+ (return-from code-resolver nil))
+ (prog->
+ (when (row-supported row1)
+ (row-context-live? row1 ->nonnil context1)
+ (instantiate (row-wff row1) 1 -> wff1)
+ (dolist (use-resolve-code?) ->* fun)
+ (funcall fun wff1 nil ->* subst &optional wff1*)
+ (make-resolventb row1 (or wff1* false) subst context1))))
+
+(definline hyperresolution-electron-polarity ()
+ ;; every atom in an electron has this polarity
+ (if *negative-hyperresolution* :neg :pos))
+
+(definline hyperresolution-nucleus-polarity ()
+ ;; some atom in a nucleus has this polarity
+ (if *negative-hyperresolution* :pos :neg))
+
+(definline row-hyperresolution-electron-p (row)
+ (if *negative-hyperresolution* (row-negative-p row) (row-positive-p row)))
+
+(definline hyperresolution-orderfun ()
+ (if *negative-hyperresolution*
+ (use-literal-ordering-with-negative-hyperresolution?)
+ (use-literal-ordering-with-hyperresolution?)))
+
+(defun hyperresolver (row)
+ (when (row-hint-p row)
+ (return-from hyperresolver nil))
+ (prog->
+ (cond
+ ((row-hyperresolution-electron-p row)
+ (hyperresolution-orderfun -> orderfun)
+ (dolist (selected-atoms-in-row row orderfun) ->* x) ;row is electron
+ (values-list x -> atom2 polarity2)
+ (if (eq :pos polarity2) false true -> truthvalue2)
+ (prog-> ;use procedural attachment as unit nucleus
+ (row-context-live? row ->nonnil context)
+ (when (row-supported row)
+ (quote nil -> atom2*)
+ (dolist (and (compound-p atom2) (function-resolve-code2 (head atom2) polarity2)) ->* fun)
+ (funcall fun (setq-once atom2* (instantiate atom2 1)) nil ->* subst &optional residue)
+ (selected-atoms-in-row row orderfun -> selected-atoms-in-row)
+ (when (selected-atom-p atom2 polarity2 selected-atoms-in-row orderfun subst 1 atom2*)
+ (make-resolventa row atom2 atom2* truthvalue2 subst context residue))))
+ (prog->
+ (quote nil -> atom2*)
+ (retrieve-resolvable-entries
+ atom2
+ nil
+ (if *negative-hyperresolution*
+ #'tme-rows-containing-atom-positively
+ #'tme-rows-containing-atom-negatively)
+ ->* atom1-entry row1s)
+ (tme-term atom1-entry -> atom1)
+ (quote nil -> atom1*)
+ (map-rows :rowset row1s :reverse t ->* row1)
+ (when (and (row-given-p row1)
+ (not (row-hint-p row1)))
+ (setq-once atom1* (instantiate atom1 1))
+ (setq-once atom2* (instantiate atom2 2))
+ (unify atom1* atom2* nil ->* subst)
+ (hyperresolver1 row1 atom1 row atom2 atom2* subst))))
+ (t ;row is nucleus
+ (let ((atoms nil) (atoms* nil))
+ (prog->
+ (map-atoms-in-wff (row-wff row) ->* atom polarity)
+ (when (and (eq (hyperresolution-nucleus-polarity) polarity)
+ (not (do-not-resolve atom))
+ (not (member atom atoms))) ;equal-p => eq for canonical terms
+ (push atom atoms)
+ (push (instantiate atom 1) atoms*)))
+ (when atoms*
+ (hyperresolver2 row nil (nreverse atoms*) 2 nil nil)))))))
+
+(defun hyperresolver1 (nucleus atom1 electron atom2 atom2* subst)
+ (let ((atoms nil) (atoms* nil))
+ (prog->
+ (map-atoms-in-wff (row-wff nucleus) ->* atom polarity)
+ (when (and (neq atom atom1) ;equal-p => eq for canonical terms
+ (eq (hyperresolution-nucleus-polarity) polarity)
+ (not (do-not-resolve atom))
+ (not (member atom atoms))) ;equal-p => eq for canonical terms
+ (push atom atoms)
+ (push (instantiate atom 1) atoms*))) ;no dereferencing needed
+ (hyperresolver2 nucleus (list (list electron atom2 atom2*)) (nreverse atoms*) 3 nil subst)))
+
+(defun hyperresolver2 (nucleus electrons atoms* n residues subst)
+ (declare (type fixnum n))
+ (prog->
+ (hyperresolution-orderfun -> orderfun)
+ (cond
+ ((null atoms*)
+ (when (and (or (row-supported nucleus)
+ (some (lambda (x) (row-supported (first x))) electrons))
+ (selected-atoms-in-hyperresolution-electrons-p electrons subst))
+ (make-hyperresolvent nucleus electrons residues subst)))
+ (t
+ (first atoms* -> atom*)
+ (when (test-option9?)
+ (let ((atom** (rewriter atom* subst)))
+ ;; should record what rewrites are used
+ (when (neq none atom*)
+ (cond
+ ((eq true atom**)
+ (return-from hyperresolver2
+ (unless *negative-hyperresolution*
+ (hyperresolver2 nucleus electrons (rest atoms*) n residues subst))))
+ ((eq false atom**)
+ (return-from hyperresolver2
+ (when *negative-hyperresolution*
+ (hyperresolver2 nucleus electrons (rest atoms*) n residues subst))))
+ (t
+ (setf atom* atom**))))))
+ (prog->
+ (dolist (and (compound-p atom*)
+ (function-resolve-code2 (head atom*) (if *negative-hyperresolution* false true)))
+ ->* fun)
+ (funcall fun atom* subst ->* subst &optional residue)
+ (cons (function-code-name (head atom*)) *resolve-functions-used* -> *resolve-functions-used*)
+ (hyperresolver2 nucleus electrons (rest atoms*) n (cons-unless-nil residue residues) subst))
+ (retrieve-resolvable-entries
+ atom*
+ subst
+ (if *negative-hyperresolution* #'tme-rows-containing-atom-negatively #'tme-rows-containing-atom-positively)
+ ->* atomn-entry rowns)
+ (tme-term atomn-entry -> atomn)
+ (quote nil -> atomn*)
+ (map-rows :rowset rowns :reverse t ->* rown)
+ (selected-atoms-in-row rown orderfun -> selected-atoms-in-rown)
+ (when (and (row-given-p rown)
+ (not (row-hint-p rown))
+ (row-hyperresolution-electron-p rown))
+ (when (selected-atom-p
+ atomn
+ (hyperresolution-electron-polarity)
+ selected-atoms-in-rown
+ orderfun)
+ (unify (first atoms*) (setq-once atomn* (instantiate atomn n)) subst ->* subst)
+ (hyperresolver2 nucleus (cons (list rown atomn atomn*) electrons) (rest atoms*) (+ n 1) residues subst)))))))
+
+(defun ur-resolver (row)
+ (when (row-clause-p row) ;nucleus
+ (ur-resolver1 row))
+ (when (row-unit-p row) ;electron
+ (prog->
+ (map-atoms-in-wff (row-wff row) ->* atom2 polarity2)
+ (setf atom2 (instantiate atom2 2))
+ (retrieve-resolvable-entries
+ atom2
+ nil
+ (if (eq :pos polarity2) #'tme-rows-containing-atom-negatively #'tme-rows-containing-atom-positively)
+ ->* atom1-entry row1s)
+ (tme-term atom1-entry -> atom1)
+ (quote nil -> atom1*)
+ (map-rows :rowset row1s :reverse t ->* row1) ;nucleus
+ (when (and (row-given-p row1)
+ (row-clause-p row1)
+ (not (row-hint-p row1))
+ (not (row-unit-p row1)))
+ (setq-once atom1* (instantiate atom1 1))
+ (unify atom1* atom2 ->* subst)
+ (ur-resolve1 row1 (list row) nil nil subst (atoms-in-clause2 (row-wff row1) atom1) 3))))
+ nil)
+
+(defun ur-resolver1 (nucleus)
+ (when (row-hint-p nucleus)
+ (return-from ur-resolver1 nil))
+ (ur-resolve1 nucleus nil nil nil nil (atoms-in-clause2 (row-wff nucleus)) 2))
+
+(defun ur-resolve1 (nucleus electrons target-atom target-polarity subst l k)
+ (declare (type fixnum k))
+ (cond
+ ((null l)
+ (when (and (or electrons *resolve-functions-used*)
+ (or (row-supported nucleus)
+ (some #'row-supported electrons))
+ (implies (and target-atom
+ (use-literal-ordering-with-ur-resolution?)
+ (clause-p (row-wff nucleus)))
+ (literal-is-not-dominating-in-clause-p
+ (use-literal-ordering-with-ur-resolution?)
+ target-atom
+ target-polarity
+ (instantiate (row-wff nucleus) 1)
+ subst)))
+ (make-ur-resolvent nucleus electrons target-atom target-polarity subst)))
+ (t
+ (let ((atom1 (instantiate (first (first l)) 1))
+ (polarity1 (second (first l))))
+ (when (null target-atom)
+ (ur-resolve1 nucleus electrons atom1 polarity1 subst (rest l) k))
+ (when (eq target-polarity polarity1)
+ (prog->
+ (unify target-atom atom1 subst ->* subst)
+ (ur-resolve1 nucleus electrons target-atom target-polarity subst (rest l) k)))
+ (prog->
+ (dolist (and (compound-p atom1) (function-resolve-code2 (heada atom1) polarity1)) ->* fun)
+ (funcall fun atom1 subst ->* subst &optional residue)
+ (unless residue
+ (cons (function-code-name (head atom1)) *resolve-functions-used* -> *resolve-functions-used*)
+ (ur-resolve1 nucleus electrons target-atom target-polarity subst (rest l) k)))
+ (prog->
+ (retrieve-resolvable-entries
+ atom1
+ subst
+ (if (eq :pos polarity1) #'tme-rows-containing-atom-negatively #'tme-rows-containing-atom-positively)
+ ->* atomk-entry rowks)
+ (tme-term atomk-entry -> atomk)
+ (quote nil -> atomk*)
+ (map-rows :rowset rowks :reverse t ->* rowk)
+ (when (and (row-given-p rowk)
+ (not (row-hint-p rowk))
+ (row-unit-p rowk))
+ (setq-once atomk* (instantiate atomk k))
+ (unify atom1 atomk* subst ->* subst)
+ (ur-resolve1 nucleus (cons rowk electrons) target-atom target-polarity subst (rest l) (+ k 1))))))))
+
+(defun backward-demodulate-by (row1)
+ (when (row-hint-p row1)
+ (return-from backward-demodulate-by nil))
+ (loop for rewrite in (row-rewrites row1)
+ as pattern = (rewrite-pattern rewrite)
+ as value = (rewrite-value rewrite)
+ as pattern-symbol-count = (rewrite-pattern-symbol-count rewrite)
+ as cond = (rewrite-condition rewrite)
+ as embeddings = (rewrite-embeddings rewrite)
+ when (if (or (eq true value) (eq false value))
+ (and (use-simplification-by-units?)
+ (neq :forward (use-simplification-by-units?)))
+ (and (use-simplification-by-equalities?)
+ (neq :forward (use-simplification-by-equalities?))))
+ do (prog->
+ (row-context-live? row1 ->nonnil context1)
+ (instantiate pattern 1 -> pattern*)
+ (instantiate value 1 -> value*)
+ (retrieve-instance-entries pattern* nil ->* e-entry)
+ (tme-term e-entry -> e)
+ (let ((row2s (tme-rows-containing-term e-entry)) e*) ;paramodulatable term?
+ (unless (rowset-empty? row2s)
+ (when (block it
+ (prog->
+ (rewrite-patterns-and-values
+ pattern* value* pattern-symbol-count embeddings (symbol-count e) ->* pattern** value**)
+ (subsume pattern** e nil ->* subst)
+ (when (and (or (eq cond t) (funcall cond pattern* value* subst))
+ (term-subsort-p value** pattern** subst))
+ (setf e* (instantiate value** subst))
+ (return-from it t)))
+ nil)
+ (prog->
+ (map-rows :rowset row2s :reverse t ->* row2)
+ (row-context-live? row2 ->nonnil context2)
+ (unless (or (eq row1 row2)
+ (row-embedding-p row2)
+ (row-deleted-p row2)
+ (not (eq t (context-subsumes? context1 context2))))
+ (cond
+ ((row-hint-p row2)
+ (when (or (eq true value) (eq false value))
+ (pushnew row2 *hints-subsumed*))
+ nil)
+ ((or (eq true value) (eq false value))
+ (let ((result (make-resolvent1 row1 pattern (if (eq true value) false true)
+ row2 e value nil context1 context2)))
+ (when result
+ (unless (eq :tautology result)
+ (setf (row-reason result) `(rewrite ,row2 ,row1)))
+ result)))
+ (t
+ (make-demodulant row1 row2 (substitute e* e (row-wff row2)) context1 context2))
+ ->nonnil demodulant)
+ (if recursive-unstore
+ (recursively-unstore-wff row2 "Simplified" (lambda (x) (eq row1 x)))
+ (unstore-wff row2 "Simplified"))
+ (unless (eq :tautology demodulant)
+ (record-backward-simplifiable-wff demodulant)))))))))
+ (setf *printing-deleted-messages* nil)
+ (prog->
+ (identity *hint-rows* -> hints)
+ (unless (rowset-empty? hints)
+ (row-wff row1 -> wff1)
+ (when (equality-p wff1)
+ (row-context-live? row1 ->nonnil context1)
+ (identity nil -> wff1*)
+ (map-rows :rowset hints ->* row2)
+ (row-context-live? row2 ->nonnil context2)
+ (unless (or (row-deleted-p row2)
+ (not (eq t (context-subsumes? context1 context2))))
+ (setq-once wff1* (renumber-new wff1))
+ (when (subsumes-p wff1* (row-wff row2))
+ (pushnew row2 *hints-subsumed*))))))
+ nil)
+
+(defun paramodulater-from (row1)
+ (when (row-hint-p row1)
+ (return-from paramodulater-from nil))
+ (prog->
+ (use-literal-ordering-with-paramodulation? -> orderfun)
+ (row-wff row1 -> wff1)
+ (when (and (implies (and orderfun
+ (not (test-option3?))
+ (not (row-sequential row1)) ;don't restrict to equality wff if sequential snark-20061213b
+ (clause-p wff1))
+ (positive-equality-wff-p wff1))
+ (implies (use-paramodulation-only-from-units?) (equality-p wff1)))
+ (map-atoms-in-wff wff1 ->* atom1 polarity1)
+ (when (and (neq polarity1 :neg)
+ (equality-p atom1)
+ (if (row-sequential row1)
+ (atom-satisfies-sequential-restriction-p atom1 wff1)
+ (implies orderfun (literal-satisfies-ordering-restriction-p
+ orderfun atom1 :pos wff1))))
+ (args atom1 -> args)
+ (first args -> a)
+ (second args -> b)
+ (unless (eq a b) ;equal-p => eq for canonical terms
+ (simplification-ordering-compare-equality-arguments atom1 nil -> dir)
+ (setf a (instantiate a 1))
+ (setf b (instantiate b 1))
+ (unless (or (variable-p a) (eq '< dir))
+ (paramodulater-from1 row1 atom1 a b dir))
+ (unless (or (variable-p b) (eq '> dir))
+ (paramodulater-from1 row1 atom1 b a dir)))))))
+
+(defun paramodulater-from1 (row1 equality1 pattern1* value1* dir)
+ ;; row1 has the equality
+ (declare (ignore dir))
+ (prog->
+ (row-context-live? row1 ->nonnil context1)
+ (and (row-embedding-p row1) (embedding-variables row1 1) -> embedding-variables1)
+ (retrieve-paramodulatable-entries pattern1* nil ->* term2-entry)
+ (tme-term term2-entry -> term2)
+ (unless (variable-p term2)
+ (rows-containing-paramodulatable-term term2 -> row2s)
+ (when row2s
+ (setf row2s (impose-binary-restrictions row1 row2s))
+ (when row2s
+ (instantiate term2 2 -> term2*)
+ (and embedding-variables1 ;unify-bag only cares if both terms are embeddings
+ (loop for row2 in row2s
+ always (and (row-embedding-p row2)
+ (or (equal-p term2 (first (args (row-wff row2))) nil)
+ (equal-p term2 (second (args (row-wff row2))) nil))))
+ (embedding-variables (car row2s) 2)
+ -> embedding-variables2)
+ (and embedding-variables2 (append embedding-variables1 embedding-variables2) -> *embedding-variables*)
+ (when (allowable-embedding-superposition (row-embedding-p row1) (row-embedding-p (car row2s)))
+ (unify pattern1* term2* nil ->* subst)
+ (unless (or (equal-p pattern1* value1* subst)
+;; (and (neq dir '>)
+;; (neq dir '<)
+;; (eq '< (simplification-ordering-compare-terms pattern1* value1* subst '<)))
+ )
+ (dolist row2s ->* row2)
+ (row-context-live? row2 ->nonnil context2)
+ (make-paramodulant row1 equality1 value1* row2 term2* subst context1 context2))))))))
+
+(defun paramodulater-to (row2)
+ (when (row-hint-p row2)
+ (return-from paramodulater-to nil))
+ (prog->
+ (quote nil -> done)
+ (use-literal-ordering-with-paramodulation? -> orderfun)
+ (row-wff row2 -> wff2)
+ (implies (and orderfun
+ (not (test-option3?))
+ (clause-p wff2))
+ (positive-equality-wff-p wff2)
+ -> paramodulate-to-equalities)
+ (dolist (selected-atoms-in-row row2 orderfun) ->* x)
+ (values-list x -> atom2 polarity2)
+ (cond
+ ((and (eq :pos polarity2) (equality-p atom2))
+ (when paramodulate-to-equalities
+ (args atom2 -> args)
+ (first args -> a)
+ (second args -> b)
+ (simplification-ordering-compare-equality-arguments atom2 nil -> dir)
+ (unless (eq '< dir)
+ (map-terms-in-term a nil polarity2 ->* term2 polarity)
+ (declare (ignore polarity))
+ (unless (or (variable-p term2) (member term2 done) (and (row-embedding-p row2) (neq term2 a)))
+ (paramodulater-to1 row2 term2 (instantiate term2 2) dir (eq term2 a))
+ (push term2 done)))
+ (unless (eq '> dir)
+ (map-terms-in-term b nil polarity2 ->* term2 polarity)
+ (declare (ignore polarity))
+ (unless (or (variable-p term2) (member term2 done) (and (row-embedding-p row2) (neq term2 b)))
+ (paramodulater-to1 row2 term2 (instantiate term2 2) dir (eq term2 b))
+ (push term2 done)))))
+ ((not (row-embedding-p row2))
+ (map-terms-in-atom atom2 nil :pos ->* term2 polarity)
+ (declare (ignore polarity))
+ (unless (or (variable-p term2) (member term2 done))
+ (paramodulater-to1 row2 term2 (instantiate term2 2) nil)
+ (push term2 done))))))
+
+(defun paramodulater-to1 (row2 term2 term2* dir &optional code-only)
+ (declare (ignore dir))
+ (prog->
+ (row-context-live? row2 ->nonnil context2)
+ (when (row-supported row2)
+ (dolist (and (compound-p term2*) (function-paramodulate-code (head term2*))) ->* fun)
+ (funcall fun term2* nil ->* value1* subst)
+ (make-paramodulanta value1* row2 term2* subst context2))
+ (when code-only
+ (return-from paramodulater-to1))
+ (and (row-embedding-p row2)
+ (or (equal-p term2 (first (args (row-wff row2))) nil)
+ (equal-p term2 (second (args (row-wff row2))) nil))
+ (embedding-variables row2 2) -> embedding-variables2)
+ (retrieve-paramodulatable-entries term2* nil #'tme-rows-containing-paramodulatable-equality ->* pattern1-entry ws)
+ (tme-term pattern1-entry -> pattern1)
+ (instantiate pattern1 1 -> pattern1*)
+ (dolist ws ->* w)
+ (car w -> row1)
+ (row-context-live? row1 ->nonnil context1)
+ (when (and (not (row-hint-p row1)) (meets-binary-restrictions-p row2 row1))
+ (cdr w -> value1)
+ (unless (eq pattern1 value1) ;equal-p => eq for canonical terms
+ (make-compound *=* pattern1 value1 -> equality1)
+ (when (if (row-sequential row1)
+ (atom-satisfies-sequential-restriction-p equality1 (row-wff row1))
+ (let ((orderfun (use-literal-ordering-with-paramodulation?)))
+ (implies orderfun (literal-satisfies-ordering-restriction-p
+ orderfun equality1 :pos (row-wff row1)))))
+ (instantiate value1 1 -> value1*)
+ (and embedding-variables2 ;unify-bag only cares if both terms are embeddings
+ (row-embedding-p row1)
+ (embedding-variables row1 1)
+ -> embedding-variables1)
+ (and embedding-variables1 (append embedding-variables1 embedding-variables2) -> *embedding-variables*)
+ (when (allowable-embedding-superposition (row-embedding-p row1) (row-embedding-p row2))
+ (unify pattern1* term2* nil ->* subst)
+ (unless (or (equal-p pattern1* value1* subst)
+;; (and (neq dir '>)
+;; (neq dir '<)
+;; (eq '< (simplification-ordering-compare-terms pattern1* value1* subst '<)))
+ )
+ (unless (eql (row-number row1) (row-number row2))
+ ;;don't duplicate work (DO THIS IN IMPOSE-BINARY-RESTRICTIONS INSTEAD)
+ (make-paramodulant row1 equality1 value1* row2 term2* subst context1 context2)))))))))
+
+(defun paramodulation-allowable-p (term row)
+ (prog->
+ (row-wff row -> wff)
+ (map-atoms-in-wff wff ->* atom polarity)
+ (identity nil -> atom-not-selected)
+ (cond
+ ((and (eq :pos polarity) (equality-p atom))
+ (args atom -> args)
+ (simplification-ordering-compare-equality-arguments atom nil -> dir)
+ (unless (eq '< dir)
+ (when (if (row-embedding-p row) (equal-p term (first args) nil) (occurs-p term (first args) nil))
+ (if (if (row-sequential row)
+ (atom-satisfies-sequential-restriction-p atom wff)
+ (let ((orderfun (use-literal-ordering-with-paramodulation?)))
+ (implies orderfun (literal-satisfies-ordering-restriction-p orderfun atom polarity wff))))
+ (return-from paramodulation-allowable-p t)
+ (setf atom-not-selected t))))
+ (unless atom-not-selected
+ (unless (eq '> dir)
+ (when (if (row-embedding-p row) (equal-p term (second args) nil) (occurs-p term (second args) nil))
+ (when (if (row-sequential row)
+ (atom-satisfies-sequential-restriction-p atom wff)
+ (let ((orderfun (use-literal-ordering-with-paramodulation?)))
+ (implies orderfun (literal-satisfies-ordering-restriction-p orderfun atom polarity wff))))
+ (return-from paramodulation-allowable-p t))))))
+ ((occurs-p term atom nil)
+ (when (if (row-sequential row)
+ (atom-satisfies-sequential-restriction-p atom wff)
+ (let ((orderfun (use-literal-ordering-with-paramodulation?)))
+ (implies orderfun (literal-satisfies-ordering-restriction-p orderfun atom polarity wff))))
+ (return-from paramodulation-allowable-p t)))))
+ nil)
+
+(defun rows-containing-paramodulatable-term (term)
+ (rows :rowset (rows-containing-term term)
+ :reverse t
+ :test (lambda (row)
+ (and (row-given-p row)
+ (implies (use-paramodulation-only-into-units?) (row-unit-p row))
+ (paramodulation-allowable-p term row)))))
+
+(defun make-embeddings (cc row)
+ (unless (row-embedding-p row)
+ (let ((wff (row-wff row)))
+ (when (equality-p wff)
+ (flet ((embed? (x)
+ (and (compound-appl-p x)
+ (function-associative (heada x))
+ (dolist (fun (function-unify-code (heada x)) nil)
+ (when (or (eq 'ac-unify fun) (eq 'associative-unify fun))
+ (return t)))
+ (not (function-do-not-paramodulate (heada x))))))
+ (mvlet* (((list a b) (args wff))
+ (embed-a (embed? a))
+ (embed-b (embed? b)))
+ (when (or embed-a embed-b)
+ (with-clock-on embedding
+ (let ((dir (simplification-ordering-compare-terms a b)))
+ (cond
+ ((eq '> dir)
+ (when embed-a
+ (make-embeddings1 cc row a b)))
+ ((eq '< dir)
+ (when embed-b
+ (make-embeddings1 cc row b a)))
+ ((and embed-a embed-b (eq (heada a) (heada b)))
+ (make-embeddings1 cc row a b))
+ (t
+ (when embed-a
+ (make-embeddings1 cc row a b))
+ (when embed-b
+ (make-embeddings1 cc row b a)))))))))))))
+
+(defun make-embeddings1 (cc row a b)
+ (let* ((head (head a))
+ (args (args a))
+ (sort (function-sort head))
+ (newvar2 (make-variable sort))
+ (temp (append args (list newvar2))))
+ (cond
+ ((function-commutative head)
+ (let ((a* (make-compound* head temp))
+ (b* (make-compound head b newvar2))) ;might not be flattened
+ (unless (subsumes-p (renumber (cons a b)) (cons a* b*))
+ (funcall cc (make-embedding row a* b* t)))))
+ (t
+ (let ((newvar1 (make-variable sort))
+ (abs (list (renumber (cons a b)))))
+ (let ((a* (make-compound* head (cons newvar1 args)))
+ (b* (make-compound head newvar1 b))) ;might not be flattened
+ (unless (dolist (ab abs)
+ (when (subsumes-p ab (cons a* b*))
+ (return t)))
+ (push (renumber (cons a* b*)) abs)
+ (funcall cc (make-embedding row a* b* :l))))
+ (let ((a* (make-compound* head temp))
+ (b* (make-compound head b newvar2))) ;might not be flattened
+ (unless (dolist (ab abs)
+ (when (subsumes-p ab (cons a* b*))
+ (return t)))
+ (push (renumber (cons a* b*)) abs)
+ (funcall cc (make-embedding row a* b* :r))))
+ (let ((a* (make-compound* head (cons newvar1 temp)))
+ (b* (make-compound head newvar1 b newvar2))) ;might not be flattened
+ (unless (dolist (ab abs)
+ (when (subsumes-p ab (cons a* b*))
+ (return t)))
+ (funcall cc (make-embedding row a* b* :l&r)))))))))
+
+(defun make-embedding (row a1 b1 type)
+ (make-row :wff (make-equality a1 b1 nil)
+ :constraints (row-constraints row)
+ :answer (row-answer row)
+ :supported (row-supported row)
+ :sequential (row-sequential row)
+ :context (row-context row)
+ :reason (if (eq t type) `(embed ,row) `(embed ,row ,type))))
+
+(defun embedding-variables (embedding+ n)
+ ;; may not return all embedding-variables because the embedding
+ ;; (= (f a ?x) (f b ?x)) might be stored as (= (f a ?x) (f ?x b)) if f is AC
+ (mvlet ((vars nil)
+ ((list arg1 arg2) (args (row-wff embedding+))))
+ (when (and (compound-appl-p arg1)
+ (compound-appl-p arg2)
+ (eq (heada arg1) (heada arg2)))
+ (let ((type (row-embedding-p embedding+)))
+ (when (or (eq :l&r type) (eq :r type) (eq t type))
+ (let ((x (first (last (argsa arg1))))
+ (y (first (last (argsa arg2)))))
+ (when (and (eq x y) (variable-p x))
+ (push (instantiate x n) vars))))
+ (when (or (eq :l&r type) (eq :l type))
+ (let ((x (first (argsa arg1)))
+ (y (first (argsa arg2))))
+ (when (and (eq x y) (variable-p x))
+ (push (instantiate x n) vars))))))
+ vars))
+
+(defun allowable-embedding-superposition (type1 type2)
+ (or (null type1)
+ (null type2)
+ (and (eq t type1) (eq t type2))
+ (and (eq :l type1) (eq :r type2))
+ (and (eq :r type1) (eq :l type2))))
+
+(defun do-not-paramodulate (term &optional subst)
+ (dereference term subst :if-compound-appl (function-do-not-paramodulate (heada term))))
+
+(defun meets-binary-restrictions-p (row1 row2)
+ (and (or (row-supported row1) (row-supported row2))
+ (implies (use-unit-restriction?) (or (row-unit-p row1) (row-unit-p row2)))
+ (implies (use-input-restriction?) (or (row-input-p row1) (row-input-p row2)))))
+
+(defun impose-binary-restrictions (row1 l &key (key #'identity))
+ (remove-if-not (lambda (x) (meets-binary-restrictions-p row1 (funcall key x))) l))
+
+(defun process-new-row-msg (control-string &rest args)
+ (when (print-rows-when-processed?)
+ (with-clock-on printing
+ (format t "~%; ")
+ (apply #'format t control-string args))))
+
+(defun maybe-new-row (row)
+ (cond
+ ((symbolp (row-reason row))
+ (let ((row* (make-row :wff (row-wff row)
+ :constraints (row-constraints row)
+ :answer (row-answer row)
+ :reason row
+ :context (row-context row)
+ :supported (row-supported row)
+ :sequential (row-sequential row))))
+ (setf (row-wff row) (flatten-term (row-wff row) nil))
+ (renumber-row row)
+ (if (row-number row)
+ (set-row-number row* (incf *number-of-rows*)) ;new row is numbered iff original was
+ (set-row-number row (incf *number-of-rows*))) ;original row is now numbered
+ (incf *number-of-backward-eliminated-rows*)
+ row*))
+ (t
+ row)))
+
+(defun process-new-row (row agenda-value agenda)
+ (with-clock-on process-new-row
+ (let ((*processing-row* row)
+ (wff (row-wff row))
+ (*rewriting-row-context* (row-context-live? row)))
+ (unless *rewriting-row-context*
+ (return-from process-new-row nil))
+ (when (print-rows-when-processed?)
+ (print-processed-row row))
+ (when (eq true wff)
+ (process-new-row-msg "Row wff is true.")
+ (return-from process-new-row nil))
+ (when (row-pure row)
+ (process-new-row-msg "Row is pure.")
+ (return-from process-new-row nil))
+ (when (and (eq agenda *agenda-of-rows-to-process*)
+ (loop for parent in (row-parents row)
+ thereis (row-deleted-p parent)))
+ (process-new-row-msg "Row parent is deleted.")
+ (return-from process-new-row nil))
+ #+ignore
+ (when (and (use-constraint-purification?) (not (constraint-purified-row-p row)))
+ (process-new-row-msg "Row wff is not purified.")
+ (return-from process-new-row nil))
+ (when (and (use-clausification?) (not (clause-p wff)))
+ (process-new-row-msg "Row wff will be and-split.")
+ #+ignore (progn (terpri) (print-term wff))
+ (clausify wff (lambda (clause) (insert-row-into-agenda (make-split row clause (row-answer row) :pos) agenda-value *agenda-of-rows-to-process* t)))
+ (return-from process-new-row nil))
+ (dolist (fun (pruning-tests-before-simplification?))
+ (when (funcall fun row)
+ (process-new-row-msg "Row is unacceptable before simplification.")
+ (return-from process-new-row nil)))
+ (let ((answer (row-answer row))
+ constraint-alist
+ (and-split-this nil))
+ (when (and (or (use-simplification-by-units?) (use-simplification-by-equalities?)) (not (row-hint-p row)))
+ (let ((*rewrites-used* (row-rewrites-used row)))
+ (unless (row-embedding-p row)
+ (let ((wff* (with-clock-on forward-simplification (rewriter wff nil))))
+ (unless (eq wff wff*)
+ (when (eq true wff*)
+ (process-new-row-msg "Simplified row wff is true.")
+ (return-from process-new-row nil))
+ (when *rewrites-used*
+ (setf row (maybe-new-row row))
+ (setf (row-rewrites-used row) *rewrites-used*))
+ (setf (row-wff row) (setf wff wff*))))
+ (when (rewrite-answers?)
+ (let ((answer* (with-clock-on forward-simplification (rewriter answer nil))))
+ (unless (eq answer answer*)
+ (when *rewrites-used*
+ (setf row (maybe-new-row row))
+ (setf (row-rewrites-used row) *rewrites-used*))
+ (setf (row-answer row) (setf answer answer*))))))
+ ;; inefficient to always rewrite constraints
+ ;; can't rewrite constraints already in global data structures
+ (let ((constraints (row-constraints row)))
+ (when constraints
+ (let ((constraints* (with-clock-on forward-simplification (rewrite-constraint-alist constraints))))
+ (unless (eq constraints constraints*)
+ (when *rewrites-used*
+ (setf row (maybe-new-row row))
+ (setf (row-rewrites-used row) *rewrites-used*))
+ (setf (row-constraints row) constraints*)))))))
+ (let ((*check-for-disallowed-answer* t))
+ (when (answer-disallowed-p answer)
+ (process-new-row-msg "Row answer contains disallowed symbol.")
+ (return-from process-new-row nil)))
+ (setf constraint-alist (row-constraints row))
+ (when constraint-alist
+ (with-clock-off constraint-simplification
+ (setf (row-constraints row) (setf constraint-alist (simplify-constraint-alist constraint-alist)))))
+ (dolist (x constraint-alist)
+ (when (eq false (cdr x))
+ (process-new-row-msg "Row constraint is false.")
+ (return-from process-new-row nil)))
+ (when (and (use-function-creation?) (equality-p wff))
+ (let* ((args (args wff))
+ (vars1 (variables (first args)))
+ (vars2 (variables (second args))))
+ ;; (when (and (set-difference vars1 vars2)
+ ;; (set-difference vars2 vars1))
+ ;; (let* ((vars (intersection vars1 vars2))
+ ;; (fn (declare-function (newsym) (length vars)))
+ ;; (val (make-compound* fn vars)))
+ (when (and vars1 vars2 (null (intersection vars1 vars2))) ;create only constants
+ (let* ((vars nil)
+ (fn (declare-constant (newsym)))
+ (val fn))
+ (if vars
+ (setf (function-created-p fn) t)
+ (setf (constant-created-p fn) t))
+ (when (eq :rpo (use-term-ordering?))
+ (rpo-add-created-function-symbol fn))
+ (setf (row-wff row) (setf wff (conjoin
+ (make-equality (first args) val)
+ (make-equality (second args) val))))
+ (setf and-split-this t)))))
+ (when (or and-split-this (and (use-clausification?) (not (clause-p wff))))
+ (process-new-row-msg "Row wff will be and-split.")
+ #+ignore (progn (terpri) (print-term wff))
+ (clausify wff (lambda (clause) (insert-row-into-agenda (make-split row clause answer :pos) agenda-value *agenda-of-rows-to-process* t)))
+ (return-from process-new-row nil))
+ (when (and (use-condensing?) (not (row-hint-p row)) (row-bare-p row) (not (literal-p wff)) (clause-p wff))
+ (with-clock-on condensing
+ (let ((wff* (condenser wff)))
+ (unless (eq wff wff*)
+ (setf row (maybe-new-row row))
+ (setf (row-wff row) (setf wff wff*))
+ (setf (row-reason row) (list 'condense (row-reason row)))))))
+ (unless (or (not (use-subsumption?))
+ (and (use-simplification-by-units?) (row-bare-unit-p row))
+ (row-hint-p row)
+ (row-embedding-p row))
+ (let ((subsuming-row (forward-subsumed row)))
+ (when subsuming-row
+ (process-new-row-msg "Row is forward subsumed by row ~A." (row-name-or-number subsuming-row))
+ (return-from process-new-row nil))))
+ (dolist (fun (pruning-tests?))
+ (when (funcall fun row)
+ (process-new-row-msg "Row is unaccepable.")
+ (return-from process-new-row nil)))
+ (when (and (use-embedded-rewrites?) (not (row-hint-p row)))
+ (make-embeddings #'record-new-embedding row))
+ (prog->
+ (setf (row-wff row) (setf wff (flatten-term (row-wff row) nil)))
+ (renumber-row row)
+ (set-row-number row (+ *number-of-rows* 1))
+ (when (prog1 (record-new-row-to-give row) (setf *printing-deleted-messages* nil))
+ (incf *number-of-rows*)
+ (when (print-rows-when-derived?)
+ (print-derived-row row))
+ (let ((*hints-subsumed* nil))
+ (unless (or (not (use-subsumption?))
+ (eq :forward (use-subsumption?))
+ (and (use-simplification-by-units?)
+ (neq :forward (use-simplification-by-units?))
+ (row-bare-unit-p row))
+ (row-embedding-p row)
+ (row-hint-p row))
+ (backward-subsumption
+ (lambda (subsumed-row)
+ (if recursive-unstore
+ (recursively-unstore-wff subsumed-row "Subsumed" (lambda (x) (eq row x)))
+ (unstore-wff subsumed-row "Subsumed")))
+ (make-row0 :wff wff ;NOT RENUMBERED
+ :constraints constraint-alist
+ :answer answer
+ :context (row-context row)
+ :reason (row-reason row)))
+ (setf *printing-deleted-messages* nil))
+ (rowset-insert row *rows*)
+ (when (eq false wff)
+ (if (row-constrained-p2 row)
+ (rowset-insert row *constraint-rows*)
+ (rowset-insert row *false-rows*)))
+ (when (and (row-hint-p row) (equality-p wff))
+ (rowset-insert row *hint-rows*))
+ (store-derived-wff row)
+ (unless (or (row-hint-p row) (row-embedding-p row))
+ (with-clock-on backward-simplification
+ (backward-demodulate-by row)))
+ (when *hints-subsumed*
+ (setf (row-hints-subsumed row) *hints-subsumed*)
+ (record-new-row-to-give-again row)))))
+ nil))))
+
+(defun row-pref (row)
+ (cond
+ ((row-hints-subsumed row)
+ 0)
+ (t
+ (funcall (agenda-ordering-function?) row))))
+
+(defun agenda-item-row (form)
+ (ecase (car form)
+ (giver
+ (second form))
+ (process-new-row
+ (second form))))
+
+(defun agenda-item-val (form)
+ (ecase (car form)
+ (giver
+ (third form))
+ (process-new-row
+ (third form))))
+
+(defun same-agenda-item-p (form1 form2)
+ (let ((row1 (agenda-item-row form1))
+ (row2 (agenda-item-row form2)))
+ (and (iff (row-number row1) (row-number row2))
+ (implies (not (use-subsumption-by-false?)) (neq false (row-wff row1))) ;keep other proofs
+ (equal-p (row-wff row1) (row-wff row2))
+ (equal-alist-p (row-constraints row1) (row-constraints row2) nil)
+ (equal-p (row-answer row1) (row-answer row2))
+ ;; something for case
+ (equal (row-context row1) (row-context row2))
+ (iff (row-hint-p row1) (row-hint-p row2))
+ )))
+
+(defun unstore-agenda-item (form)
+ (ecase (first form)
+ (giver
+ (let ((row (second form)))
+ (setf (row-agenda-entries row) (delete form (row-agenda-entries row))) ;don't double delete it from agenda
+ (unstore-wff row "Deleted because agenda full"))
+ (incf *number-of-agenda-full-deleted-rows*))))
+
+(defun insert-row-into-agenda (row val agenda &optional at-front)
+ (let ((v (if (row-number row)
+ `(giver ,row ,val ,agenda)
+ `(process-new-row ,row ,val ,agenda))))
+ (push v (row-agenda-entries row))
+ (agenda-insert v val agenda at-front)))
+
+(defun delete-row-from-agenda (row &optional test)
+ (let ((undeleted-agenda-entries nil) undeleted-agenda-entries-last)
+ (dolist (x (row-agenda-entries row))
+ (ecase (first x)
+ ((giver process-new-row)
+ (if (implies test (funcall test x))
+ (agenda-delete x (third x) (fourth x))
+ (collect x undeleted-agenda-entries)))))
+ (setf (row-agenda-entries row) undeleted-agenda-entries)))
+
+(defun pop-form-from-agenda ()
+ (let ((form (pop-agenda *agenda*)))
+ (dolist (x (rest form))
+ (when (row-p x)
+ (setf (row-agenda-entries x) (delete form (row-agenda-entries x)))))
+ form))
+
+(defun record-new-embedding (row)
+ (insert-row-into-agenda row 0 *agenda-of-new-embeddings-to-process*))
+
+(defun record-new-input-wff (row)
+ (insert-row-into-agenda row 0 *agenda-of-input-rows-to-process*))
+
+(defun record-backward-simplifiable-wff (row)
+ (cond
+ ((eq false (row-wff row))
+ (insert-row-into-agenda row 0 *agenda-of-false-rows-to-process*))
+ (t
+ (insert-row-into-agenda row 0 *agenda-of-backward-simplifiable-rows-to-process* t))))
+
+(defun record-new-derived-row (row)
+ (cond
+ ((eq false (row-wff row))
+ (insert-row-into-agenda row 0 *agenda-of-false-rows-to-process*))
+ (t
+ (mvlet (((values row-pref at-front) (row-pref row)))
+ (insert-row-into-agenda row row-pref *agenda-of-rows-to-process* at-front)))))
+
+(defun record-new-row-to-give (row)
+ (cond
+ ((eq false (row-wff row))
+ (insert-row-into-agenda row 0 *agenda-of-false-rows-to-process*))
+ (t
+ (mvlet (((values row-pref at-front) (row-pref row)))
+ (cond
+ ((row-input-p row)
+ (insert-row-into-agenda row row-pref *agenda-of-input-rows-to-give* at-front))
+ ((let ((p (level-pref-for-giving?)))
+ (and p (<= (row-level row) p)))
+ (insert-row-into-agenda row (cons 3 row-pref) *agenda-of-rows-to-give* at-front))
+ (t
+ (insert-row-into-agenda row (cons 4 row-pref) *agenda-of-rows-to-give* at-front)))))))
+
+(defun record-new-row-to-give-again (row)
+ ;; when the value of row-pref changes because the row subsumes a hint,
+ ;; use this to delete the row from the agenda and reinsert it with its higher priority
+ (when (row-agenda-entries row)
+ (delete-row-from-agenda row (lambda (x) (eq 'giver (first x))))
+ (record-new-row-to-give row)))
+
+(defun giver (given-row &optional agenda-value agenda)
+ (declare (ignore agenda-value agenda))
+ (unless (row-context-live? given-row)
+ (return-from giver nil))
+ (incf *number-of-given-rows*)
+ (print-given-row given-row)
+ (when (use-replacement-resolution-with-x=x?)
+ (let ((*check-for-disallowed-answer* t))
+ (when (resolve-with-x=x given-row)
+ (return-from giver nil))))
+ (when (resolve-with-x-eq-x given-row)
+ (return-from giver nil))
+ (when (resolve-with-x-eq-x2 given-row)
+ (return-from giver nil))
+ (store-given-row given-row)
+ (when (row-hint-p given-row)
+ (return-from giver nil))
+ (when (eq false (row-wff given-row))
+ (cond
+ ((not (row-constrained-p2 given-row))
+ (setf *proof* given-row)
+ (when (print-final-rows?)
+ (print-final-row given-row))
+ (return-from giver t))
+ (t
+ (give-constraint-row given-row)
+ (return-from giver nil))))
+ (let ((use-factoring? (use-factoring?)))
+ (when (and use-factoring?
+ (not (literal-p (row-wff given-row)))
+ (implies (eq :pos use-factoring?) (row-positive-p given-row))
+ (implies (eq :neg use-factoring?) (row-negative-p given-row)))
+ (with-clock-on factoring
+ (factorer given-row))))
+ (when (use-resolution?)
+ (with-clock-on resolution
+ (resolver given-row)))
+ (when (use-hyperresolution?)
+ (with-clock-on resolution
+ (let ((*negative-hyperresolution* nil))
+ (hyperresolver given-row))))
+ (when (use-negative-hyperresolution?)
+ (with-clock-on resolution
+ (let ((*negative-hyperresolution* t))
+ (hyperresolver given-row))))
+ (when (use-ur-resolution?)
+ (with-clock-on resolution
+ (ur-resolver given-row)))
+#+ignore
+ (when (use-ur-pttp?)
+ (with-clock-on resolution
+ (ur-pttp given-row)))
+ (when (use-paramodulation?)
+ (with-clock-on paramodulation
+ (paramodulater-from given-row)
+ (paramodulater-to given-row)))
+ (when (use-resolve-code?)
+ (with-clock-on resolution
+ (code-resolver given-row)))
+ nil)
+
+(defun give-constraint-row (given-row)
+ ;; given-row is of of the form 'constraints -> false'
+ (when (and (row-from-conjecture-p given-row) ;assumed consistent otherwise
+ (row-constraint-coverage (rows :rowset *constraint-rows* :reverse t)))
+ (record-new-derived-row
+ (make-row :wff false
+ :answer (let ((n 0))
+ (disjoin*
+ (rows :collect (lambda (x) (instantiate (row-answer x) (incf n)))
+ :rowset *constraint-rows*
+ :reverse t)))
+;;? :supported (row-supported row)
+;;? :sequential (row-sequential row)
+ :context (row-context given-row)
+ :reason `(combine ,@(rows :rowset *constraint-rows* :reverse t))))
+ (rowset-delete given-row *constraint-rows*)))
+
+(defun initialize-propositional-abstraction-of-input-wffs ()
+ (let ((clause-set (make-dp-clause-set)))
+ (dp-insert (list (list (function-name *=*) (function-arity *=*))) clause-set)
+ (setf *propositional-abstraction-of-input-wffs* clause-set)))
+
+(defun check-propositional-abstraction-of-input-wffs ()
+ ;; clause-set should be checkpointed so that
+ ;; assumptions and conjectures can be removed, e.g., by new-row-context
+ (with-clock-on satisfiability-testing
+ (let ((clause-set *propositional-abstraction-of-input-wffs*))
+ (prog->
+ (mapnconc-agenda *agenda-of-input-rows-to-process* ->* x)
+ (second x -> row)
+ (row-wff row -> wff)
+ (quote t -> *propositional-abstraction-term-to-lisp*)
+ (term-to-lisp wff -> wff*)
+ (cond
+ ((eq 'false wff*)
+ (return-from check-propositional-abstraction-of-input-wffs nil))
+ ((neq 'true wff*)
+ (dp-insert-wff wff* clause-set :print-warnings nil)))
+ nil)
+;; (dp-clauses 'print clause-set)
+ (dp-satisfiable-p clause-set
+ :find-all-models 1
+ :print-summary nil
+ :print-warnings nil
+ :trace nil
+ :trace-choices nil
+ :branch-limit 10000000))))
+
+(defun closure-init ()
+ (when (use-assertion-analysis?)
+ (complete-assertion-analysis))
+ (when critique-options
+ (with-clock-on printing
+ (critique-options)))
+ (unless rewrites-initialized
+ (initialize-rewrites)
+ (setf rewrites-initialized t))
+ (unless (use-closure-when-satisfiable?)
+ (let ((v (check-propositional-abstraction-of-input-wffs)))
+ (when v
+ (with-clock-on printing
+ (warn "Propositional abstraction of input is satisfiable with model ~S." (first v)))
+ (return-from closure-init :satisfiable))))
+ (when (use-purity-test?)
+ (with-clock-on purity-testing
+ (purity-test #'(lambda (cc)
+ (prog->
+ (dolist *agenda* ->* agenda)
+ (mapnconc-agenda agenda ->* form)
+ (funcall cc (second form))
+ nil)))))
+ nil)
+
+(defun give-is-next-in-agenda ()
+ (dolist (agenda *agenda* nil)
+ (when (< 0 (agenda-length agenda))
+ (let ((name (agenda-name agenda)))
+ (return (or (string= name "rows to give")
+ (string= name "input rows to give")))))))
+
+(defun closure (&key
+ (number-of-given-rows-limit (number-of-given-rows-limit?))
+ (number-of-rows-limit (number-of-rows-limit?))
+ (run-time-limit (run-time-limit?))
+ (only-unnumbered-rows nil)
+ (listen-for-commands (listen-for-commands?)))
+ (unwind-protect
+ (progn
+ (setf *snark-is-running* t)
+ (setf *proof* nil)
+ (let ((v (closure-init)))
+ (when v
+ (return-from closure v)))
+ (when number-of-given-rows-limit
+ (incf number-of-given-rows-limit *number-of-given-rows*))
+ (when number-of-rows-limit
+ (incf number-of-rows-limit *number-of-rows*))
+ (when run-time-limit
+ (incf run-time-limit (total-run-time)))
+ #+lcl5.0
+ (when listen-for-commands
+ (clear-input))
+ (loop
+ (when (and number-of-given-rows-limit (<= number-of-given-rows-limit *number-of-given-rows*) (give-is-next-in-agenda))
+ (return :number-of-given-rows-limit))
+ (when (and number-of-rows-limit (<= number-of-rows-limit *number-of-rows*))
+ (return :number-of-rows-limit))
+ (when (and run-time-limit (<= run-time-limit (total-run-time)))
+ (return :run-time-limit))
+ (when listen-for-commands
+ (case (read-char-no-hang *terminal-io* nil nil)
+ ((nil)
+ )
+ ((#\Q #\q)
+ (return :user-quit))
+ ((#\B #\b)
+ (with-clock-on halted
+ (clear-input)
+ (break "Break in closure at user request.")))
+ (otherwise
+ (with-clock-on halted
+ (clear-input)
+ (when (yes-or-no-p "Stop now? ")
+ (return :user-quit))))))
+ (when (and only-unnumbered-rows
+ (let ((v (agenda-first *agenda*)))
+ (and v (row-number (second v)))))
+ (return :only-unnumbered-rows))
+ (prog->
+ (pop-form-from-agenda -> form)
+ (cond
+ ((null form)
+ (return :agenda-empty))
+ ((apply (car form) (cdr form))
+ (return :proof-found))))))
+ (setf *snark-is-running* nil)
+ (when (print-summary-when-finished?)
+ (terpri)
+ (print-summary
+ :clocks (print-clocks-when-finished?)
+ :term-memory (print-term-memory-when-finished?)
+ :agenda (print-agenda-when-finished?)))
+ (when (print-rows-when-finished?)
+ (print-rows :ancestry t))
+ (nocomment)))
+
+
+(defun proof ()
+ ;; final row of the proof found in the most recent call on closure
+ ;; nil if no proof was found in the most recent call on closure
+ *proof*)
+
+(defun proofs ()
+ ;; final rows of all proofs
+ (rows :rowset *false-rows*))
+
+(defun answer (&optional term-to-lisp)
+ (and *proof* (if term-to-lisp (term-to-lisp (row-answer *proof*)) (row-answer *proof*))))
+
+(defun answers (&optional term-to-lisp)
+ (rows :rowset *false-rows* :collect (lambda (*proof*) (answer term-to-lisp))))
+
+(defun make-snark-system (&optional compile)
+ (cl-user::make-snark-system compile))
+
+#+cmu
+(defun save-snark-system (&key (name "snark-cmucl.core"))
+ (format t "~2%SNARK can be started by '~A -core ~A'" cl-user::*command-line-utility-name* name)
+ (format t "~2%")
+ (force-output)
+ (extensions:save-lisp name))
+
+#+sbcl
+(defun save-snark-system (&key executable (name (if executable
+ (if (member :x86-64 *features*) "snark-sbcl64" "snark-sbcl")
+ (if (member :x86-64 *features*) "snark-sbcl64.core" "snark-sbcl.core"))))
+ (cond
+ (executable
+ (format t "~2%SNARK can be started by '~A'" name)
+ (format t "~%followed by (in-package :snark-user)")
+ (format t "~2%")
+ (force-output)
+ (sb-ext:save-lisp-and-die name :executable t))
+ (t
+ (format t "~2%SNARK can be started by '~A --core ~A'" (first cl-user::*posix-argv*) name)
+ (format t "~%followed by (in-package :snark-user)")
+ (format t "~2%")
+ (force-output)
+ (sb-ext:save-lisp-and-die name))))
+
+#+(and ccl (not mcl))
+(defun save-snark-system (&key (name (if (member :x86-64 *features*) "snark-ccl64" "snark-ccl")))
+ (format t "~2%SNARK can be started by '~A'" name)
+ (format t "~%followed by (in-package :snark-user)")
+ (format t "~2%")
+ (force-output)
+ (ccl:save-application name :prepend-kernel t))
+
+#+allegro
+(defun save-snark-system (&key (name "snark-acl.dxl"))
+ (format t "~2%SNARK can be started by '~A -I ~A'" (sys:command-line-argument 0) name)
+ (format t "~%followed by (in-package :snark-user)")
+ (format t "~2%")
+ (force-output)
+ (cl-user::dumplisp :name name)
+ (quit))
+
+#+clisp
+(defun save-snark-system (&key (name "snark-lispinit.mem"))
+ (format t "~2%SNARK can be started by '~A -M ~A'" "clisp" name)
+ (format t "~2%")
+ (force-output)
+ (ext:saveinitmem name)
+ (quit))
+
+;;; wffs are stored with variables in block 0
+;;; these are used directly for demodulation and subsumption
+;;; given wff is renumbered to have variables in block 1
+;;; additional inference operation inputs are renumbered to have variables in block 2, 3, ...
+;;; result of inference operation will have variables in blocks 1, 2, 3, ... (but not 0)
+;;; and possibly "temporary" variables as well
+
+;;; main.lisp EOF
diff --git a/snark-20120808r02/src/map-file.abcl b/snark-20120808r02/src/map-file.abcl
new file mode 100644
index 0000000..b664969
Binary files /dev/null and b/snark-20120808r02/src/map-file.abcl differ
diff --git a/snark-20120808r02/src/map-file.lisp b/snark-20120808r02/src/map-file.lisp
new file mode 100644
index 0000000..128b295
--- /dev/null
+++ b/snark-20120808r02/src/map-file.lisp
@@ -0,0 +1,85 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
+;;; File: map-file.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-lisp)
+
+(defun mapnconc-file-forms (function filespec &key (if-does-not-exist :error) (package *package*))
+ ;; apply function to each form in file and return the result of nconc'ing the values
+ (with-open-file (stream filespec :direction :input :if-does-not-exist if-does-not-exist)
+ (when stream
+ (mapnconc-stream-forms function stream :package package))))
+
+(defun mapnconc-file-lines (function filespec &key (if-does-not-exist :error) (package *package*))
+ ;; apply function to each line in file and return the result of nconc'ing the values
+ (with-open-file (stream filespec :direction :input :if-does-not-exist if-does-not-exist)
+ (when stream
+ (mapnconc-stream-lines function stream :package package))))
+
+(defun mapnconc-stream-forms (function stream &key (package *package*))
+ ;; apply function to each form in stream and return the result of nconc'ing the values
+ (prog->
+ (find-or-make-package package -> *package*)
+ (mapnconc-stream0 stream #'read ->* form)
+ (cond
+ ((and (consp form) (eq 'in-package (first form)))
+ (eval form)
+ nil)
+ ((or (null function) (eq 'list function) (eq #'list function))
+ (list form))
+ (t
+ (funcall function form)))))
+
+(defun mapnconc-stream-lines (function stream &key (package *package*))
+ ;; apply function to each line in stream and return the result of nconc'ing the values
+ (prog->
+ (find-or-make-package package -> *package*)
+ (mapnconc-stream0 stream #'read-line ->* line)
+ (cond
+ ((or (null function) (eq 'list function) (eq #'list function))
+ (list line))
+ (t
+ (funcall function line)))))
+
+(defun mapnconc-stream0 (function stream read-function)
+ (let ((eof (cons nil nil))
+ (result nil) result-last)
+ (loop
+ (let ((x (funcall read-function stream nil eof)))
+ (if (eq eof x)
+ (return result)
+ (ncollect (funcall function x) result))))))
+
+(defun read-file (filespec &rest mapnconc-file-forms-options)
+ (declare (dynamic-extent mapnconc-file-forms-options))
+ (apply #'mapnconc-file-forms nil filespec mapnconc-file-forms-options))
+
+(defun read-file-lines (filespec &rest mapnconc-file-lines-options)
+ (declare (dynamic-extent mapnconc-file-lines-options))
+ (apply #'mapnconc-file-lines nil filespec mapnconc-file-lines-options))
+
+(defun read-file-to-string (filespec &key (if-does-not-exist :error))
+ (with-open-file (stream filespec :direction :input :if-does-not-exist if-does-not-exist)
+ (with-output-to-string (string)
+ (loop
+ (let ((ch (read-char stream nil :eof)))
+ (if (eq :eof ch)
+ (return string)
+ (write-char ch string)))))))
+
+;;; map-file.lisp EOF
diff --git a/snark-20120808r02/src/multiset-ordering.abcl b/snark-20120808r02/src/multiset-ordering.abcl
new file mode 100644
index 0000000..5aed182
Binary files /dev/null and b/snark-20120808r02/src/multiset-ordering.abcl differ
diff --git a/snark-20120808r02/src/multiset-ordering.lisp b/snark-20120808r02/src/multiset-ordering.lisp
new file mode 100644
index 0000000..87a257e
--- /dev/null
+++ b/snark-20120808r02/src/multiset-ordering.lisp
@@ -0,0 +1,349 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: multiset-ordering.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; comparison function should return >, <, =, or ?
+;;;
+;;; if testval is non-nil, it should be one of >, <, or =,
+;;; (eq testval (compare ... testval)) is true
+;;; iff
+;;; (eq testval (compare ...))) is true,
+;;; but faster
+
+(defun compare-multisets (compare list1 list2 &optional testval)
+ (let ((eql-alist nil))
+ (dolist (x list1)
+ (setf eql-alist (acons+ x 1 eql-alist)))
+ (dolist (y list2)
+ (setf eql-alist (acons+ y -1 eql-alist)))
+ (cond
+ ((alist-notany-minusp eql-alist)
+ (if (alist-notany-plusp eql-alist) '= '>))
+ ((alist-notany-plusp eql-alist)
+ '<)
+ (t
+ (let ((alist nil))
+ (flet ((equal0 (x y) (eq '= (funcall compare x y '=))))
+ (declare (dynamic-extent #'equal0))
+ (dolist (x eql-alist)
+ (setf alist (acons+ (car x) (cdr x) alist :test #'equal0))))
+ (cond
+ ((alist-notany-minusp alist)
+ (if (alist-notany-plusp alist) '= '>))
+ ((alist-notany-plusp alist)
+ '<)
+ ((and (or (null testval) (eq '> testval))
+ (dolist (y alist t)
+ (declare (type cons y))
+ (when (minusp (cdr y))
+ (unless (dolist (x alist nil)
+ (declare (type cons x))
+ (when (plusp (cdr x))
+ (if (or testval (not (test-option39?)))
+ (when (eq '> (funcall compare (car x) (car y) '>))
+ (return t))
+ (case (funcall compare (car x) (car y))
+ (>
+ (return t))
+ (<
+ (setf (cdr x) 0))))))
+ (return nil)))))
+ '>)
+ ((and (or (null testval) (eq '< testval))
+ (dolist (x alist t)
+ (declare (type cons x))
+ (when (plusp (cdr x))
+ (unless (dolist (y alist nil)
+ (declare (type cons y))
+ (when (minusp (cdr y))
+ (when (eq '< (funcall compare (car x) (car y) '<))
+ (return t))))
+ (return nil)))))
+ '<)
+ (t
+ (if (null testval) '? nil))))))))
+
+(defun compare-term-multisets (compare xargs yargs &optional subst testval)
+
+ ;; first, strip off initial eql arguments
+ (loop
+ (cond
+ ((null xargs)
+ (return-from compare-term-multisets (if (null yargs) '= '<)))
+ ((null yargs)
+ (return-from compare-term-multisets '>))
+ ((eql (first xargs) (first yargs))
+ (setf xargs (rest xargs))
+ (setf yargs (rest yargs)))
+ (t
+ (return))))
+
+ ;; quick comparison of singleton multisets
+ (cond
+ ((null (rest xargs))
+ (cond
+ ((null (rest yargs))
+ (return-from compare-term-multisets (funcall compare (first xargs) (first yargs) subst testval)))
+ ((member (first xargs) yargs)
+ (return-from compare-term-multisets '<))))
+ ((null (rest yargs))
+ (cond
+ ((member (first yargs) xargs)
+ (return-from compare-term-multisets '>)))))
+
+ (let ((variable-counts nil) (constant-counts nil) (compound-counts nil)
+ (xargs-compound-exists nil) (yargs-compound-exists nil)
+ (xargs-remain nil) (yargs-remain nil) term)
+
+ ;; destructively updates lists of
+ ;; variable and count pairs,
+ ;; constant and count pairs, and
+ ;; compound and count paris
+ ;; term and count pair is represented as (term . count)
+ (let (v) ;count variables and constants in xargs
+ (dolist (term xargs)
+ (dereference
+ term subst
+ :if-compound (setf xargs-compound-exists t)
+ :if-variable (cond
+ ((null variable-counts)
+ (setf variable-counts (cons (make-tc term 1) nil)))
+ ((setf v (assoc/eq term variable-counts))
+ (incf (tc-count v)))
+ (t
+ (push (make-tc term 1) variable-counts)))
+ :if-constant (cond
+ ((null constant-counts)
+ (setf constant-counts (cons (make-tc term 1) nil)))
+ ((setf v (assoc term constant-counts))
+ (incf (tc-count v)))
+ (t
+ (push (make-tc term 1) constant-counts))))))
+
+ (let (v) ;count variables and constants in yargs
+ (dolist (term yargs)
+ (dereference
+ term subst
+ :if-compound (setf yargs-compound-exists t)
+ :if-variable (cond
+ ((null variable-counts)
+ (if (eq '= testval)
+ (return-from compare-term-multisets nil)
+ (setf variable-counts (cons (make-tc term -1) nil))))
+ ((setf v (assoc/eq term variable-counts))
+ (if (and (eq '= testval) (eql 0 (tc-count v)))
+ (return-from compare-term-multisets nil)
+ (decf (tc-count v))))
+ (t
+ (if (eq '= testval)
+ (return-from compare-term-multisets nil)
+ (push (make-tc term -1) variable-counts))))
+ :if-constant (cond
+ ((null constant-counts)
+ (if (eq '= testval)
+ (return-from compare-term-multisets nil)
+ (setf constant-counts (cons (make-tc term -1) nil))))
+ ((setf v (assoc term constant-counts))
+ (if (and (eq '= testval) (eql 0 (tc-count v)))
+ (return-from compare-term-multisets nil)
+ (decf (tc-count v))))
+ (t
+ (if (eq '= testval)
+ (return-from compare-term-multisets nil)
+ (push (make-tc term -1) constant-counts)))))))
+
+ (when (eq '= testval)
+ (dolist (v constant-counts)
+ (unless (eql 0 (tc-count v))
+ (return-from compare-term-multisets nil)))
+ (dolist (v variable-counts)
+ (unless (eql 0 (tc-count v))
+ (return-from compare-term-multisets nil)))
+ (cond
+ ((not xargs-compound-exists)
+ (return-from compare-term-multisets (if yargs-compound-exists nil '=)))
+ ((not yargs-compound-exists)
+ (return-from compare-term-multisets nil))))
+
+ (when (or xargs-compound-exists yargs-compound-exists)
+ (flet ((equal0 (x y) (eq '= (funcall compare x y subst '=))))
+ (declare (dynamic-extent #'equal0))
+
+ (when xargs-compound-exists
+ (let (v) ;count compounds in xargs
+ (dolist (term xargs)
+ (dereference
+ term subst
+ :if-compound (cond
+ ((null compound-counts)
+ (setf compound-counts (cons (make-tc term 1) nil)))
+ ((setf v (or (assoc/eq term compound-counts)
+ (assoc term compound-counts :test #'equal0)))
+ (incf (tc-count v)))
+ (t
+ (push (make-tc term 1) compound-counts)))))))
+
+ (when yargs-compound-exists
+ (let (v) ;count compounds in yargs
+ (dolist (term yargs)
+ (dereference
+ term subst
+ :if-compound (cond
+ ((null compound-counts)
+ (if (eq '= testval)
+ (return-from compare-term-multisets nil)
+ (setf compound-counts (cons (make-tc term -1) nil))))
+ ((setf v (or (assoc/eq term compound-counts)
+ (assoc term compound-counts :test #'equal0)))
+ (if (and (eq '= testval) (eql 0 (tc-count v)))
+ (return-from compare-term-multisets nil)
+ (decf (tc-count v))))
+ (t
+ (if (eq '= testval)
+ (return-from compare-term-multisets nil)
+ (push (make-tc term -1) compound-counts))))))))))
+
+ (when (eq '= testval)
+ (dolist (v compound-counts)
+ (unless (eql 0 (tc-count v))
+ (return-from compare-term-multisets nil)))
+ (return-from compare-term-multisets '=))
+
+ (dolist (x variable-counts)
+ (when (plusp (tc-count x))
+ (setf term (tc-term x))
+ (or (dolist (y compound-counts nil)
+ (when (minusp (tc-count y))
+ (when (eq '> (funcall compare (tc-term y) term subst '>))
+ (setf (tc-count x) 0)
+ (return t))))
+ (cond ;uneliminated xarg variable
+ ((and testval (neq '> testval))
+ (return-from compare-term-multisets nil))
+ (t
+ (setf xargs-remain t))))))
+
+ (dolist (y variable-counts)
+ (when (minusp (tc-count y))
+ (setf term (tc-term y))
+ (or (dolist (x compound-counts nil)
+ (when (plusp (tc-count x))
+ (when (eq '> (funcall compare (tc-term x) term subst '>))
+ (setf (tc-count y) 0)
+ (return t))))
+ (cond ;uneliminated yarg variable
+ ((and testval (neq '< testval))
+ (return-from compare-term-multisets nil))
+ (xargs-remain
+ (return-from compare-term-multisets '?))
+ (t
+ (setf yargs-remain t))))))
+
+ (dolist (x constant-counts)
+ (when (plusp (tc-count x))
+ (setf term (tc-term x))
+ (dolist (y constant-counts nil)
+ (when (minusp (tc-count y))
+ (ecase (symbol-ordering-compare term (tc-term y))
+ (<
+ (setf (tc-count x) 0)
+ (return t))
+ (>
+ (setf (tc-count y) 0))
+ (?
+ ))))))
+
+ (dolist (x constant-counts)
+ (when (plusp (tc-count x))
+ (setf term (tc-term x))
+ (or (dolist (y compound-counts nil)
+ (when (minusp (tc-count y))
+ (ecase (funcall compare (tc-term y) term subst nil)
+ (>
+ (setf (tc-count x) 0)
+ (return t))
+ (<
+ (setf (tc-count y) 0))
+ (?
+ ))))
+ (cond ;uneliminated xarg constant
+ ((and testval (neq '> testval))
+ (return-from compare-term-multisets nil))
+ (yargs-remain
+ (return-from compare-term-multisets '?))
+ (t
+ (setf xargs-remain t))))))
+
+ (dolist (y constant-counts)
+ (when (minusp (tc-count y))
+ (setf term (tc-term y))
+ (or (dolist (x compound-counts nil)
+ (when (plusp (tc-count x))
+ (ecase (funcall compare (tc-term x) term subst nil)
+ (>
+ (setf (tc-count y) 0)
+ (return t))
+ (<
+ (setf (tc-count x) 0))
+ (?
+ ))))
+ (cond ;uneliminated yarg constant
+ ((and testval (neq '< testval))
+ (return-from compare-term-multisets nil))
+ (xargs-remain
+ (return-from compare-term-multisets '?))
+ (t
+ (setf yargs-remain t))))))
+
+ (dolist (x compound-counts)
+ (when (plusp (tc-count x))
+ (setf term (tc-term x))
+ (or (dolist (y compound-counts nil)
+ (when (minusp (tc-count y))
+ (ecase (funcall compare term (tc-term y) subst nil)
+ (<
+ (setf (tc-count x) 0)
+ (return t))
+ (>
+ (setf (tc-count y) 0))
+ (?
+ ))))
+ (cond ;uneliminated xarg compound
+ ((and testval (neq '> testval))
+ (return-from compare-term-multisets nil))
+ (yargs-remain
+ (return-from compare-term-multisets '?))
+ (t
+ (setf xargs-remain t))))))
+
+ ;;(cl:assert (not (and xargs-remain yargs-remain)))
+ (cond
+ (yargs-remain
+ '<)
+ ((dolist (y compound-counts nil)
+ (when (minusp (tc-count y))
+ (return t))) ;uneliminated yarg compound
+ (if xargs-remain '? '<))
+ (xargs-remain
+ '>)
+ (t
+ '=))))
+
+;;; multiset-ordering.lisp EOF
diff --git a/snark-20120808r02/src/mvlet.abcl b/snark-20120808r02/src/mvlet.abcl
new file mode 100644
index 0000000..b3a064d
Binary files /dev/null and b/snark-20120808r02/src/mvlet.abcl differ
diff --git a/snark-20120808r02/src/mvlet.lisp b/snark-20120808r02/src/mvlet.lisp
new file mode 100644
index 0000000..3e9d3c3
--- /dev/null
+++ b/snark-20120808r02/src/mvlet.lisp
@@ -0,0 +1,251 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
+;;; File: mvlet.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-lisp)
+
+;;; MVLET and MVLET* are extensions of LET and LET*
+;;; that add to the list of binding forms
+;;; the forms ((values var1 var2 var*) [init-form])
+;;; ((list var1 var2 var*) [init-form])
+;;; ((list* var1 var2 var*) [init-form])
+;;; that does multiple-value-binding and list destructuring
+;;; extra values in init-form are ignored; missing ones are replaced by nil
+;;; note that allowing fewer than two variables isn't really useful
+;;;
+;;; the troublesome part:
+;;; declarations at the beginning of the body
+;;; are decoded and placed in the proper locations
+;;; in the expansion
+;;;
+;;; stickel@ai.sri.com 1999-08-09
+
+(defmacro mvlet (bindings &body body)
+ (mvlet-expansion bindings body nil))
+
+(defmacro mvlet* (bindings &body body)
+ (mvlet-expansion bindings body :none))
+
+(defun binding-p (x)
+ ;; var
+ ;; (var [init-form])
+ ;; ((values var1 var2 var*) [init-form])
+ ;; ((list var1 var2 var*) [init-form])
+ ;; ((list* var1 var2 var*) [init-form])
+ (or (symbolp x)
+ (and (consp x)
+ (listp (cdr x))
+ (null (cddr x))
+ (if (consp (car x))
+ (case (caar x)
+ ((values list list* :values :list :list*)
+ (do ((l (cdar x) (cdr l))
+ (n 0 (+ n 1)))
+ ((atom l)
+ (and (null l) (<= 2 n)))
+ (unless (symbolp (car l))
+ (return nil)))))
+ (symbolp (car x))))))
+
+(defun list-bindings (vars form &optional list*)
+ ;; (list-bindings '(a b c d) 'foo nil) -> ((v foo) (a (pop v)) (b (pop v)) (c (first v)) (d (second v)))
+ ;; (list-bindings '(a b c d) 'foo t) -> ((v foo) (a (pop v)) (b (pop v)) (c (first v)) (d (rest v)))
+ (let ((vars (reverse vars))
+ (v (gensym)))
+ (do ((l (cddr vars) (cdr l))
+ (l2 (list `(,(second vars) (first ,v))
+ `(,(first vars) ,(if list* `(rest ,v) `(second ,v))))
+ (cons `(,(first l) (pop ,v)) l2)))
+ ((null l)
+ (cons `(,v ,form) l2)))))
+
+(defun mvlet-expansion (bindings body subst)
+ (cond
+ ((null bindings)
+ `(let () ,@body))
+ (t
+ (dolist (b bindings)
+ (unless (binding-p b)
+ (error "~S is not a proper binding." b)))
+ (multiple-value-bind (decl-specs body) (extract-declaration-specifiers body)
+ (first (expand-mvlet bindings decl-specs body subst))))))
+
+(defun expand-mvlet (bindings decl-specs body subst)
+ (let (v)
+ (cond
+ ((null bindings)
+ (let ((result body))
+ (when decl-specs
+ (setf result `((declare ,@decl-specs) ,@result)))
+ (when (consp subst)
+ (setf result `((let ,(reverse subst) ,@result))))
+ result))
+
+ ;; var or (var constant)
+ ((or (symbolp (setf v (car bindings)))
+ (and (symbolp (setf v (caar bindings)))
+ (constantp (cadar bindings))))
+ (let ((val (if (consp (car bindings)) (cadar bindings) nil)))
+ (if (and (listp subst) (rest bindings))
+ (expand-mvlet (rest bindings) decl-specs body (cons (list v val) subst))
+ `((let ((,v ,val))
+ ,@(expand-mvlet1 (rest bindings) decl-specs body subst v))))))
+
+ ;; (var init-form)
+ ((symbolp v)
+ (when (and (listp subst) (rest bindings))
+ (push (list v (setf v (make-symbol (symbol-name v)))) subst))
+ `((let ((,v ,(cadar bindings)))
+ ,@(expand-mvlet1 (rest bindings) decl-specs body subst v))))
+
+ ;; ((values var1 var2 var*) [init-form])
+ ((member (first (setf v (caar bindings))) '(values :values))
+ (setf v (rest v))
+ (when (and (listp subst) (rest bindings))
+ (setf v (mapcar
+ #'(lambda (v1)
+ (push (list v1 (setf v1 (make-symbol (symbol-name v1)))) subst)
+ v1)
+ v)))
+ `((multiple-value-bind ,v ,(cadar bindings)
+ ,@(expand-mvlet1 (rest bindings) decl-specs body subst v))))
+
+ ;; ((list var1 var2 var*) [init-form])
+ ;; ((list* var1 var2 var*) [init-form])
+ ((member (first v) '(list list* :list :list*))
+ (let ((b (list-bindings (rest v) (cadar bindings) (member (first v) '(list* :list*)))))
+ `((let (,(first b))
+ ,@(expand-mvlet (append (rest b) (rest bindings)) decl-specs body subst))))))))
+
+(defun expand-mvlet1 (bindings decl-specs body subst v)
+ (multiple-value-bind (l1 l2) (filter-declaration-specifiers decl-specs v subst)
+ (if (null l1)
+ (expand-mvlet bindings l2 body subst)
+ (cons `(declare ,@l1) (expand-mvlet bindings l2 body subst)))))
+
+(defun type-symbol-p (x)
+ ;; is X a symbol that names a type?
+ (and (symbolp x)
+ (handler-case
+ (progn (typep nil x) t) ;is there a better way?
+ (error () nil))))
+
+(defun extract-declaration-specifiers (body)
+ ;; returns declaration-specifiers of declarations at beginning of body
+ ;; (declare (fixnum x y)) -> ((type fixnum x) (type fixnum y)) etc.
+ ;; declaration-specifier syntax
+ ;; relevant to mvlet
+ ;; (dynamic-extent [[var* | (function fn)*]])
+ ;; (ignorable {var | (function fn)}*) (1)
+ ;; (ignore {var | (function fn)}*)
+ ;; (special var*)
+ ;; (type typespec var*)
+ ;; (a-symbol-which-is-the-name-of-a-type var*)
+ ;; irrelevant to mvlet?
+ ;; (declaration name*)
+ ;; (ftype type function-name*)
+ ;; (function ???)
+ ;; (inline function-name*)
+ ;; (notinline function-name*)
+ ;; (optimize ???)
+ ;; (a-symbol-declared-to-be-a-declaration-identifier ???)
+ ;; (1) fix CLHS glossary: add IGNORABLE to list of declaration identifiers
+ (let ((decl-specs nil) form)
+ (loop
+ (cond
+ ((and body (consp (setf form (first body))) (eq 'declare (first form)))
+ (dolist (decl-spec (rest form))
+ (let ((decl-id (first decl-spec)))
+ (case decl-id
+ ((dynamic-extent ignorable ignore special)
+ (dolist (v (rest decl-spec))
+ (push `(,decl-id ,v) decl-specs)))
+ (type
+ (let ((type (second decl-spec)))
+ (dolist (v (rest (rest decl-spec)))
+ (push `(,decl-id ,type ,v) decl-specs))))
+ (otherwise
+ (if (type-symbol-p decl-id)
+ (dolist (v (rest decl-spec))
+ (push `(type ,decl-id ,v) decl-specs))
+ (push decl-spec decl-specs))))))
+ (setf body (rest body)))
+ (t
+ (return (values (nreverse decl-specs) body)))))))
+
+(defun filter-declaration-specifiers (decl-specs v subst)
+ ;; returns (values l1 l2) where
+ ;; l1 are declaration specifiers in decl-specs that concern
+ ;; variable or variables v and
+ ;; l2 are declaration specifiers in decl-specs that don't
+ (if (null decl-specs)
+ (values nil nil)
+ (let ((d (first decl-specs))
+ (r (rest decl-specs)))
+ (multiple-value-bind (l1 l2) (filter-declaration-specifiers r v subst)
+ (if (case (first d)
+ ((dynamic-extent ignorable ignore special)
+ (if (consp v) (member (second d) v) (eq (second d) v)))
+ (type
+ (if (consp v) (member (third d) v) (eq (third d) v))))
+ (setf l1 (if (eq l1 r) decl-specs (cons d l1)))
+ (setf l2 (if (eq l2 r) decl-specs (cons d l2))))
+ ;; also add to l1 some declarations for temporary variables
+ ;; that variable or variables v will be bound to
+ (when (consp subst)
+ (case (first d)
+ (dynamic-extent
+ (let ((x (second (assoc (second d) subst))))
+ (when (and x (if (consp v) (member x v) (eq x v)))
+ (push `(,(first d) ,x) l1))))
+ (type
+ (let ((x (second (assoc (third d) subst))))
+ (when (and x (if (consp v) (member x v) (eq x v)))
+ (push `(,(first d) ,(second d) ,x) l1))))))
+ (values l1 l2)))))
+
+(defun mvlet-test1 ()
+ (let ((form '(mvlet* ((u (foo))
+ (v 13)
+ ((values w x) (bar))
+ (y (baz)))
+ (declare (fixnum v x) (special y w))
+ (declare (dynamic-extent x))
+ (list u v w x y)))
+ (*print-pretty* t))
+ (print (macroexpand-1 (print form)))
+ (terpri)
+ (print (macroexpand-1 (print (cons 'mvlet (rest form)))))
+ nil))
+
+(defun mvlet-test2 ()
+ (let ((form '(mvlet (((values a1 a2 a3) (foo))
+ ((list b1 b2 b3) (bar))
+ ((list* c1 c2 c3) (baz)))
+ (list a1 a2 a3 b1 b2 b3 c1 c2 c3)))
+ (*print-pretty* t))
+ (print (macroexpand-1 (print form)))
+ nil))
+
+#+(and mcl (not openmcl))
+(progn
+ (pushnew '(mvlet . 1) ccl:*fred-special-indent-alist* :test #'equal)
+ (pushnew '(mvlet* . 1) ccl:*fred-special-indent-alist* :test #'equal)
+ nil)
+
+;;; mvlet.lisp EOF
diff --git a/snark-20120808r02/src/nonhorn-magic-set.abcl b/snark-20120808r02/src/nonhorn-magic-set.abcl
new file mode 100644
index 0000000..cab9bd5
Binary files /dev/null and b/snark-20120808r02/src/nonhorn-magic-set.abcl differ
diff --git a/snark-20120808r02/src/nonhorn-magic-set.lisp b/snark-20120808r02/src/nonhorn-magic-set.lisp
new file mode 100644
index 0000000..f4c1fac
--- /dev/null
+++ b/snark-20120808r02/src/nonhorn-magic-set.lisp
@@ -0,0 +1,131 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: nonhorn-magic-set.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun make-magic-goal-atom (atom)
+ (flet ((magic-goal-name (name)
+ (intern (to-string :goal_ name) :snark-user)))
+ (dereference
+ atom nil
+ :if-constant (let ((v (constant-magic atom)))
+ (if (or (null v) (eq 'goal v))
+ true
+ (if (eq t v)
+ (setf (constant-magic atom)
+ (declare-proposition
+ (magic-goal-name atom)
+ :magic 'goal))
+ v)))
+ :if-compound (let* ((head (head atom))
+ (v (function-magic head)))
+ (if (or (null v) (eq 'goal v))
+ true
+ (make-compound* (if (eq t v)
+ (setf (function-magic head)
+ (declare-relation
+ (magic-goal-name (function-name head))
+ (function-arity head)
+ :commutative (function-commutative head)
+ :magic 'goal))
+ v)
+ (args atom)))))))
+
+(defun magic-transform-clause (cc clause &key (transform-negative-clauses t) (transform-positive-units nil))
+ ;; {d} yields
+ ;; {d} if transform-positive-units is false
+ ;; or
+ ;; {~goal_d, d} if transform-positive-units is true
+ ;; {d, e, f} yields
+ ;; {~goal_d, ~goal_e, ~goal_f, d, e, f}
+ ;; {~a} yields
+ ;; {goal_a} if transform-negative-clauses is true
+ ;; and
+ ;; {~a}
+ ;; {~a, ~b, ~c} yields
+ ;; {goal_a} if transform-negative-clauses is true
+ ;; and
+ ;; {~a, goal_b} if transform-negative-clauses is true
+ ;; and
+ ;; {~a, ~b, goal_c} if transform-negative-clauses is true
+ ;; and
+ ;; {~a, ~b, ~c}
+ ;; {~a, ~b, ~c, d, e, f} yields
+ ;; {~goal_d, ~goal_e, ~goal_f, goal_a}
+ ;; and
+ ;; {~goal_d, ~goal_e, ~goal_f, ~a, goal_b}
+ ;; and
+ ;; {~goal_d, ~goal_e, ~goal_f, ~a, ~b, goal_c}
+ ;; and
+ ;; {~goal_d, ~goal_e, ~goal_f, ~a, ~b, ~c, d, e, f}
+ (let ((posatoms nil) posatoms-last
+ (negatoms nil) negatoms-last)
+ (prog->
+ (map-atoms-in-clause clause ->* atom polarity)
+ (if (eq :pos polarity) (collect atom posatoms) (collect atom negatoms)))
+ (cl:assert (not (and (null posatoms) (null negatoms))))
+ (let ((l nil) l-last)
+ (dolist (atom posatoms)
+ (collect (negate (make-magic-goal-atom atom)) l))
+ (dolist (atom negatoms)
+ (unless (and (null posatoms) (not transform-negative-clauses))
+ (funcall cc (disjoin* (append l (list (make-magic-goal-atom atom))))))
+ (collect (negate atom) l))
+ (cond
+ ((and (null negatoms) (null (rest posatoms)) (not transform-positive-units))
+ (funcall cc (first posatoms)))
+ (t
+ (funcall cc (disjoin* (append l posatoms)))))))
+ nil)
+
+(defun magic-transform-wff (wff &key (transform-negative-clauses t) (transform-positive-units nil))
+ ;; for use only if wff is a clause or conjunction of clauses
+ ;; magic-transform-wff is idempotent
+ (if (or (eq true wff) (eq false wff))
+ wff
+ (let ((clauses nil) clauses-last)
+ (prog->
+ (map-conjuncts wff ->* clause)
+ (magic-transform-clause
+ clause
+ :transform-negative-clauses transform-negative-clauses
+ :transform-positive-units transform-positive-units
+ ->* clause)
+ (collect clause clauses))
+ (conjoin* clauses))))
+
+(defun proposition-magic-goal-p (prop)
+ (eq 'goal (constant-magic prop)))
+
+(defun relation-magic-goal-p (rel)
+ (eq 'goal (function-magic rel)))
+
+(defun magic-goal-atom-p (atom)
+ (dereference
+ atom nil
+ :if-constant (proposition-magic-goal-p atom)
+ :if-compound (relation-magic-goal-p (head atom))))
+
+(defun magic-goal-occurs-p (wff)
+ (prog->
+ (map-atoms-in-wff wff ->* atom polarity)
+ (when (and (eq :pos polarity) (magic-goal-atom-p atom))
+ (return-from prog-> t))))
+
+;;; nonhorn-magic-set.lisp EOF
diff --git a/snark-20120808r02/src/numbering-system.lisp b/snark-20120808r02/src/numbering-system.lisp
new file mode 100644
index 0000000..4249f4c
--- /dev/null
+++ b/snark-20120808r02/src/numbering-system.lisp
@@ -0,0 +1,32 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
+;;; File: numbering-system.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :common-lisp-user)
+
+(defpackage :snark-numbering
+ (:use :common-lisp :snark-lisp :snark-sparse-array)
+ (:export
+ #:nonce
+ #:initialize-numberings #:make-numbering
+ #:*standard-eql-numbering*
+ ))
+
+(loads "numbering")
+
+;;; numbering-system.lisp EOF
diff --git a/snark-20120808r02/src/numbering.abcl b/snark-20120808r02/src/numbering.abcl
new file mode 100644
index 0000000..873e4b4
Binary files /dev/null and b/snark-20120808r02/src/numbering.abcl differ
diff --git a/snark-20120808r02/src/numbering.lisp b/snark-20120808r02/src/numbering.lisp
new file mode 100644
index 0000000..2eff933
--- /dev/null
+++ b/snark-20120808r02/src/numbering.lisp
@@ -0,0 +1,82 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-numbering -*-
+;;; File: numbering.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-numbering)
+
+(defvar *nonce* 0)
+(declaim (type integer *nonce*))
+(defvar *standard-eql-numbering*)
+
+(definline nonce ()
+ ;; each call returns a new positive value in ascending order
+ (incf *nonce*))
+
+(defun initialize-numberings ()
+ (setf *nonce* 0)
+ (setf *standard-eql-numbering* (make-numbering :test #'eql))
+ nil)
+
+(defun make-numbering (&key (test #'eql) (inverse t))
+ ;; make-numbering returns a function f such that
+ ;; (f :lookup object) returns a unique number for object, adding one if necessary
+ ;; (f :lookup? object) returns the number for object or nil if there isn't one
+ ;; (f :delete object) deletes an object from the numbering
+ ;; (f :inverse number) returns an object by its number
+ ;; (f :map fn) applies binary function fn to each object and its number
+ (let ((table (make-hash-table :test test)))
+ (if inverse
+ (let ((invtable (make-sparse-vector :default-value '%absent%)))
+ (lambda (action arg)
+ (ecase action
+ (:lookup
+ (or (gethash arg table)
+ (let ((number (nonce)))
+ (setf (sparef invtable number) arg (gethash arg table) number))))
+ (:lookup?
+ (gethash arg table))
+ (:inverse
+ (let ((object (sparef invtable arg)))
+ (if (eq '%absent% object) (error "No object numbered ~D." arg) object)))
+ (:delete
+ (let ((number (gethash arg table)))
+ (when number
+ (setf (sparef invtable number) '%absent%)
+ (remhash arg table)
+ number)))
+ (:map
+ (map-sparse-vector-with-indexes arg invtable)))))
+ (lambda (action arg)
+ (ecase action
+ (:lookup
+ (or (gethash arg table)
+ (let ((number (nonce)))
+ (setf (gethash arg table) number))))
+ (:lookup?
+ (gethash arg table))
+ (:delete
+ (let ((number (gethash arg table)))
+ (when number
+ (remhash arg table)
+ number))))))))
+
+#+ignore
+(eval-when (:load-toplevel :execute)
+ (initialize-numberings))
+
+;;; numbering.lisp EOF
diff --git a/snark-20120808r02/src/options.abcl b/snark-20120808r02/src/options.abcl
new file mode 100644
index 0000000..35402bd
Binary files /dev/null and b/snark-20120808r02/src/options.abcl differ
diff --git a/snark-20120808r02/src/options.lisp b/snark-20120808r02/src/options.lisp
new file mode 100644
index 0000000..eabae51
--- /dev/null
+++ b/snark-20120808r02/src/options.lisp
@@ -0,0 +1,395 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: options.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(declaim (special *snark-globals* *agenda-of-rows-to-give* *agenda-of-rows-to-process*))
+
+(defvar *snark-options* nil)
+
+(defmacro declare-snark-option (name &optional (default-value nil) (invisible-value :always-print))
+ ;; example:
+ ;; (declare-snark-option USE-FOO t)
+ ;; yields the functions USE-FOO, DEFAULT-USE-FOO, USE-FOO?
+ ;;
+ ;; (USE-FOO value) sets the value of the USE-FOO option
+ ;; (USE-FOO) sets the value of the USE-FOO option to T
+ ;;
+ ;; (DEFAULT-USE-FOO value) sets the default value of the USE-FOO option
+ ;; (DEFAULT-USE-FOO) sets the default value of the USE-FOO option to T
+ ;;
+ ;; (USE-FOO?) returns the value of the USE-FOO option
+ ;; (DEFAULT-USE-FOO?) returns the default value of the USE-FOO option
+ ;;
+ ;; (initialize) will initialize options to their default values
+ ;;
+ ;; DEFAULT-USE-FOO should be used BEFORE initialize to establish a
+ ;; default value for foo for all future runs; USE-FOO should be used
+ ;; AFTER initialize to change the value of foo for an individual run
+ ;;
+ ;; (print-options) will print the value of each SNARK option
+ ;; whose value differs from its invisible value (:always-print
+ ;; or :never-print can be specified instead of an invisible value)
+ (cl:assert (or (symbolp name) (stringp name)))
+ (setf name (intern (string name) :snark))
+ (let ((snark-option-variable-name (intern (to-string "*%" name "%*") :snark))
+ (default-snark-option-variable-name (intern (to-string :*%default- name "%*") :snark))
+ (invisible-snark-option-variable-name (intern (to-string :*%invisible- name "%*") :snark))
+ (snark-option-access-function-name (intern (to-string name "?") :snark))
+ (default-snark-option-function-name (intern (to-string :default- name) :snark))
+ (default-snark-option-access-function-name (intern (to-string :default- name "?") :snark)))
+ `(progn
+ (unless (member ',name *snark-options*)
+ (setf *snark-options* (nconc *snark-options* (list ',name)))
+ (nconc *snark-globals*
+ (list ',snark-option-variable-name))
+ (nconc *snark-nonsave-globals*
+ (list ',default-snark-option-variable-name
+ ',invisible-snark-option-variable-name)))
+
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(,default-snark-option-access-function-name
+ ,default-snark-option-function-name
+ ,snark-option-access-function-name
+ ,name)
+ :snark))
+
+ (defparameter ,default-snark-option-variable-name ,default-value)
+
+ (defparameter ,invisible-snark-option-variable-name ,invisible-value)
+
+ (defvar ,snark-option-variable-name ,default-snark-option-variable-name)
+
+ (defun ,default-snark-option-access-function-name ()
+ ,default-snark-option-variable-name)
+
+ (defun ,default-snark-option-function-name (&optional (value t))
+ (setf ,default-snark-option-variable-name value)) ;affects only future runs
+
+ (definline ,snark-option-access-function-name ()
+ ,snark-option-variable-name)
+
+ (defgeneric ,name (&optional value)
+ (:method (&optional (value t))
+ (setf ,snark-option-variable-name value))))))
+
+(declare-snark-option variable-symbol-prefixes '(#\?) :never-print) ;use first for output, any for input
+
+(declare-snark-option use-resolution nil)
+(declare-snark-option use-hyperresolution nil)
+(declare-snark-option use-negative-hyperresolution nil)
+(declare-snark-option use-ur-resolution nil)
+(declare-snark-option use-ur-pttp nil)
+(declare-snark-option use-paramodulation nil)
+(declare-snark-option use-factoring nil)
+(declare-snark-option use-equality-factoring nil)
+(declare-snark-option use-condensing t)
+(declare-snark-option use-resolve-code nil) ;list of resolve-code functions
+
+(declare-snark-option use-unit-restriction nil)
+(declare-snark-option use-input-restriction nil)
+(declare-snark-option use-literal-ordering-with-resolution nil)
+(declare-snark-option use-literal-ordering-with-hyperresolution nil)
+(declare-snark-option use-literal-ordering-with-negative-hyperresolution nil)
+(declare-snark-option use-literal-ordering-with-ur-resolution nil)
+(declare-snark-option use-literal-ordering-with-paramodulation nil)
+
+(declare-snark-option use-subsumption t) ;nil, :forward, t
+(declare-snark-option use-subsumption-by-false :false) ;nil, :false, :forward, t
+(declare-snark-option use-lookahead-in-dpll-for-subsumption t t)
+(declare-snark-option use-simplification-by-units t) ;nil, :forward, t
+(declare-snark-option use-simplification-by-equalities t) ;nil, :forward, t
+(declare-snark-option use-term-ordering :rpo) ;nil, :manual, :kbo, :rpo, or a function
+(declare-snark-option use-term-ordering-cache nil nil)
+(declare-snark-option use-default-ordering t) ;nil, :arity, :reverse, t
+(declare-snark-option 1-ary-functions>2-ary-functions-in-default-ordering nil)
+(declare-snark-option ordering-functions>constants nil) ;t for speed, only if functions > constants always
+(declare-snark-option rpo-status :multiset) ;default status
+(declare-snark-option kbo-status :left-to-right) ;default status
+(declare-snark-option kbo-variable-weight 1 1) ;number or var->number function (so different sort variables can have different weights); constant-weight >= this > 0
+(declare-snark-option kbo-builtin-constant-weight 1 1) ;number or const->number function
+
+(declare-snark-option use-indefinite-answers nil) ;nil, :disjunctive, :conditional (UNIMPLEMENTED)
+(declare-snark-option use-conditional-answer-creation nil)
+(declare-snark-option use-constructive-answer-restriction nil :never-print) ;no longer necessary (use constant-allowed-in-answer and function-allowed-in-answer)
+(declare-snark-option use-answers-during-subsumption t :never-print) ;no longer necessary (always enabled)
+(declare-snark-option use-constraint-solver-in-subsumption nil)
+(declare-snark-option allow-skolem-symbols-in-answers t)
+(declare-snark-option rewrite-answers nil)
+(declare-snark-option rewrite-constraints t :never-print) ;nop
+(declare-snark-option use-constraint-purification nil) ;nil, t, 1, 2
+(declare-snark-option use-embedded-rewrites t t)
+(declare-snark-option use-function-creation nil)
+(declare-snark-option use-replacement-resolution-with-x=x nil)
+(declare-snark-option use-paramodulation-only-into-units nil)
+(declare-snark-option use-paramodulation-only-from-units nil)
+(declare-snark-option use-single-replacement-paramodulation nil)
+
+(declare-snark-option use-partitions nil nil) ;nil or list of partition ids
+(declare-snark-option partition-communication-table nil :never-print)
+
+(declare-snark-option declare-root-sort :top-sort-a :top-sort-a)
+(declare-snark-option declare-string-sort 'string 'string) ;string, :top-sort
+
+(declare-snark-option assert-context :root) ;:root, :current
+
+(declare-snark-option assert-supported t) ;nil, t :uninherited
+(declare-snark-option assume-supported t) ;nil, t, :uninherited
+(declare-snark-option prove-supported t) ;nil, t, :uninherited
+(declare-snark-option assert-sequential nil) ;nil, t, :uninherited
+(declare-snark-option assume-sequential nil) ;nil, t, :uninherited
+(declare-snark-option prove-sequential nil) ;nil, t, :uninherited
+
+(declare-snark-option prove-closure t :never-print)
+
+(declare-snark-option number-of-given-rows-limit nil)
+(declare-snark-option number-of-rows-limit nil)
+(declare-snark-option agenda-length-before-simplification-limit 10000)
+(declare-snark-option agenda-length-limit 3000)
+(declare-snark-option run-time-limit nil)
+(declare-snark-option row-argument-count-limit nil nil)
+(declare-snark-option row-weight-limit nil)
+(declare-snark-option row-weight-before-simplification-limit nil)
+(declare-snark-option level-pref-for-giving nil)
+(declare-snark-option variable-weight 1 1) ;number or var->number function (so different sort variables can have different weights)
+(declare-snark-option builtin-constant-weight 1 1) ;number or const->number function
+(declare-snark-option bag-weight-factorial nil nil)
+
+(declare-snark-option agenda-ordering-function 'row-priority)
+(declare-snark-option row-priority-size-factor 0 0)
+(declare-snark-option row-priority-weight-factor 1 1)
+(declare-snark-option row-priority-depth-factor 1 1)
+(declare-snark-option row-priority-level-factor 1 1)
+(declare-snark-option pruning-tests '(row-weight-limit-exceeded))
+(declare-snark-option pruning-tests-before-simplification '(row-weight-before-simplification-limit-exceeded))
+
+(declare-snark-option use-clausification t)
+(declare-snark-option use-equality-elimination nil) ;nil, t, or :unconstrained
+(declare-snark-option use-magic-transformation nil)
+(declare-snark-option use-ac-connectives t)
+(declare-snark-option use-purity-test nil)
+(declare-snark-option use-relevance-test nil)
+(declare-snark-option use-assertion-analysis t t)
+
+(declare-snark-option use-associative-unification nil nil) ;for declarations by assertion analysis
+(declare-snark-option use-associative-identity nil nil) ;for declarations by assertion analysis
+(declare-snark-option use-dp-subsumption nil nil)
+(declare-snark-option unify-bag-basis-size-limit 1000 1000)
+
+(declare-snark-option use-term-memory-deletion t t)
+
+(declare-snark-option variable-sort-marker #\. :never-print)
+
+(declare-snark-option use-variable-name-sorts nil :never-print) ;deprecated
+(declare-snark-option use-well-sorting nil :never-print) ;nil, t, or :terms
+(declare-snark-option use-extended-implications 'warn :never-print) ;nil, t, or warn
+(declare-snark-option use-extended-quantifiers 'warn :never-print) ;nil, t, or warn
+(declare-snark-option use-sort-relativization nil :never-print)
+(declare-snark-option use-quantifier-preservation nil :never-print)
+
+(declare-snark-option input-floats-as-ratios t :never-print) ;nop (always input floats as ratios)
+
+(declare-snark-option use-closure-when-satisfiable t :never-print)
+
+(declare-snark-option listen-for-commands nil :never-print)
+
+(declare-snark-option use-to-lisp-code t :never-print) ;turn off use of to-lisp-code
+(declare-snark-option variable-to-lisp-code nil :never-print)
+
+(declare-snark-option print-rows-when-given nil :never-print)
+(declare-snark-option print-rows-when-derived t :never-print)
+(declare-snark-option print-rows-when-processed nil :never-print)
+(declare-snark-option print-final-rows t :never-print) ;nil, t, :tptp, :tptp-too
+(declare-snark-option print-unorientable-rows t :never-print)
+(declare-snark-option print-pure-rows nil :never-print)
+(declare-snark-option print-irrelevant-rows nil :never-print)
+(declare-snark-option print-rewrite-orientation nil :never-print) ;1998-07-29
+
+(declare-snark-option print-rows-test nil :never-print)
+
+;;; the following options control how a row is printed
+(declare-snark-option print-rows-shortened nil :never-print)
+(declare-snark-option print-rows-prettily t :never-print)
+(declare-snark-option print-row-wffs-prettily t :never-print)
+(declare-snark-option print-row-answers t :never-print)
+(declare-snark-option print-row-constraints t :never-print)
+(declare-snark-option print-row-reasons t :never-print)
+(declare-snark-option print-row-goals t :never-print)
+(declare-snark-option print-row-partitions t :never-print)
+(declare-snark-option print-row-length-limit nil :never-print)
+(declare-snark-option print-given-row-lines-printing 2 :never-print)
+(declare-snark-option print-given-row-lines-signalling 1 :never-print)
+
+;;; the following options control what is printed when closure finishes
+(declare-snark-option print-summary-when-finished t :never-print)
+(declare-snark-option print-clocks-when-finished t :never-print)
+(declare-snark-option print-term-memory-when-finished t :never-print)
+(declare-snark-option print-agenda-when-finished t :never-print)
+(declare-snark-option print-rows-when-finished nil :never-print)
+
+(declare-snark-option print-options-when-starting t :never-print)
+(declare-snark-option print-assertion-analysis-notes t :never-print)
+(declare-snark-option print-symbol-table-warnings t :never-print)
+
+;;; the following options are for debugging
+(declare-snark-option print-time-used nil :never-print)
+(declare-snark-option trace-unify nil :never-print)
+(declare-snark-option meter-unify-bag nil :never-print) ;nil, t, or number of seconds
+(declare-snark-option trace-unify-bag-basis nil :never-print)
+(declare-snark-option trace-unify-bag-bindings nil :never-print)
+(declare-snark-option trace-dp-refute nil :never-print)
+(declare-snark-option trace-rewrite nil :never-print)
+(declare-snark-option trace-optimize-sparse-vector-expression nil :never-print)
+(declare-snark-option trace-dpll-subsumption nil :never-print) ;nil, :summary, :clauses
+
+(declare-snark-option changeable-properties-of-locked-constant '(:alias :allowed-in-answer :kbo-weight :weight) :never-print)
+(declare-snark-option changeable-properties-of-locked-function '(:alias :allowed-in-answer :kbo-weight :weight :weight-code :new-name) :never-print)
+
+(declare-snark-option test-option2 nil nil) ;simplification-ordering-compare-equality-arguments
+(declare-snark-option test-option3 nil nil) ;paramodulater for waldinger
+(declare-snark-option test-option6 nil nil) ;clausify
+(declare-snark-option test-option8 nil nil) ;unify-bag
+(declare-snark-option test-option9 nil nil) ;rewriting during hyperresolution
+(declare-snark-option test-option14 nil nil) ;sparse-vector-expressions for indexing
+(declare-snark-option test-option17 nil nil) ;revert to nonspecial unification for jepd relation atoms
+(declare-snark-option test-option18 nil nil) ;instance-graph - insert uses might-unify-p
+(declare-snark-option test-option19 nil nil) ;revert to earlier rpo
+(declare-snark-option test-option20 nil nil) ;rpo
+(declare-snark-option test-option21 nil nil) ;maximum-intersection-size in optimize-sparse-vector-expression
+(declare-snark-option test-option23 t t ) ;make skolem symbols bigger than nonskolems in default symbol ordering
+(declare-snark-option test-option29 nil nil) ;magic-transform-positive-units
+(declare-snark-option test-option30 nil nil) ;declare sort coercion functions like the-bird, the-integer
+(declare-snark-option test-option36 nil nil) ;nil or cutoff for number of unifiers for incomplete subsumption test
+(declare-snark-option test-option37 nil nil) ;nop (always use extended any-ary sum and product functions)
+(declare-snark-option test-option38 nil nil) ;turn off term hashing
+(declare-snark-option test-option39 nil nil) ;compare-multisets
+(declare-snark-option test-option40 nil nil) ;rpo-compare-multisets
+(declare-snark-option test-option41 nil nil) ;resolve with $$eq in constraints
+(declare-snark-option test-option42 nil nil) ;rewrite ($$less a b) to (not ($$lesseq b a)) and ($$lesseq a b) to (not ($$less b a))
+(declare-snark-option test-option43 nil nil) ;don't use do-not-resolve atoms for rewriting
+(declare-snark-option test-option44 nil nil) ;associative-identity-paramodulater generates only collapsed terms
+(declare-snark-option test-option45 nil nil) ;function-identity2 returns identity when subsuming as well as unifying
+(declare-snark-option test-option49 nil nil) ;don't use feature-vector-indexing minimum-depth features
+(declare-snark-option test-option50 nil nil) ;don't use feature-vector-indexing ground-literal features
+(declare-snark-option test-option51 nil nil) ;use feature-vector-indexing for term generalization retrievals
+(declare-snark-option test-option52 nil nil) ;use feature-vector-indexing for term instance retrievals
+(declare-snark-option test-option53 nil nil)
+(declare-snark-option test-option54 nil nil)
+(declare-snark-option test-option55 nil nil)
+(declare-snark-option test-option56 nil nil)
+(declare-snark-option test-option57 nil nil)
+(declare-snark-option test-option58 nil nil)
+(declare-snark-option test-option59 nil nil)
+(declare-snark-option test-option60 nil nil)
+
+(defvar options-have-been-critiqued)
+
+(defun initialize-options ()
+ (setf options-have-been-critiqued nil)
+ (dolist (name *snark-options*)
+ (setf (symbol-value (intern (to-string "*%" name "%*") :snark))
+ (symbol-value (intern (to-string :*%default- name "%*") :snark)))))
+
+(defun finalize-options ()
+ (dolist (name *snark-options*)
+ (funcall name (symbol-value (intern (to-string "*%" name "%*") :snark)))))
+
+(defun snark-option-spec-p (x)
+ ;; accepts print-rows-when-given, (print-rows-when-given), (print-rows-when-given nil)
+ ;; and default-print-rows-when-given etc.
+ (and (or (atom x) (and (listp (rest x)) (null (rrest x))))
+ (let ((name (if (atom x) x (first x))))
+ (and (symbolp name)
+ (or (member name *snark-options*)
+ (let ((s (symbol-name name)))
+ (and (<= 8 (length s))
+ (string= :default- s :end2 8)
+ (member s *snark-options* :test #'(lambda (x y) (string= x y :start1 8))))))))))
+
+(defun set-options (options)
+ (dolist (x options)
+ (if (snark-option-spec-p x)
+ (if (atom x) (funcall x t) (funcall (first x) (second x)))
+ (warn "~S is not a SNARK option setting." x))))
+
+(defmacro let-options (options &body forms)
+ (let ((bindings nil) (settings nil))
+ (dolist (x options)
+ (cond
+ ((snark-option-spec-p x)
+ (push (intern (to-string "*%" (if (atom x) x (first x)) "%*") :snark) bindings)
+ (push x settings))
+ (t
+ (warn "~S is not a SNARK option setting." x) ;treat it as an ordinary let binding
+ (push x bindings))))
+ `(let ,(nreverse bindings)
+ ,@(nreverse settings)
+ ,@forms)))
+
+#+(and mcl (not openmcl))
+(progn
+ (pushnew '(let-options . 1) ccl:*fred-special-indent-alist* :test #'equal)
+ nil)
+
+(defun print-options (&optional all)
+ (with-standard-io-syntax2
+ (format t "~&; The current SNARK option values are")
+ (dolist (name *snark-options*)
+ (let ((value
+ (symbol-value
+ (intern (to-string "*%" name "%*") :snark)))
+ (default-value
+ (symbol-value
+ (intern (to-string :*%default- name "%*") :snark)))
+ (invisible-value
+ (symbol-value
+ (intern (to-string :*%invisible- name "%*") :snark))))
+ (when (or all
+ (and (neq :never-print invisible-value)
+ (or (eq :always-print invisible-value)
+ (neq value invisible-value))))
+ (if (neql value default-value)
+ (format t "~%; (~A ~S)" name value)
+ (format t "~%; (~A ~S)" name value)))))
+ (format t "~%")
+ nil))
+
+(defmethod agenda-length-limit :before (&optional (value t))
+ (limit-agenda-length *agenda-of-rows-to-give* value))
+
+(defmethod agenda-length-before-simplification-limit :before (&optional (value t))
+ (limit-agenda-length *agenda-of-rows-to-process* value))
+
+(defmethod use-resolve-code :around (&optional (value nil))
+ (call-next-method
+ (if (listp value)
+ (remove-duplicates value :from-end t) ;replace
+ (cons value (remove value (use-resolve-code?)))))) ;add
+
+(defmethod use-term-ordering :around (&optional (value nil))
+ (call-next-method
+ (case value
+ (:recursive-path :rpo)
+ (:knuth-bendix :kbo)
+ (otherwise value))))
+
+(defmethod use-constraint-purification :around (&optional (value nil))
+ (call-next-method (if value 2 nil)))
+
+;;; options.lisp EOF
diff --git a/snark-20120808r02/src/output.abcl b/snark-20120808r02/src/output.abcl
new file mode 100644
index 0000000..9e35144
Binary files /dev/null and b/snark-20120808r02/src/output.abcl differ
diff --git a/snark-20120808r02/src/output.lisp b/snark-20120808r02/src/output.lisp
new file mode 100644
index 0000000..1a5062f
--- /dev/null
+++ b/snark-20120808r02/src/output.lisp
@@ -0,0 +1,506 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: output.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defmacro with-no-output (&body forms)
+ ;; turn off SNARK printing options and redirect any remaining output to /dev/null
+ ;; example usage:
+ ;; (with-no-output
+ ;; (initialize)
+ ;; (assert ...)
+ ;; (prove ...))
+ `(let-options ((default-print-rows-when-derived nil)
+ (default-print-rows-when-given nil)
+ (default-print-rows-when-processed nil)
+ (default-print-final-rows nil)
+ (default-print-unorientable-rows nil)
+ (default-print-pure-rows nil)
+ (default-print-irrelevant-rows nil)
+ (default-print-rewrite-orientation nil)
+ (default-print-summary-when-finished nil)
+ (default-print-clocks-when-finished nil)
+ (default-print-term-memory-when-finished nil)
+ (default-print-agenda-when-finished nil)
+ (default-print-rows-when-finished nil)
+ (default-print-options-when-starting nil)
+ (default-print-assertion-analysis-notes nil)
+ (default-print-symbol-table-warnings nil)
+ (print-rows-when-derived nil)
+ (print-rows-when-given nil)
+ (print-rows-when-processed nil)
+ (print-final-rows nil)
+ (print-unorientable-rows nil)
+ (print-pure-rows nil)
+ (print-irrelevant-rows nil)
+ (print-rewrite-orientation nil)
+ (print-summary-when-finished nil)
+ (print-clocks-when-finished nil)
+ (print-term-memory-when-finished nil)
+ (print-agenda-when-finished nil)
+ (print-rows-when-finished nil)
+ (print-options-when-starting nil)
+ (print-assertion-analysis-notes nil)
+ (print-symbol-table-warnings nil)
+ )
+ #+mcl
+ (progn ,@forms)
+ #-mcl
+ (with-open-file (*standard-output*
+ (make-pathname :directory '(:absolute "dev") :name "null")
+ :direction :output
+ :if-exists :append)
+ (let ((*error-output* *standard-output*))
+ ,@forms))))
+
+(defun print-function-symbol (fn &optional (stream *standard-output*) depth)
+ (declare (ignore depth))
+ (write (function-name fn) :stream stream)
+ fn)
+
+(defun print-variable (x &optional (stream *standard-output*) depth)
+ (declare (ignore depth))
+ (let ((num (variable-number x))
+ (sort (variable-sort x)))
+ (princ (first (variable-symbol-prefixes?)) stream)
+ (mvlet (((values i j) (floor num 6)))
+ (princ (nth j '(x y z u v w)) stream)
+ (unless (eql 0 i)
+ (write i :stream stream :base 10 :radix nil)))
+ (unless (top-sort? sort)
+ (princ (variable-sort-marker?) stream)
+ (princ (sort-name sort) stream))
+ x))
+
+(defun print-term3 (term &optional (stream *standard-output*) depth)
+ (declare (ignore depth))
+ (print-term term nil stream))
+
+(defun print-term (term &optional subst (stream *standard-output*))
+ ;; terms are printed by first converting them to lisp
+ (with-standard-io-syntax2
+ (write (term-to-lisp term subst) :stream stream))
+ term)
+
+(defun print-row-term (term &optional subst (stream *standard-output*))
+ (let ((term term))
+ (when (print-row-length-limit?)
+ (dereference
+ term subst
+ :if-compound-appl (when (and (eq *or* (heada term)) (< (print-row-length-limit?) (length (argsa term))))
+ (setf term (make-compound* *or* (nconc (firstn (argsa term) (print-row-length-limit?)) '(---)))))))
+ (let ((*print-pretty2* (and (print-rows-prettily?) (print-row-wffs-prettily?))))
+ (print-term term subst stream)))
+ term)
+
+(defmethod print-given-row (row)
+ (case (print-rows-when-given?)
+ ((nil)
+ (when (eq :signal (print-rows-when-derived?))
+ (comment)
+ (princ #\|)))
+ (:signal
+ (comment)
+ (princ #\|))
+ (otherwise
+ (with-clock-on printing
+ (when (print-time-used?)
+ (print-incremental-time-used))
+ (dotimes (dummy (- (case (print-rows-when-derived?)
+ ((:signal nil)
+ (print-given-row-lines-signalling?))
+ (otherwise
+ (print-given-row-lines-printing?)))
+ 1))
+ (declare (ignorable dummy))
+ (terpri))
+ (terpri)
+ (print-row row :string "Infer_from_row ")
+ (princ " ")
+ (force-output))))
+ row)
+
+(defmethod print-derived-row (row)
+ (case (print-rows-when-derived?)
+ ((nil)
+ )
+ (:signal
+ (comment)
+ (princ #\+))
+ #+ignore
+ (:fact
+ (when (let ((wff (row-wff row)))
+ (dereference wff nil :if-compound (eq fact-relation (head wff))))
+ (with-clock-on printing
+ (when (print-time-used?)
+ (print-incremental-time-used))
+ (terpri)
+ (print-row row)
+ (princ " "))))
+ (otherwise
+ (with-clock-on printing
+ (when (print-time-used?)
+ (print-incremental-time-used))
+ (terpri)
+ (print-row row)
+ (princ " "))))
+ row)
+
+(defun print-processed-row (row)
+ (case (print-rows-when-processed?)
+ ((nil :signal)
+ )
+ (otherwise
+ (with-clock-on printing
+ (when (print-time-used?)
+ (print-incremental-time-used))
+ (terpri)
+ (let-options ((use-to-lisp-code nil))
+ (print-row row :string "Processing_row "))
+ (princ " "))))
+ row)
+
+(defun print-pure-row (row)
+ (case (print-pure-rows?)
+ ((nil)
+ )
+ (otherwise
+ (with-clock-on printing
+ (when (print-time-used?)
+ (print-incremental-time-used))
+ (terpri)
+ (print-row row :string "Pure_row ")
+ (princ " "))))
+ row)
+
+(defvar *printing-deleted-messages* nil)
+
+(defun print-deleted-wff (row msg)
+ (case (print-rows-when-derived?)
+ ((nil)
+ )
+ (:signal
+ (comment)
+ (princ (if (equal "deleted because agenda full" msg) #\d #\-)))
+ #+ignore
+ (:fact
+ (when (let ((wff (row-wff row)))
+ (dereference wff nil :if-compound (eq fact-relation (head wff))))
+ (with-clock-on printing
+ (terpri-comment)
+ (format t " ~A ~A" msg (row-name-or-number row)))))
+ (otherwise
+ (with-clock-on printing
+ (cond
+ ((equal *printing-deleted-messages* msg)
+ (format t ",~A" (row-name-or-number row)))
+ (t
+ (terpri-comment)
+ (format t "~A ~A" msg (row-name-or-number row))
+ (setf *printing-deleted-messages* msg))))))
+ row)
+
+(defun print-unorientable-wff (equality-or-equivalence)
+ (case (print-unorientable-rows?)
+ ((nil :signal)
+ )
+ (otherwise
+ (with-clock-on printing
+ (warn "Could not orient ~A." equality-or-equivalence))))
+ equality-or-equivalence)
+
+(defvar *szs-filespec* nil)
+
+(defvar *szs-conjecture* nil)
+
+(defun print-szs-status (status &optional (nocomment nil) (filespec *szs-filespec*))
+ (unless nocomment
+ (terpri)
+ (princ "#||")
+ (terpri))
+ (princ "% SZS status ")
+ (princ (case status
+ (:proof-found
+ (if *szs-conjecture* "Theorem" "Unsatisfiable"))
+ (:run-time-limit
+ "Timeout")
+ (:agenda-empty
+ "GaveUp")
+ (otherwise
+ status)))
+ (when filespec
+ (princ " for ")
+ (princ filespec))
+ (unless nocomment
+ (terpri)
+ (princ "||#")
+ (terpri)))
+
+(defun print-szs-answers-short (answers)
+ (let ((answers (mapcan (lambda (answer)
+ (and (compound-p answer) (eq 'values (function-name (head answer))) (list (args answer))))
+ answers)))
+ (when answers
+ (princ "% SZS answers short ")
+ (print-term-in-tptp-format answers)
+ (terpri)
+ t)))
+
+(defun print-final-row (row)
+ (let ((p (print-final-rows?)))
+ (cond
+ ((null p)
+ )
+ ((eq :signal p)
+ (comment)
+ (princ #\.))
+ (t
+ (with-clock-on printing
+ (unless (eq :tptp p)
+ (terpri)
+ (terpri)
+ (princ "(Refutation")
+ (print-ancestry row)
+ (terpri)
+ (princ ")"))
+ (when (or (eq :tptp p) (eq :tptp-too p))
+ (terpri)
+ (terpri)
+ (princ "#||")
+ (terpri)
+ (print-szs-status :proof-found t)
+ (terpri)
+ (print-szs-answers-short (list (row-answer row)))
+ (princ "% SZS output start Refutation")
+ (print-ancestry row :format :tptp)
+ (terpri)
+ (princ "% SZS output end Refutation")
+ (terpri)
+ (princ "||#")))))
+ row))
+
+(defun replace-rows-by-name-or-number (x)
+ (cond
+ ((consp x)
+ (lcons (replace-rows-by-name-or-number (car x)) (replace-rows-by-name-or-number (cdr x)) x))
+ ((row-p x)
+ (row-name-or-number x))
+ (t
+ x)))
+
+(defun print-row-reason (row)
+ (with-standard-io-syntax2
+ (prin1 (replace-rows-by-name-or-number (row-reason row))))
+ nil)
+
+(defun print-row3 (row *standard-output* depth)
+ "this function is used in the defstruct for ROW to print rows."
+ (declare (ignore depth))
+ (let-options ((print-rows-shortened nil)
+ (print-rows-prettily nil)
+ (print-row-reasons nil)
+ (print-row-answers nil)
+ (print-row-constraints nil)
+ (print-row-partitions nil))
+ (print-row row)))
+
+(defun print-row-length-limit1 (row)
+ (let ((n1 (print-rows-shortened?)))
+ (and n1
+ (let* ((reason (row-reason row))
+ (n2 (and (consp reason)
+ (eq 'resolve (first reason))
+ (row-p (third reason))
+ (clause-p (row-wff (third reason)))
+ (wff-length (row-wff (third reason))))))
+ (if (numberp n1)
+ (if n2 (min n1 n2) n1)
+ n2)))))
+
+(defun print-row (row &key (string "Row ") format ancestry reverse)
+ (setf row (row row 'warn))
+ (cond
+ ((null row)
+ )
+ (ancestry
+ (print-rows
+ :rowset (let ((rowset (make-rowset))) (rowset-insert row rowset) rowset)
+ :format format
+ :ancestry ancestry
+ :reverse reverse))
+ (t
+ (ecase format
+ ((nil)
+ (with-standard-io-syntax2
+ (princ "(")
+ (princ string)
+ (prin1 (row-name-or-number row))
+ (cond
+ ((print-rows-prettily?)
+ (terpri)
+ (princ " "))
+ (t
+ (princ " ")))
+ (let-options ((print-row-length-limit (print-row-length-limit1 row)))
+ (print-row-term
+ (cond
+ ((not (print-row-goals?))
+ (prog->
+ (map-atoms-in-wff-and-compose-result (row-wff row) ->* atom polarity)
+ (declare (ignore polarity))
+ (dereference
+ atom nil
+ :if-constant (if (proposition-magic-goal-p atom) true atom)
+ :if-compound (if (relation-magic-goal-p (head atom)) true atom))))
+ (t
+ (row-wff row)))))
+ (when (print-row-reasons?)
+ (cond
+ ((print-rows-prettily?)
+ (terpri)
+ (princ " "))
+ (t
+ (format t "~70T")))
+ (print-row-reason row))
+ (when (print-row-constraints?)
+ (dolist (x (row-constraints row))
+ (unless (eq true (cdr x))
+ (terpri)
+ (princ " ")
+ (princ (string-capitalize (car x)))
+ (princ "-Constraint ")
+ (print-row-term (negate (cdr x))))))
+ (when (print-row-answers?)
+ (let ((answer (row-answer row)))
+ (unless (eq false answer)
+ (terpri)
+ (princ " Answer ")
+ (print-row-term answer))))
+ (when (and (use-partitions?) (print-row-partitions?))
+ (terpri)
+ (princ " Partitions ")
+ (prin1 (mapcar #'car (row-context row))))
+ (princ ")")))
+ (:tptp
+ (print-row-in-tptp-format row)))))
+ row)
+
+(defvar *propositional-abstraction-term-to-lisp* nil)
+
+(defun term-to-lisp (term &optional subst)
+ "Return a Lisp data structure for the given term."
+ ;; returns (f a b c) for SNARK term f(a,b,c)
+ ;; returns (list a b c) for SNARK term [a,b,c]
+ ;; use variable-p, variable-number, variable-sort
+ ;; sort information is invalid after SNARK is reinitialized
+ (labels
+ ((term-to-lisp (term)
+ (dereference
+ term subst
+ :if-constant (let ((name (constant-name term)))
+ (cond
+ ((not (can-be-constant-name name))
+ (list '$$quote name))
+ (t
+ name)))
+ :if-variable (dolist (fun (if (use-to-lisp-code?) (mklist (variable-to-lisp-code?)) nil) term)
+ (let ((v (funcall fun term)))
+ (unless (eq none v)
+ (return v))))
+ :if-compound (let ((head (head term))
+ (args (args term)))
+ (cond
+ ((and *propositional-abstraction-term-to-lisp*
+ (not (function-logical-symbol-p head)))
+ (list (function-name head) (function-arity head)))
+ (t
+ (dolist (fun (if (use-to-lisp-code?) (function-to-lisp-code head) nil) (cons (function-name head) (args-to-lisp args)))
+ (let ((v (funcall fun head args subst)))
+ (unless (eq none v)
+ (return v)))))))))
+ (args-to-lisp (args)
+ (lcons (term-to-lisp (first args)) (args-to-lisp (rest args)) args)))
+ (term-to-lisp term)))
+
+(defun cons-term-to-lisp (head args subst)
+ ;; converts
+ ;; (a) to ($$list a)
+ ;; (a b) to ($$list a b)
+ ;; (a . b) to ($$cons a b)
+ ;; (a b . c) to ($$list* a b c)
+ ;; when used as to-lisp-code for cons
+ (cl:assert (eq *cons* head))
+ (let* ((y (term-to-lisp (second args) subst))
+ (x (term-to-lisp (first args) subst)))
+ (cond
+ ((null y)
+ (list (current-function-name '$$list :any) x))
+ ((atom y)
+ (list (function-name head) x y))
+ (t
+ (let ((v (first y)) list*)
+ (cond
+ ((eq v (current-function-name '$$list :any))
+ (list* v x (rest y)))
+ ((or (eq v (setf list* (current-function-name '$$list* :any)))
+ (eq v (function-name head)))
+ (list* list* x (rest y)))
+ (t
+ (list (function-name head) x y))))))))
+
+(defun quant-compound-to-lisp (head args subst)
+ (list (function-name head)
+ (mapcar (lambda (var-spec)
+ (if (variable-p var-spec)
+ (term-to-lisp var-spec subst)
+ (mapcar #'(lambda (x) (term-to-lisp x subst)) var-spec)))
+ (first args))
+ (term-to-lisp (second args) subst)))
+
+(defun row-sorts (row &optional sorts)
+ (prog->
+ (map-terms-in-wff (row-wff row) ->* term polarity)
+ (declare (ignore polarity))
+ (let ((sort (term-sort term)))
+ (unless (top-sort? sort)
+ (pushnew (term-sort term) sorts :test #'same-sort?))))
+ sorts)
+
+(defun derivation-sorts (row)
+ (let ((sorts nil))
+ (dolist (row (row-ancestry row))
+ (setf sorts (row-sorts row sorts)))
+ sorts))
+
+(defun subsort-forms (sorts)
+ (let ((result nil))
+ (dotails (l sorts)
+ (let ((sort1 (first l)))
+ (dolist (sort2 (rest l))
+ (cond
+ ((subsort? sort1 sort2)
+ (push `(subsort ,(sort-name sort1) ,(sort-name sort2)) result))
+ ((subsort? sort2 sort1)
+ (push `(subsort ,(sort-name sort2) ,(sort-name sort1)) result))))))
+ result))
+
+(defun derivation-subsort-forms (row)
+ (subsort-forms (derivation-sorts row)))
+
+;;; output.lisp EOF
diff --git a/snark-20120808r02/src/patches.abcl b/snark-20120808r02/src/patches.abcl
new file mode 100644
index 0000000..0f86217
Binary files /dev/null and b/snark-20120808r02/src/patches.abcl differ
diff --git a/snark-20120808r02/src/patches.lisp b/snark-20120808r02/src/patches.lisp
new file mode 100644
index 0000000..b15efff
--- /dev/null
+++ b/snark-20120808r02/src/patches.lisp
@@ -0,0 +1,26 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: patches.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2002.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun make-instance-graph (&rest args)
+ (declare (ignore args))
+ nil)
+
+;;; patches.lisp EOF
diff --git a/snark-20120808r02/src/path-index.abcl b/snark-20120808r02/src/path-index.abcl
new file mode 100644
index 0000000..0779138
Binary files /dev/null and b/snark-20120808r02/src/path-index.abcl differ
diff --git a/snark-20120808r02/src/path-index.lisp b/snark-20120808r02/src/path-index.lisp
new file mode 100644
index 0000000..0794c49
--- /dev/null
+++ b/snark-20120808r02/src/path-index.lisp
@@ -0,0 +1,870 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: path-index.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(declaim (special *terpri-indent*))
+
+(defvar *path-index*)
+
+(defstruct (path-index
+ (:constructor make-path-index0 (entry-constructor entries))
+ (:copier nil))
+ (entry-constructor nil :read-only t) ;term->entry function for new entry insertion
+ (node-counter (make-counter 1) :read-only t)
+ (entry-counter (make-counter) :read-only t)
+ (top-node (make-path-index-internal-node1 :mark nil) :read-only t)
+ (entries nil :read-only t)) ;term->entry hash-table for entry lookup
+
+(defstruct (path-index-node
+ (:copier nil))
+ (parent-node nil :read-only t)
+ (mark (increment-counter (path-index-node-counter *path-index*))))
+
+(defstruct (path-index-internal-node1
+ (:include path-index-node)
+ (:copier nil))
+ (variable-child-node nil) ;nil or internal-node
+ (constant-indexed-child-nodes (make-sparse-vector)) ;constant# -> leaf-node sparse-vector
+ (function-indexed-child-nodes (make-sparse-vector))) ;function# -> internal-node sparse-vector
+
+(defstruct (path-index-internal-node2
+ (:include path-index-node)
+ (:copier nil))
+ (integer-indexed-child-nodes nil :read-only t) ;vector of internal-nodes (or nil) indexed by argument position
+ query) ;node in integer-indexed-child-nodes to use to generate all instances
+
+(defstruct (path-index-leaf-node
+ (:include path-index-node)
+ (:copier nil))
+ (entries (make-sparse-vector) :read-only t))
+
+(defstruct (path-index-entry
+ (:include index-entry)
+ (:constructor make-path-index-entry (term))
+ (:copier nil))
+ in-nodes ;vector of (possible query) nodes that contain entry
+ in-nodes-last ;last index into in-nodes
+ (mark nil))
+
+(defun make-path-index (&key (entry-constructor #'make-path-index-entry))
+ (setf *path-index* (make-path-index0 entry-constructor (make-sparse-vector))))
+
+(defmacro path-index-internal-node1-function-indexed-child-node (head node1)
+ `(sparef (path-index-internal-node1-function-indexed-child-nodes ,node1) (function-number ,head)))
+
+(defmacro path-index-internal-node1-constant-indexed-child-node (const node1)
+ `(sparef (path-index-internal-node1-constant-indexed-child-nodes ,node1) (constant-number ,const)))
+
+(defmacro add-path-index-internal-node1-function-indexed-child-node (head node1 node)
+ `(setf (path-index-internal-node1-function-indexed-child-node ,head ,node1) ,node))
+
+(defmacro add-path-index-internal-node1-constant-indexed-child-node (const node1 node)
+ `(setf (path-index-internal-node1-constant-indexed-child-node ,const ,node1) ,node))
+
+(defun path-index-entry (term)
+ ;; return path-index-entry for term
+ ;; create one if there isn't one
+ (let ((term# (funcall *standard-eql-numbering* :lookup term)))
+ (or (sparef (path-index-entries *path-index*) term#)
+ (path-index-insert term))))
+
+(defun the-path-index-entry (term)
+ ;; return path-index-entry for term
+ ;; error if there isn't one
+ (let ((term# (funcall *standard-eql-numbering* :lookup term)))
+ (or (sparef (path-index-entries *path-index*) term#)
+ (progn
+ (cl:assert (eql term (hash-term term)))
+ (error "No path-index-entry for term.")))))
+
+(defun some-path-index-entry (term)
+ ;; return path-index-entry for term
+ ;; return nil if there isn't one
+ (let ((term# (funcall *standard-eql-numbering* :lookup term)))
+ (or (sparef (path-index-entries *path-index*) term#)
+ (progn
+ #+ignore (cl:assert (eql term (hash-term term)))
+ nil))))
+
+(defun path-index-delete (term)
+ (let* ((path-index *path-index*)
+ (term# (funcall *standard-eql-numbering* :lookup term))
+ (entry (or (sparef (path-index-entries path-index) term#)
+ (progn
+ #+ignore (cl:assert (eql term (hash-term term)))
+ nil))))
+ (when entry
+ (every (lambda (node)
+ (when (path-index-leaf-node-p node)
+ (let ((entries (path-index-leaf-node-entries node)))
+ (setf (sparef entries (tme-number entry)) nil)
+ (when (= 0 (sparse-vector-count entries))
+ (path-index-delete-leaf-node node))))
+ t)
+ (path-index-entry-in-nodes entry))
+ (setf (sparef (path-index-entries path-index) term#) nil)
+ (decrement-counter (path-index-entry-counter path-index)))
+ entry))
+
+(defun path-index-delete-leaf-node (node)
+ (let ((path-index *path-index*)
+ (parent (path-index-node-parent-node node)))
+ (cond
+ ((eq node (path-index-internal-node1-variable-child-node parent))
+ (setf (path-index-internal-node1-variable-child-node parent) nil))
+ (t
+ (let ((table (path-index-internal-node1-constant-indexed-child-nodes parent)))
+ (map-sparse-vector-with-indexes
+ (lambda (value key)
+ (when (eq node value)
+ (setf (sparef table key) nil)))
+ table))))
+ (decrement-counter (path-index-node-counter path-index))))
+
+(defvar *path-index-insert-entry*)
+(defvar *path-index-insert-entry-leaf-nodes*)
+(defvar *path-index-insert-entry-internal-nodes*)
+
+(defun path-index-insert (term)
+ #+ignore (cl:assert (eql term (hash-term term)))
+ (let* ((path-index *path-index*)
+ (entry (funcall (path-index-entry-constructor path-index) term)))
+ (increment-counter (path-index-entry-counter path-index))
+ (let ((term# (funcall *standard-eql-numbering* :lookup term)))
+ (setf (sparef (path-index-entries path-index) term#) entry))
+ (let ((*path-index-insert-entry* entry)
+ (*path-index-insert-entry-leaf-nodes* nil)
+ (*path-index-insert-entry-internal-nodes* nil))
+ ;; FOR EMBEDDINGS
+ (when (compound-p term)
+ (let ((head (head term)))
+ (when (function-associative head)
+ (setf term (make-compound* head (make-variable) (args term))))))
+ (path-index-insert* term (path-index-top-node path-index))
+ (let* ((l (nconc *path-index-insert-entry-internal-nodes* *path-index-insert-entry-leaf-nodes*))
+ (n (length l)))
+ (setf (path-index-entry-in-nodes entry) (make-array n :initial-contents l))
+ (setf (path-index-entry-in-nodes-last entry) (- n 1))))
+ entry))
+
+(defun path-index-insert* (term node1 &optional head-if-associative)
+ ;; find or create paths for term so that term can be inserted in path-index
+ (dereference
+ term nil
+ :if-variable (let ((leaf (path-index-internal-node1-variable-child-node node1)))
+ (unless leaf
+ (setf leaf (make-path-index-leaf-node :parent-node node1))
+ (setf (path-index-internal-node1-variable-child-node node1) leaf))
+ (path-index-insert-at-leaf leaf))
+ :if-constant (let ((leaf (path-index-internal-node1-constant-indexed-child-node term node1)))
+ (unless leaf
+ (setf leaf (make-path-index-leaf-node :parent-node node1))
+ (add-path-index-internal-node1-constant-indexed-child-node term node1 leaf))
+ (path-index-insert-at-leaf leaf))
+ :if-compound (let ((args (args term)))
+ (if args
+ (path-index-insert-appl (head term) args node1 head-if-associative)
+ (path-index-insert* (function-name (head term)) node1 head-if-associative))))) ;handle 0-ary as constant
+
+(defun path-index-insert-appl (head args node1 head-if-associative)
+ (cond
+ ((eq head-if-associative head)
+ (dolist (arg args)
+ (path-index-insert* arg node1 head-if-associative)))
+ ((no-integer-indexed-child-nodes-p head)
+ (let ((node1a (path-index-internal-node1-function-indexed-child-node head node1)))
+ (unless node1a
+ (setf node1a (make-path-index-internal-node1 :parent-node node1))
+ (add-path-index-internal-node1-function-indexed-child-node head node1 node1a))
+ (let ((l *path-index-insert-entry-internal-nodes*))
+ (unless (member node1a l)
+ (setf *path-index-insert-entry-internal-nodes* (cons node1a l))))
+ (ecase (function-index-type head)
+ (:commute ;no integer indexed child nodes => arity=2
+ (path-index-insert* (first args) node1a)
+ (path-index-insert* (second args) node1a))
+ (:jepd
+ (path-index-insert* (first args) node1a)
+ (path-index-insert* (second args) node1a))
+ (:hash-but-dont-index
+ (path-index-insert* (function-name head) node1 head-if-associative)) ;as if there were no arguments
+ ((nil)
+ (case (function-arity head)
+ (otherwise
+ (let ((head-if-associative (and (function-associative head) head)))
+ (dolist (arg args)
+ (path-index-insert* arg node1a head-if-associative)))))))))
+ (t
+ (ecase (function-index-type head)
+ ((nil)
+ (path-index-insert-list head args node1))
+ (:commute
+ (path-index-insert-list head args node1 #'c-index))))))
+
+(defun path-index-insert-list (head args node1 &optional indexfun)
+ (loop with node2 = (path-index-insert-list1 head (length args) node1 indexfun)
+ with iinodes = (path-index-internal-node2-integer-indexed-child-nodes node2)
+ for arg in args
+ as i from 0
+ do (path-index-insert* arg (svref iinodes (if indexfun (funcall indexfun head i) i)))))
+
+(defun path-index-insert-list1 (head arity node1 indexfun)
+ (let ((node2 (path-index-internal-node1-function-indexed-child-node head node1)))
+ (unless node2
+ (let ((iinodes (make-array arity :initial-element nil)))
+ (setf node2 (make-path-index-internal-node2 :parent-node node1 :integer-indexed-child-nodes iinodes))
+ (dotimes (i arity)
+ (let ((i* (if indexfun (funcall indexfun head i) i)))
+ (unless (svref iinodes i*)
+ (setf (svref iinodes i*) (make-path-index-internal-node1 :parent-node node2)))))
+ (loop for i downfrom (- arity 1)
+ as v = (svref iinodes i)
+ do (when v
+ (setf (path-index-internal-node2-query node2) v)
+ (return))))
+ (add-path-index-internal-node1-function-indexed-child-node head node1 node2))
+ (let ((l *path-index-insert-entry-internal-nodes*)
+ (n (path-index-internal-node2-query node2)))
+ (unless (member n l)
+ (setf *path-index-insert-entry-internal-nodes* (cons n l))))
+ node2))
+
+(defun path-index-insert-at-leaf (leaf)
+ (let ((entry *path-index-insert-entry*)
+ (entries (path-index-leaf-node-entries leaf)))
+ (let ((num (tme-number entry)))
+ (unless (sparef entries num)
+ (push leaf *path-index-insert-entry-leaf-nodes*)
+ (setf (sparef entries num) entry)))))
+
+(defun no-integer-indexed-child-nodes-p (head)
+ (ecase (function-index-type head)
+ (:commute
+ (or (eql 2 (function-arity head)) (eq *=* head)))
+ ((:jepd :hash-but-dont-index)
+ t)
+ ((nil)
+ (let ((arity (function-arity head)))
+ (or (eql 1 arity)
+ (function-associative head)
+ (eq :any arity))))))
+
+(defun c-index (head i)
+ (declare (ignore head))
+ (if (eql 1 i) 0 i))
+
+(defmacro path-index-variable-leaf (node1)
+ `(let ((v (path-index-internal-node1-variable-child-node ,node1)))
+ (and v
+ (neql 0 (sparse-vector-count (path-index-leaf-node-entries v)))
+ v)))
+
+(defmacro path-index-constant-leaf (node1 const)
+ `(let ((v (path-index-internal-node1-constant-indexed-child-node ,const ,node1)))
+ (and v
+ (neql 0 (sparse-vector-count (path-index-leaf-node-entries v)))
+ v)))
+
+(defun make-path-index-query (type term &optional subst)
+;;(print type) (print-term term subst)
+ (let ((query
+ (ecase type
+ (:generalization
+ (make-path-index-query-g term subst (path-index-top-node *path-index*)))
+ (:instance
+ (make-path-index-query-i term subst (path-index-top-node *path-index*)))
+ (:unifiable
+ (make-path-index-query-u term subst (path-index-top-node *path-index*)))
+ (:variant
+ (make-path-index-query-v term subst (path-index-top-node *path-index*))))))
+ #+ignore
+ (progn
+ (terpri-comment-indent)
+ (print-term term subst)
+ (format t " ~(~A~) query:" type)
+ (print-path-index-query query)
+ (terpri))
+ query))
+
+(defun make-path-index-query-v (term subst node1 &optional head-if-associative)
+ (dereference
+ term subst
+ :if-variable (path-index-variable-leaf node1)
+ :if-constant (path-index-constant-leaf node1 term)
+ :if-compound (let ((head (head term))
+ (args (args term)))
+ (if (and args (not (eq :hash-but-dont-index (function-index-type head))))
+ (make-path-index-query-appl #'make-path-index-query-v head args subst node1 head-if-associative)
+ (make-path-index-query-v (function-name head) subst node1 head-if-associative))))) ;handle 0-ary as constant
+
+(defun make-path-index-query-i (term subst node1 &optional head-if-associative)
+ (dereference
+ term subst
+ :if-variable t
+ :if-constant (path-index-constant-leaf node1 term)
+ :if-compound (let ((head (head term))
+ (args (args term)))
+ (if (and args (not (eq :hash-but-dont-index (function-index-type head))))
+ (make-path-index-query-appl #'make-path-index-query-i head args subst node1 head-if-associative)
+ (make-path-index-query-i (function-name head) subst node1 head-if-associative))))) ;handle 0-ary as constant
+
+(defun make-path-index-query-g (term subst node1 &optional head-if-associative)
+ (dereference
+ term subst
+ :if-variable (path-index-variable-leaf node1)
+ :if-constant (make-uniond-query2
+ (path-index-constant-leaf node1 term)
+ (path-index-variable-leaf node1))
+ :if-compound (let ((head (head term))
+ (args (args term)))
+ (if (and args (not (eq :hash-but-dont-index (function-index-type head))))
+ (make-uniond-query2
+ (make-path-index-query-appl #'make-path-index-query-g head args subst node1 head-if-associative)
+ (path-index-variable-leaf node1))
+ (make-path-index-query-g (function-name head) subst node1 head-if-associative))))) ;handle 0-ary as constant
+
+(defun make-path-index-query-u (term subst node1 &optional head-if-associative)
+ (dereference
+ term subst
+ :if-variable t
+ :if-constant (make-uniond-query2
+ (path-index-constant-leaf node1 term)
+ (path-index-variable-leaf node1))
+ :if-compound (let ((head (head term))
+ (args (args term)))
+ (if (and args (not (eq :hash-but-dont-index (function-index-type head))))
+ (make-uniond-query2
+ (make-path-index-query-appl #'make-path-index-query-u head args subst node1 head-if-associative)
+ (path-index-variable-leaf node1))
+ (make-path-index-query-u (function-name head) subst node1 head-if-associative))))) ;handle 0-ary as constant
+
+(defun make-path-index-query-appl (make-query head args subst node1 head-if-associative)
+ (cond
+ ((eq head-if-associative head)
+ (let ((v (let ((qq nil) qq-last)
+ (dolist (arg args)
+ (let ((q (funcall make-query arg subst node1 head-if-associative)))
+ (cond
+ ((null q)
+ (return-from make-path-index-query-appl nil))
+ ((neq t q)
+ (collect q qq)))))
+ (make-boolean-query 'intersection qq))))
+ (if (eq t v) node1 v)))
+ ((no-integer-indexed-child-nodes-p head)
+ (let ((node1a (path-index-internal-node1-function-indexed-child-node head node1)))
+ (and node1a
+ (let ((v (let ((qq nil) qq-last)
+ (ecase (function-index-type head)
+ ((nil :commute)
+ (case (function-arity head)
+ (otherwise
+ (let ((head-if-associative (and (function-associative head) head)))
+ (dolist (arg args)
+ (let ((q (funcall make-query arg subst node1a head-if-associative)))
+ (cond
+ ((null q)
+ (return-from make-path-index-query-appl nil))
+ ((neq t q)
+ (collect q qq)))))))))
+ (:jepd
+ (dolist (arg (firstn args 2))
+ (let ((q (funcall make-query arg subst node1a)))
+ (cond
+ ((null q)
+ (return-from make-path-index-query-appl nil))
+ ((neq t q)
+ (collect q qq)))))))
+ (make-boolean-query 'intersection qq))))
+ (if (eq t v) node1a v)))))
+ (t
+ (ecase (function-index-type head)
+ ((nil)
+ (make-path-index-query-list make-query head args subst node1))
+ (:commute
+ (make-path-index-query-list make-query head args subst node1 #'c-index))))))
+
+(defun make-path-index-query-list (make-query head args subst node1 &optional indexfun)
+ (let ((node2 (path-index-internal-node1-function-indexed-child-node head node1)))
+ (and node2
+ (let ((v (make-boolean-query
+ 'intersection
+ (loop with iinodes = (path-index-internal-node2-integer-indexed-child-nodes node2)
+ for arg in args
+ as i from 0
+ as q = (funcall make-query arg subst (svref iinodes (if indexfun (funcall indexfun head i) i)))
+ when (null q)
+ do (return-from make-path-index-query-list nil)
+ unless (eq t q)
+ collect q))))
+ (if (eq t v) (path-index-internal-node2-query node2) v)))))
+
+(defmacro map-leaf0 (leaf x &optional y)
+ `(prog->
+ (map-sparse-vector (path-index-leaf-node-entries ,leaf) ->* entry)
+ (cond
+ ((eq query-id (path-index-entry-mark entry))
+ )
+ ,@(when y (list y))
+ ((or (null queries) (path-index-entry-satisfies-query-p entry (first queries) (rest queries)))
+ ,x
+ (setf (path-index-entry-mark entry) query-id)))))
+
+(defmacro map-leaf (leaf)
+ `(if (null test)
+ (map-leaf0 ,leaf (funcall cc entry))
+ (map-leaf0 ,leaf (funcall cc entry test-value)
+ ((null (setf test-value (funcall test entry)))
+ (setf (path-index-entry-mark entry) query-id)))))
+
+;;; test is a predicate applied to a path-index-entry before path-index
+;;; query evaluation is complete to quickly determine whether the
+;;; path-index-entry should be retrieved if it satisfies the query
+;;; the result of test is also passed as second argument to cc
+
+(defun map-path-index-entries (cc type term &optional subst test query-id)
+ (let ((query (make-path-index-query type term subst)))
+ (when query
+ (map-path-index-by-query cc query test query-id))))
+
+(defun map-path-index-by-query (cc query &optional test query-id)
+ (let ((optimized nil))
+ (unless query-id
+ (setf query-id (cons 'query-id nil))) ;query-id unique, eq testable
+ (cond
+ ((test-option14?)
+ (when (path-index-sparse-vector-expression-p query)
+ (setf query (fix-path-index-sparse-vector-expression query))
+ (setf query (if (trace-optimize-sparse-vector-expression?)
+ (traced-optimize-sparse-vector-expression query)
+ (optimize-sparse-vector-expression query)))
+ (let ((n (test-option21?)))
+ (when (and n (consp query) (eq 'intersection (first query)))
+ (setf query (firstn query (+ n 1))))) ;keep only first n terms of intersection
+ (if test
+ (let (test-value)
+ (flet ((filter (entry) (setf test-value (funcall test entry))))
+ (declare (dynamic-extent #'filter))
+ (prog->
+ (map-sparse-vector-expression query :reverse t :filter #'filter ->* entry)
+ (unless (eq query-id (path-index-entry-mark entry))
+ (funcall cc entry test-value)
+ (setf (path-index-entry-mark entry) query-id)))))
+ (prog->
+ (map-sparse-vector-expression query :reverse t ->* entry)
+ (unless (eq query-id (path-index-entry-mark entry))
+ (funcall cc entry)
+ (setf (path-index-entry-mark entry) query-id))))
+ (return-from map-path-index-by-query))))
+ (let (test-value)
+ (labels
+ ((map-path-index-by-query* (query queries)
+ (loop
+ (cond
+ ((not (consp query))
+ (cond
+ ((path-index-leaf-node-p query)
+ (map-leaf query)
+ (return))
+ (t
+ (when (path-index-internal-node2-p query)
+ (setf query (path-index-internal-node2-query query)))
+ (map-sparse-vector
+ (lambda (v) (map-leaf v))
+ (path-index-internal-node1-constant-indexed-child-nodes query)
+ :reverse t)
+ (let ((var-leaf (path-index-internal-node1-variable-child-node query)))
+ (when var-leaf
+ (map-leaf var-leaf)))
+ (let ((q nil))
+ (map-sparse-vector
+ (lambda (v)
+ (when q
+ (map-path-index-by-query* q queries))
+ (setf q v))
+ (path-index-internal-node1-function-indexed-child-nodes query)
+ :reverse t)
+ (if q
+ (setf query q)
+ (return))))))
+ ((eq 'intersection (first query))
+ (dolist (q (prog1 (setf query (rest query))
+ (setf query (if optimized (first query) (select-query query)))))
+ (unless (eq q query)
+ (push q queries))))
+ (t
+;; (cl:assert (member (first query) '(union uniond)))
+ (do* ((l (rest query) l1)
+ (l1 (rest l) (rest l1)))
+ ((null l1)
+ (setf query (first l)))
+ (map-path-index-by-query* (first l) queries)))))))
+ #+ignore (cl:assert query)
+ (when (eq t query)
+ (setf query (path-index-top-node *path-index*)))
+ (map-path-index-by-query* query nil)))))
+
+(defmacro mark-path-index-entry-in-nodes (entry)
+ (cl:assert (symbolp entry))
+ (let ((v (gensym)) (i (gensym)))
+ `(let ((,v (path-index-entry-in-nodes ,entry))
+ (,i (path-index-entry-in-nodes-last ,entry)))
+ (declare (type vector ,v) (type fixnum ,i))
+ (loop
+ (setf (path-index-node-mark (svref ,v ,i)) ,entry)
+ (if (eql 0 ,i)
+ (return)
+ (decf ,i))))))
+
+(defmacro member-path-index-entry-in-nodes (query entry)
+ (cl:assert (symbolp query))
+ (cl:assert (symbolp entry))
+ (let ((v (gensym)) (i (gensym)))
+ `(let ((,v (path-index-entry-in-nodes ,entry))
+ (,i (path-index-entry-in-nodes-last ,entry)))
+ (declare (type vector ,v) (type fixnum ,i))
+ (loop
+ (when (eq (svref ,v ,i) ,query)
+ (return t))
+ (if (eql 0 ,i)
+ (return nil)
+ (decf ,i))))))
+
+(defun path-index-entry-satisfies-query-p (entry query &optional more-queries)
+ (cond
+ (more-queries
+ (mark-path-index-entry-in-nodes entry)
+ (and (path-index-entry-satisfies-query-p* entry query)
+ (path-index-entry-satisfies-query-p* entry (first more-queries))
+ (dolist (query (rest more-queries) t)
+ (unless (path-index-entry-satisfies-query-p* entry query)
+ (return nil)))))
+ ((consp query)
+ (mark-path-index-entry-in-nodes entry)
+ (path-index-entry-satisfies-query-p* entry query))
+ (t
+ (member-path-index-entry-in-nodes query entry))))
+
+(defun path-index-entry-satisfies-query-p* (entry query)
+ (loop
+ (cond
+ ((not (consp query)) ;query is a node
+ (return-from path-index-entry-satisfies-query-p*
+ (eq (path-index-node-mark query) entry)))
+ ((eq 'intersection (first query)) ;intersection
+ (do* ((l (rest query) l1)
+ (l1 (rest l) (rest l1)))
+ ((null l1)
+ (setf query (first l)))
+ (unless (path-index-entry-satisfies-query-p* entry (first l))
+ (return-from path-index-entry-satisfies-query-p*
+ nil))))
+ (t
+;; (cl:assert (member (first query) '(union uniond)))
+ (do* ((l (rest query) l1)
+ (l1 (rest l) (rest l1)))
+ ((null l1)
+ (setf query (first l)))
+ (when (path-index-entry-satisfies-query-p* entry (first l))
+ (return-from path-index-entry-satisfies-query-p*
+ t)))))))
+
+(defun retrieval-size (query bound)
+ (cond
+ ((not (consp query))
+ (cond
+ ((path-index-leaf-node-p query)
+ (sparse-vector-count (path-index-leaf-node-entries query)))
+ (t
+ (when (path-index-internal-node2-p query)
+ (setf query (path-index-internal-node2-query query)))
+ (let ((total-size 0))
+ (let ((var-leaf (path-index-internal-node1-variable-child-node query)))
+ (when var-leaf
+ (incf total-size (sparse-vector-count (path-index-leaf-node-entries var-leaf)))
+ (when (>= total-size bound)
+ (return-from retrieval-size bound))))
+ (map-sparse-vector
+ (lambda (v)
+ (incf total-size (sparse-vector-count (path-index-leaf-node-entries v)))
+ (when (>= total-size bound)
+ (return-from retrieval-size bound)))
+ (path-index-internal-node1-constant-indexed-child-nodes query))
+ (map-sparse-vector
+ (lambda (v)
+ (incf total-size (retrieval-size v (- bound total-size)))
+ (when (>= total-size bound)
+ (return-from retrieval-size bound)))
+ (path-index-internal-node1-function-indexed-child-nodes query))
+ total-size))))
+ ((eq 'intersection (first query))
+ (let* ((args (rest query))
+ (min-size (retrieval-size (first args) bound)))
+ (dolist (arg (rest args))
+ (let ((n (retrieval-size arg min-size)))
+ (when (< n min-size)
+ (when (<= (setf min-size n) 1)
+ (return)))))
+ min-size))
+ (t
+;; (cl:assert (member (first query) '(union uniond)))
+ (let ((total-size 0))
+ (dolist (arg (rest query))
+ (incf total-size (retrieval-size arg (- bound total-size)))
+ (when (>= total-size bound)
+ (return-from retrieval-size bound)))
+ total-size))))
+
+(defun select-query (args)
+ (let* ((best (first args))
+ (min-size (retrieval-size best 1000000)))
+ (dolist (arg (rest args))
+ (let ((n (retrieval-size arg min-size)))
+ (when (< n min-size)
+ (setf best arg)
+ (when (<= (setf min-size n) 1)
+ (return)))))
+ best))
+
+(defun make-boolean-query* (fn l)
+ (let ((a (first l))
+ (d (rest l)))
+ (if (null d)
+ (if (and (consp a) (eq fn (first a)))
+ (rest a)
+ l)
+ (let ((d* (make-boolean-query* fn d)))
+ (cond
+ ((and (consp a) (eq fn (first a)))
+ (nodup-append (rest a) d*))
+ ((equal a (first d*))
+ d*)
+ ((member a (rest d*) :test #'equal)
+ (cons a (cons (first d*) (remove a (rest d*) :test #'equal))))
+ ((eq d d*)
+ l)
+ (t
+ (cons a d*)))))))
+
+(defun make-boolean-query (fn l)
+ (cond
+ ((null l)
+ (ecase fn
+ (intersection
+ t)
+ ((union uniond)
+ nil)))
+ (t
+ (let ((l* (make-boolean-query* fn l)))
+ (cond
+ ((null (rest l*))
+ (first l*))
+ (t
+ (cons fn l*)))))))
+
+(defun make-uniond-query2 (q1 q2)
+ (cond
+ ((null q1)
+ q2)
+ ((null q2)
+ q1)
+ (t
+ (make-boolean-query 'uniond (list q1 q2)))))
+
+(defun nodup-append (l1 l2 &optional (l2* nil))
+ ;; append l1 and l2 eliminating items in l2 that appear in l1
+ (if (null l2)
+ (if (null l2*)
+ l1
+ (append l1 (nreverse l2*)))
+ (nodup-append l1
+ (rest l2)
+ (if (member (first l2) l1 :test #'equal)
+ l2*
+ (cons (first l2) l2*)))))
+
+(defun path-index-sparse-vector-expression-p (x)
+ (cond
+ ((atom x)
+ (when (path-index-leaf-node-p x)
+ (setf x (path-index-leaf-node-entries x)))
+ (and (sparse-vector-p x) (null (sparse-vector-default-value x))))
+ (t
+ (let ((fn (first x))
+ (args (rest x)))
+ (and (or (eq 'intersection fn) (eq 'union fn) (eq 'uniond fn))
+ args
+ (dolist (arg args t)
+ (unless (path-index-sparse-vector-expression-p arg)
+ (return nil))))))))
+
+(defun fix-path-index-sparse-vector-expression (x)
+ (cond
+ ((atom x)
+ (if (path-index-leaf-node-p x)
+ (path-index-leaf-node-entries x)
+ x))
+ (t
+ (dotails (l (rest x))
+ (setf (first l) (fix-path-index-sparse-vector-expression (first l))))
+ x)))
+
+(defun sparse-vector-expression-description (expr)
+ (cond
+ ((atom expr)
+ (sparse-vector-count expr))
+ (t
+ (cons (ecase (first expr) (intersection '&) (union 'u) (uniond 'v))
+ (mapcar #'sparse-vector-expression-description (rest expr))))))
+
+(defun sz (x)
+ (if (atom x) 0 (+ (sz (car x)) (sz (cdr x)) 1)))
+
+(defun traced-optimize-sparse-vector-expression (expr)
+ (let* ((desc (sparse-vector-expression-description expr))
+ (expr* (optimize-sparse-vector-expression expr))
+ (desc* (sparse-vector-expression-description expr*)))
+ (format t "~%~A" desc*)
+ (unless (eql (sz desc) (sz desc*))
+ (format t " optimized from ~A" desc))
+ expr*))
+
+(defun print-path-index (&key terms nodes)
+ (let ((index *path-index*))
+ (mvlet (((:values current peak added deleted) (counter-values (path-index-entry-counter index))))
+ (format t "~%; Path-index has ~:D entr~:@P (~:D at peak, ~:D added, ~:D deleted)." current peak added deleted))
+ (mvlet (((:values current peak added deleted) (counter-values (path-index-node-counter index))))
+ (format t "~%; Path-index has ~:D node~:P (~:D at peak, ~:D added, ~:D deleted)." current peak added deleted))
+ (when (or nodes terms)
+ (print-index* (path-index-top-node index) nil terms))))
+
+(defmethod print-index-leaf-node ((node path-index-leaf-node) revpath print-terms)
+ (with-standard-io-syntax2
+ (prog->
+ (format t "~%; Path ")
+ (print-revpath revpath)
+ (path-index-leaf-node-entries node -> entries)
+ (format t " has ~:D entr~:@P." (sparse-vector-count entries))
+ (when print-terms
+ (map-sparse-vector entries ->* entry)
+ (format t "~%; ")
+ (print-term (index-entry-term entry))))))
+
+(defmethod map-index-leaf-nodes (cc (node path-index-internal-node1) revpath)
+ (let ((v (path-index-internal-node1-variable-child-node node)))
+ (when v
+ (map-index-leaf-nodes cc v (cons "variable" revpath))))
+ (map-sparse-vector-with-indexes
+ (lambda (v k)
+ (map-index-leaf-nodes cc v (cons (symbol-numbered k) revpath)))
+ (path-index-internal-node1-constant-indexed-child-nodes node)
+ :reverse t)
+ (map-sparse-vector-with-indexes
+ (lambda (v k)
+ (map-index-leaf-nodes cc v (cons (symbol-numbered k) revpath)))
+ (path-index-internal-node1-function-indexed-child-nodes node)
+ :reverse t))
+
+(defmethod map-index-leaf-nodes (cc (node path-index-internal-node2) revpath)
+ (let ((iinodes (path-index-internal-node2-integer-indexed-child-nodes node)))
+ (dotimes (i (array-dimension iinodes 0))
+ (let ((v (svref iinodes i)))
+ (when v
+ (map-index-leaf-nodes cc v (cons i revpath)))))))
+
+(defmethod map-index-leaf-nodes (cc (node path-index-leaf-node) revpath)
+ (funcall cc node revpath))
+
+(defun print-revpath (revpath)
+ (princ "[")
+ (dolist (x (reverse (rest revpath)))
+ (cond
+ ((function-symbol-p x)
+ (prin1 x))
+ (t
+ (cl:assert (integerp x))
+ (cond
+ ((< x 0)
+ (princ "list")
+ (princ (- x)))
+ (t
+ (princ "arg")
+ (princ (+ x 1))))))
+ (princ ","))
+ (prin1 (first revpath) *standard-output*)
+ (princ "]"))
+
+(defun path-index-key-for-value (value table)
+ (map-sparse-vector-with-indexes
+ (lambda (v k)
+ (when (eq value v)
+ (return-from path-index-key-for-value (symbol-numbered k))))
+ table))
+
+(defun path-index-node-revpath (node)
+ (let ((parent-node (path-index-node-parent-node node)))
+ (cond
+ ((path-index-internal-node1-p parent-node)
+ (cons (or (if (eq node (path-index-internal-node1-variable-child-node parent-node)) "variable" nil)
+ (path-index-key-for-value node (path-index-internal-node1-function-indexed-child-nodes parent-node))
+ (path-index-key-for-value node (path-index-internal-node1-constant-indexed-child-nodes parent-node)))
+ (path-index-node-revpath parent-node)))
+ ((path-index-internal-node2-p parent-node)
+ (cons (position node (path-index-internal-node2-integer-indexed-child-nodes parent-node))
+ (path-index-node-revpath parent-node)))
+ (t
+ nil))))
+
+(defun print-path-index-query (query &key terms)
+ (cond
+ ((or (null query) (eq t query))
+ (terpri-comment-indent)
+ (princ query))
+ ((and (consp query) (eq 'intersection (first query)))
+ (terpri-comment-indent)
+ (princ "(intersection")
+ (let ((*terpri-indent* (+ *terpri-indent* 3)))
+ (mapc (lambda (q) (print-path-index-query q :terms terms)) (rest query)))
+ (princ ")"))
+ ((and (consp query) (eq 'union (first query)))
+ (terpri-comment-indent)
+ (princ "(union")
+ (let ((*terpri-indent* (+ *terpri-indent* 3)))
+ (mapc (lambda (q) (print-path-index-query q :terms terms)) (rest query)))
+ (princ ")"))
+ ((and (consp query) (eq 'uniond (first query)))
+ (terpri-comment-indent)
+ (princ "(uniond")
+ (let ((*terpri-indent* (+ *terpri-indent* 3)))
+ (mapc (lambda (q) (print-path-index-query q :terms terms)) (rest query)))
+ (princ ")"))
+ ((path-index-leaf-node-p query)
+ (print-index* query (path-index-node-revpath query) terms))
+ (t
+ (terpri-comment-indent)
+ (let ((revpath (path-index-node-revpath query)))
+ (princ "(all-entries ")
+ (print-revpath (cons "..." revpath))
+;; (let ((*terpri-indent* (+ *terpri-indent* 3)))
+;; (print-path-index* query revpath terms))
+ (princ ")"))))
+ nil)
+
+;;; path-index.lisp EOF
diff --git a/snark-20120808r02/src/pattern-match.abcl b/snark-20120808r02/src/pattern-match.abcl
new file mode 100644
index 0000000..7dd2d27
Binary files /dev/null and b/snark-20120808r02/src/pattern-match.abcl differ
diff --git a/snark-20120808r02/src/pattern-match.lisp b/snark-20120808r02/src/pattern-match.lisp
new file mode 100644
index 0000000..efeb6fb
--- /dev/null
+++ b/snark-20120808r02/src/pattern-match.lisp
@@ -0,0 +1,45 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
+;;; File: pattern-match.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-lisp)
+
+(defun pattern-match (pat expr &optional alist)
+ ;; matches pat to expr creating bindings in alist for ?vars in pat
+ ;; sublis can be used to make instances of other expressions that contain ?vars
+ ;; (nil) is used as value for successful match with no bindings
+ (cond
+ ((consp pat)
+ (and (consp expr)
+ (setf alist (pattern-match (car pat) (car expr) alist))
+ (pattern-match (cdr pat) (cdr expr) alist)))
+ ((and pat (symbolp pat) (eql #\? (char (symbol-name pat) 0)))
+ (cond
+ ((null (first alist))
+ (acons pat expr nil))
+ (t
+ (let ((v (assoc pat alist)))
+ (if v
+ (if (equal (cdr v) expr) alist nil)
+ (acons pat expr alist))))))
+ ((eql pat expr)
+ (or alist '(nil)))
+ (t
+ nil)))
+
+;;; pattern-match.lisp EOF
diff --git a/snark-20120808r02/src/posets.abcl b/snark-20120808r02/src/posets.abcl
new file mode 100644
index 0000000..6a02a06
Binary files /dev/null and b/snark-20120808r02/src/posets.abcl differ
diff --git a/snark-20120808r02/src/posets.lisp b/snark-20120808r02/src/posets.lisp
new file mode 100644
index 0000000..42dc63a
--- /dev/null
+++ b/snark-20120808r02/src/posets.lisp
@@ -0,0 +1,69 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: posets.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2005.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; notes:
+;;; integers are used as elements so that sparse-arrays can be used
+
+(defun make-poset (&rest args)
+ (declare (ignore args))
+ (make-sparse-matrix :boolean t))
+
+(definline poset-greaterp (poset x y)
+ (and (not (eql x y))
+ (sparef poset x y)))
+
+(definline poset-lessp (poset x y)
+ (and (not (eql x y))
+ (sparef poset y x)))
+
+(defun poset-equivalent (poset x y)
+ (declare (ignorable poset))
+ (or (eql x y)
+ (unimplemented)))
+
+(defun declare-poset-greaterp (poset x y)
+ (add-edge-transitively poset x y))
+
+(defun declare-poset-lessp (poset x y)
+ (add-edge-transitively poset y x))
+
+(defun poset-superiors (poset element)
+ (setf (sparse-matrix-column poset element) t))
+
+(defun poset-inferiors (poset element)
+ (setf (sparse-matrix-row poset element) t))
+
+(defun add-edge-transitively (graph vertex1 vertex2)
+ (let ((l1 (list vertex1))
+ (l2 (list vertex2)))
+ (let ((col (sparse-matrix-column graph vertex1)))
+ (when col (map-sparse-vector (lambda (vertex) (push vertex l1)) col)))
+ (let ((row (sparse-matrix-row graph vertex2)))
+ (when row (map-sparse-vector (lambda (vertex) (push vertex l2)) row)))
+ (dolist (v1 l1)
+ (dolist (v2 l2)
+ (cond
+ ((eql v1 v2)
+ (error "Trying to define node ~A > node ~A in ordering relation." v1 v2))
+ (t
+ (setf (sparef graph v1 v2) t)))))))
+
+;;; posets.lisp EOF
diff --git a/snark-20120808r02/src/progc.abcl b/snark-20120808r02/src/progc.abcl
new file mode 100644
index 0000000..2409bfb
Binary files /dev/null and b/snark-20120808r02/src/progc.abcl differ
diff --git a/snark-20120808r02/src/progc.lisp b/snark-20120808r02/src/progc.lisp
new file mode 100644
index 0000000..d208187
--- /dev/null
+++ b/snark-20120808r02/src/progc.lisp
@@ -0,0 +1,288 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
+;;; File: progc.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-lisp)
+
+(defparameter *prog->-function-second-forms*
+ '(funcall apply map map-into))
+
+(defparameter *prog->-special-forms*
+ '(
+;; (pattern . forms)
+
+ ((dolist list-form &rest l ->* var)
+ (dolist (var list-form . l)
+ (unnamed-prog-> . prog->-tail)))
+ ((dotails list-form &rest l ->* var)
+ (dotails (var list-form . l)
+ (unnamed-prog-> . prog->-tail)))
+ ((dopairs list-form &rest l ->* var1 var2)
+ (dopairs (var1 var2 list-form . l)
+ (unnamed-prog-> . prog->-tail)))
+ ((dotimes count-form &rest l ->* var)
+ (dotimes (var count-form . l)
+ (unnamed-prog-> . prog->-tail)))
+ ((identity form -> var)
+ (let ((var form))
+ (unnamed-prog-> . prog->-tail)))
+ ))
+
+(defun prog->*-function-second-form-p (fn)
+ (member fn *prog->-function-second-forms*))
+
+(defun prog->-special-form (fn)
+ (assoc fn *prog->-special-forms* :key #'first))
+
+(defun prog->-special-form-pattern (fn)
+ (car (prog->-special-form fn)))
+
+(defun prog->-special-form-args (fn)
+ (rest (prog->-special-form-pattern fn)))
+
+(defun prog->-special-form-result (fn)
+ (cdr (prog->-special-form fn)))
+
+(defun prog->-special-form-match-error (form)
+ (error "~S doesn't match prog-> special form ~S."
+ form (prog->-special-form-pattern (first form))))
+
+(defun prog->-no-variable-error (form)
+ (error "No variable to assign value to in (prog-> ... ~S ...)."
+ form))
+
+(defun prog->-too-many-variables-error (form)
+ (error "More than one variable to assign value to in (prog-> ... ~S ...)." form))
+
+(defun prog->-too-many->s-error (form)
+ (error "More than one -> in (prog-> ... ~S ...)." form))
+
+(defun prog->-unrecognized->-atom (atom form)
+ (error "Unrecognized operation ~S in (prog-> ... ~S ...)." atom form))
+
+(defun prog->-atom (x)
+ (and (symbolp x)
+ (<= 2 (length (string x)))
+ (string= x "->" :end1 2)))
+
+(defun prog->*-function-argument (forms args)
+ (cond
+ ((and (null (rest forms))
+ (consp (first forms))
+ (eq (caar forms) 'funcall)
+ (equal (cddar forms) args))
+ (cadar forms))
+ ((and (null (rest forms))
+ (consp (first forms))
+ (not (#-(or lucid (and mcl (not openmcl))) special-operator-p
+;; #-(or allegro lucid) special-form-p
+;; #+allegro cltl1:special-form-p
+ #+(and mcl (not openmcl)) special-form-p
+ #+lucid lisp:special-form-p
+ (caar forms)))
+ (not (macro-function (caar forms)))
+ (equal (cdar forms) args))
+ `(function ,(caar forms)))
+ (t
+ `(function (lambda ,args ,@forms)))))
+
+(defun process-prog-> (forms)
+ (cond
+ ((null forms)
+ nil)
+ (t
+ (let ((form (first forms)))
+ (cond
+ ((not (consp form))
+ (cons form (process-prog-> (rest forms))))
+ (t
+ (let* ((args (rest form))
+ (x (member-if #'prog->-atom args)))
+ (cond
+ ((null x)
+ (cons (case (first form) ;forms with explicit or implicit progn also get prog-> processing
+ ((progn)
+ (process-prog->-progn (rest form)))
+ ((block when unless let let* mvlet mvlet* catch)
+ (list* (first form)
+ (second form)
+ (process-prog-> (cddr form))))
+ ((multiple-value-bind progv)
+ (list* (first form)
+ (second form)
+ (third form)
+ (process-prog-> (cdddr form))))
+ ((cond)
+ (cons (first form)
+ (mapcar (lambda (x)
+ (cons (first x)
+ (process-prog-> (rest x))))
+ (rest form))))
+ ((case ecase ccase typecase etypecase ctypecase)
+ (list* (first form)
+ (second form)
+ (mapcar (lambda (x)
+ (cons (first x)
+ (process-prog-> (rest x))))
+ (cddr form))))
+ ((if)
+ (cl:assert (<= 3 (length form) 4))
+ (list (first form)
+ (second form)
+ (process-prog->-progn (list (third form)))
+ (process-prog->-progn (list (fourth form)))))
+ (otherwise
+ form))
+ (process-prog-> (rest forms))))
+ ((prog->-special-form (first form))
+ (do ((formals (prog->-special-form-args (first form)) (rest formals))
+ (args args (rest args))
+ (alist (acons 'prog->-tail (rest forms) nil)))
+ (nil)
+ (cond
+ ((and (endp formals) (endp args))
+ (return (sublis alist (prog->-special-form-result (first form)))))
+ ((endp formals)
+ (prog->-special-form-match-error form))
+ ((eq (first formals) '&rest)
+ (setf formals (rest formals))
+ (cond
+ ((or (endp args) (prog->-atom (first args)))
+ (setf args (cons nil args))
+ (setf alist (acons (first formals) nil alist)))
+ (t
+ (setf alist (acons (first formals)
+ (loop collect (first args)
+ until (or (endp (rest args)) (prog->-atom (second args)))
+ do (pop args))
+ alist)))))
+ ((endp args)
+ (prog->-special-form-match-error form))
+ ((prog->-atom (first formals))
+ (unless (string= (string (first formals)) (string (first args)))
+ (prog->-special-form-match-error form)))
+ (t
+ (setf alist (acons (first formals) (first args) alist))))))
+ ((member-if #'prog->-atom (rest x))
+ (prog->-too-many->s-error form))
+ (t
+ (let ((inputs (ldiff args x))
+ (outputs (rest x)))
+ (cond
+ ((string= (string (first x)) "->*")
+ (let ((funarg (prog->*-function-argument (process-prog-> (rest forms)) outputs)))
+ (cond
+ ((and (consp funarg)
+ (eq 'function (first funarg))
+ (consp (second funarg))
+ (eq 'lambda (first (second funarg))))
+ (let ((g (gensym)))
+ (list
+ `(flet ((,g ,@(rest (second funarg))))
+ (declare (dynamic-extent (function ,g)))
+ ,@(prog->*-call form inputs `(function ,g))))))
+ (t
+ (prog->*-call form inputs funarg)))))
+ ((null outputs)
+ (prog->-no-variable-error form))
+ ((string= (string (first x)) "->")
+ (cond
+ ((null (rest outputs))
+ (cond
+ ((and (consp (first outputs))
+ (member (first (first outputs)) '(values list list* :values :list :list*)))
+ (list `(mvlet ((,(first outputs) (,(first form) ,@inputs)))
+ ,@(process-prog-> (rest forms)))))
+ (t
+ (list `(let ((,(first outputs) (,(first form) ,@inputs)))
+ ,@(process-prog-> (rest forms)))))))
+ (t
+ (list `(multiple-value-bind ,outputs
+ (,(first form) ,@inputs)
+ ,@(process-prog-> (rest forms)))))))
+ ((string= (string (first x)) (symbol-name :->nonnil))
+ (cond
+ ((null (rest outputs))
+ (cond
+ ((and (consp (first outputs))
+ (member (first (first outputs)) '(values list list* :values :list :list*)))
+ (list `(mvlet ((,(first outputs) (,(first form) ,@inputs)))
+ (when ,(first outputs)
+ ,@(process-prog-> (rest forms))))))
+ (t
+ (list `(let ((,(first outputs) (,(first form) ,@inputs)))
+ (when ,(first outputs)
+ ,@(process-prog-> (rest forms))))))))
+ (t
+ (list `(multiple-value-bind ,outputs
+ (,(first form) ,@inputs)
+ (when ,(first outputs)
+ ,@(process-prog-> (rest forms))))))))
+ ((rest outputs)
+ (prog->-too-many-variables-error form))
+ ((string= (string (first x)) (symbol-name :->stack))
+ (list `(let ((,(first outputs) (,(first form) ,@inputs)))
+ (declare (dynamic-extent ,(first outputs)))
+ ,@(process-prog-> (rest forms)))))
+ ((string= (string (first x)) (symbol-name :->progv))
+ (list `(let ((!prog->temp1! (list (,(first form) ,@inputs)))
+ (!prog->temp2! (list ,(first outputs))))
+ (declare (dynamic-extent !prog->temp1! !prog->temp2!))
+ (progv !prog->temp2! !prog->temp1! ,@(process-prog-> (rest forms))))))
+ (t
+ (prog->-unrecognized->-atom (first x) form)))))))))))))
+
+(defun prog->*-call (form inputs funarg)
+ (cond
+ ((prog->*-function-second-form-p (first form))
+ (list `(,(first form) ,(first inputs) ,funarg ,@(rest inputs))))
+ (t
+ (list `(,(first form) ,funarg ,@inputs)))))
+
+(defun wrap-progn (forms &optional no-simplification)
+ (cond
+ ((and (null forms)
+ (not no-simplification))
+ nil)
+ ((and (null (rest forms))
+ (not no-simplification))
+ (first forms))
+ (t
+ (cons 'progn forms))))
+
+(defun wrap-block (name forms &optional no-simplification)
+ (cond
+ ((and (null forms)
+ (not no-simplification))
+ nil)
+ (t
+ (list* 'block name forms))))
+
+(defun process-prog->-progn (forms)
+ (wrap-progn (process-prog-> forms)))
+
+(defun process-prog->-block (forms)
+ (wrap-block 'prog-> (process-prog-> forms)))
+
+(defmacro unnamed-prog-> (&body forms)
+ (process-prog->-progn forms))
+
+(defmacro prog-> (&body forms)
+ (process-prog->-block forms))
+
+;;; progc.lisp EOF
diff --git a/snark-20120808r02/src/recursive-path-ordering.abcl b/snark-20120808r02/src/recursive-path-ordering.abcl
new file mode 100644
index 0000000..18f0bc6
Binary files /dev/null and b/snark-20120808r02/src/recursive-path-ordering.abcl differ
diff --git a/snark-20120808r02/src/recursive-path-ordering.lisp b/snark-20120808r02/src/recursive-path-ordering.lisp
new file mode 100644
index 0000000..831a73d
--- /dev/null
+++ b/snark-20120808r02/src/recursive-path-ordering.lisp
@@ -0,0 +1,292 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: recursive-path-ordering.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defvar *rpo-cache*)
+(defvar *rpo-cache-numbering*)
+(defvar *ac-rpo-cache*)
+
+(defun rpo-compare-terms-top (x y &optional subst testval)
+ (let ((*rpo-cache* nil)
+ (*rpo-cache-numbering* nil)
+ (*ac-rpo-cache* nil))
+ (rpo-compare-terms x y subst testval)))
+
+(defun rpo-cache-lookup (x y)
+ (and *rpo-cache*
+ (let ((x# (funcall *rpo-cache-numbering* :lookup x))
+ (y# (funcall *rpo-cache-numbering* :lookup y)))
+ (sparef *rpo-cache* x# y#))))
+
+(defun rpo-cache-store (x y com)
+ (when com
+ (unless *rpo-cache*
+ (setf *rpo-cache* (make-sparse-vector))
+ (setf *rpo-cache-numbering* (make-numbering)))
+ (let ((x# (funcall *rpo-cache-numbering* :lookup x))
+ (y# (funcall *rpo-cache-numbering* :lookup y)))
+ (setf (sparef *rpo-cache* x# y#) com))))
+
+(definline rpo-compare-variable*compound (x y subst testval)
+ (and (or (null testval) (eq '< testval)) (if (variable-occurs-p x y subst) '< '?)))
+
+(definline rpo-compare-compound*variable (x y subst testval)
+ (and (or (null testval) (eq '> testval)) (if (variable-occurs-p y x subst) '> '?)))
+
+(defun rpo-compare-terms (x y &optional subst testval)
+ (cond
+ ((eql x y)
+ '=)
+ (t
+ (dereference2
+ x y subst
+ :if-variable*variable (if (eq x y) '= '?)
+ :if-variable*constant '?
+ :if-constant*variable '?
+ :if-variable*compound (rpo-compare-variable*compound x y subst testval)
+ :if-compound*variable (rpo-compare-compound*variable x y subst testval)
+ :if-constant*constant (symbol-ordering-compare x y)
+ :if-compound*constant (and (neq '= testval) (rpo-compare-compound*constant x y subst testval))
+ :if-constant*compound (and (neq '= testval) (rpo-compare-constant*compound x y subst testval))
+ :if-compound*compound (rpo-compare-compounds x y subst testval)))))
+
+(defun rpo-compare-compound*constant (compound constant subst testval)
+ ;; for a constant to be bigger than a compound,
+ ;; constant must be bigger than every constant/function symbol in compound
+ ;; and compound must be ground
+ ;;
+ ;; for a constant to be less than a compound,
+ ;; constant must be smaller than or identical to some constant/function symbol in compound
+ (let ((can-be-< t))
+ (labels
+ ((compare-with-term (term)
+ (dereference
+ term subst
+ :if-variable (if (eq '< testval) (return-from rpo-compare-compound*constant nil) (setf can-be-< nil))
+ :if-constant (ecase (symbol-ordering-compare term constant)
+ ((> =)
+ (return-from rpo-compare-compound*constant '>))
+ (?
+ (if (eq '< testval) (return-from rpo-compare-compound*constant nil) (setf can-be-< nil)))
+ (<
+ ))
+ :if-compound (progn
+ (ecase (symbol-ordering-compare (head term) constant)
+ (>
+ (return-from rpo-compare-compound*constant '>))
+ (?
+ (if (eq '< testval) (return-from rpo-compare-compound*constant nil) (setf can-be-< nil)))
+ (<
+ ))
+ (dolist (arg (args term))
+ (compare-with-term arg))))))
+ (let ((head (head compound)))
+ (cond
+ ((function-boolean-valued-p head)
+ (return-from rpo-compare-compound*constant
+ (if (constant-boolean-valued-p constant)
+ (if (ordering-functions>constants?) '> (symbol-ordering-compare head constant)) ;no subterm comparisons
+ '>))) ;atom > term
+ ((constant-boolean-valued-p constant)
+ (return-from rpo-compare-compound*constant '<)) ;term < atom
+ ((ordering-functions>constants?)
+ '>)
+ (t
+ (ecase (symbol-ordering-compare head constant)
+ (>
+ (return-from rpo-compare-compound*constant '>))
+ (?
+ (if (eq '< testval) (return-from rpo-compare-compound*constant nil) (setf can-be-< nil)))
+ (<
+ ))
+ (dolist (arg (args compound))
+ (compare-with-term arg))
+ (if can-be-< '< '?)))))))
+
+(defun rpo-compare-constant*compound (constant compound subst testval)
+ (opposite-order (rpo-compare-compound*constant compound constant subst (opposite-order testval))))
+
+(defun rpo-compare-compounds (x y subst testval)
+ (cond
+ ((eq x y)
+ '=)
+ ((test-option19?)
+ (rpo-compare-compounds0 x y subst testval))
+ (t
+ (ecase testval
+ (>
+ (and (implies (test-option20?) (no-new-variable-occurs-p y subst (variables x subst)))
+ (rpo-compare-compounds0 x y subst '>)))
+ (<
+ (and (implies (test-option20?) (no-new-variable-occurs-p x subst (variables y subst)))
+ (rpo-compare-compounds0 x y subst '<)))
+ (=
+ (let ((xvars (variables x subst))
+ (yvars (variables y subst)))
+ (and (length= xvars yvars)
+ (dolist (v xvars t)
+ (unless (member v yvars :test #'eq)
+ (return nil)))
+ (rpo-compare-compounds0 x y subst '=))))
+ ((nil)
+ (let ((xvars (variables x subst))
+ (yvars (variables y subst)))
+ (dolist (v xvars)
+ (unless (member v yvars :test #'eq)
+ (setf testval '>)
+ (return)))
+ (dolist (v yvars)
+ (unless (member v xvars :test #'eq)
+ (cond
+ ((null testval)
+ (setf testval '<)
+ (return))
+ (t
+ (return-from rpo-compare-compounds '?))))))
+ (let ((v (rpo-compare-compounds0 x y subst testval)))
+ (if (or (null testval) (eq testval v)) v '?)))))))
+
+(defun rpo-compare-compounds0 (x y subst testval)
+ (let ((fn (head x)))
+ (ecase (symbol-ordering-compare fn (head y))
+ (=
+ (case (function-arity fn)
+ (1
+ (rpo-compare-terms (arg1 x) (arg1 y) subst testval))
+ (otherwise
+ (let ((status (function-rpo-status fn)))
+ (ecase status
+ (:left-to-right
+ (rpo-compare-lists x y (args x) (args y) subst testval))
+ (:right-to-left
+ (rpo-compare-lists x y (reverse (args x)) (reverse (args y)) subst testval))
+ ((:commutative :multiset)
+ (let ((xargs (args x))
+ (yargs (args y)))
+ (cond
+ ((and (eq :commutative status) (or (rrest xargs) (rrest yargs)))
+ (rpo-compare-terms (make-compound* *a-function-with-left-to-right-ordering-status*
+ (make-compound *a-function-with-multiset-ordering-status* (first xargs) (second xargs))
+ (rrest xargs))
+ (make-compound* *a-function-with-left-to-right-ordering-status*
+ (make-compound *a-function-with-multiset-ordering-status* (first yargs) (second yargs))
+ (rrest yargs))
+ subst
+ testval))
+ (t
+ (compare-term-multisets #'rpo-compare-terms xargs yargs subst testval)))))
+ (:ac
+ (with-clock-on ordering-ac
+ (ac-rpo-compare-compounds fn (flatargs x subst) (flatargs y subst) subst)))
+ ((:none)
+ ;; (unimplemented)
+ (cond
+ ((equal-p x y subst)
+ '=)
+ (t
+ '?))))))))
+ (>
+ (and (neq '= testval) (rpo-compare-compounds> x (flatargs y subst) subst testval)))
+ (<
+ (and (neq '= testval) (rpo-compare-compounds< (flatargs x subst) y subst testval)))
+ (?
+ (and (neq '= testval) (rpo-compare-compounds? x y (flatargs x subst) (flatargs y subst) subst testval))))))
+
+(defun rpo-compare-lists (x y xargs yargs subst testval)
+ (let (xarg yarg)
+ (loop
+ (cond
+ ((null xargs)
+ (return (if (null yargs) '= '<)))
+ ((null yargs)
+ (return '>))
+ ((eql (setf xarg (pop xargs)) (setf yarg (pop yargs)))
+ )
+ (t
+ (ecase (rpo-compare-terms xarg yarg subst nil)
+ (>
+ (return (and (neq '= testval) (rpo-compare-compounds> x yargs subst testval))))
+ (<
+ (return (and (neq '= testval) (rpo-compare-compounds< xargs y subst testval))))
+ (?
+ (return (and (neq '= testval) (rpo-compare-compounds? x y xargs yargs subst testval))))
+ (=
+ )))))))
+
+(defun rpo-compare-compounds> (x yargs subst testval)
+ (if (or (null yargs) (function-boolean-valued-p (head x)))
+ '>
+ (let ((can-be-> t))
+ (dolist (yarg yargs (if can-be-> '> '?))
+ (ecase (rpo-compare-terms x yarg subst nil)
+ (?
+ (if (eq '> testval) (return nil) (setf can-be-> nil)))
+ ((< =)
+ (return '<))
+ (>
+ ))))))
+
+(defun rpo-compare-compounds< (xargs y subst testval)
+ (if (or (null xargs) (function-boolean-valued-p (head y)))
+ '<
+ (let ((can-be-< t))
+ (dolist (xarg xargs (if can-be-< '< '?))
+ (ecase (rpo-compare-terms xarg y subst nil)
+ (?
+ (if (eq '< testval) (return nil) (setf can-be-< nil)))
+ ((> =)
+ (return '>))
+ (<
+ ))))))
+
+(defun rpo-compare-compounds? (x y xargs yargs subst testval)
+ (cond
+ ((and (or (null testval) (eq '> testval)) (thereis-rpo-equal-or-greaterp xargs y subst))
+ '>)
+ ((and (or (null testval) (eq '< testval)) (thereis-rpo-equal-or-greaterp yargs x subst))
+ '<)
+ ((null testval)
+ '?)))
+
+(defun thereis-rpo-equal-or-greaterp (args term subst)
+ (and (not (function-boolean-valued-p (head term)))
+ (dolist (arg args nil)
+ (dereference
+ arg subst
+ :if-constant (when (eq '< (rpo-compare-compound*constant term arg subst '<))
+ (return t))
+ :if-compound (case (rpo-compare-compounds arg term subst '>)
+ ((> =) ;= should be returned if they're equal even if testval is >
+ (return t)))))))
+
+(defun rpo-compare-alists (alist1 alist2 subst testval)
+ ;; this should be specialized for better performance
+ (labels
+ ((rpo-alist-args (alist)
+ (dereference
+ alist subst
+ :if-variable (list alist)
+ :if-constant nil
+ :if-compound (lcons (first alist)
+ (rpo-alist-args (rest alist))
+ alist))))
+ (compare-term-multisets #'rpo-compare-terms (rpo-alist-args alist1) (rpo-alist-args alist2) subst testval)))
+
+;;; recursive-path-ordering.lisp EOF
diff --git a/snark-20120808r02/src/resolve-code-tables.abcl b/snark-20120808r02/src/resolve-code-tables.abcl
new file mode 100644
index 0000000..12b7a8f
Binary files /dev/null and b/snark-20120808r02/src/resolve-code-tables.abcl differ
diff --git a/snark-20120808r02/src/resolve-code-tables.lisp b/snark-20120808r02/src/resolve-code-tables.lisp
new file mode 100644
index 0000000..798456b
--- /dev/null
+++ b/snark-20120808r02/src/resolve-code-tables.lisp
@@ -0,0 +1,154 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: resolve-code-tables.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2006.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun table-satisfier (cc atom subst)
+ ;; enables procedural attachment of a table to a relation
+ (let* ((args (args atom))
+ (pattern (table-lookup-pattern args subst)))
+ (cond
+ ((eq none pattern)
+ ) ;inapplicable
+ (t
+ (prog->
+ (predicate-to-table (function-name (head atom)) -> table mapper exporters)
+ (funcall mapper table exporters pattern subst ->* subst)
+ (funcall cc subst))))))
+
+(defun table-rewriter (atom subst)
+ ;; assume completeness of table to return false
+ (let* ((args (args atom))
+ (pattern (table-lookup-pattern args subst)))
+ (cond
+ ((eq none pattern)
+ none) ;inapplicable
+ ((ground-p pattern)
+ (prog->
+ (predicate-to-table (function-name (head atom)) -> table mapper exporters)
+ (funcall mapper table exporters pattern nil ->* subst)
+ (declare (ignore subst))
+ (return-from table-rewriter true)) ;true if in table
+ (dolist (x pattern)
+ (unless (constant-constructor x)
+ (return-from table-rewriter none))) ;don't rewrite if args aren't constructors
+ false) ;false if not in table
+ (t
+ (dolist (x pattern)
+ (unless (or (variable-p x) (constant-constructor x))
+ (return-from table-rewriter none))) ;don't rewrite if args aren't constructors
+ (prog->
+ (predicate-to-table (function-name (head atom)) -> table mapper exporters)
+ (quote nil -> *frozen-variables*)
+ (funcall mapper table exporters pattern nil ->* subst)
+ (declare (ignore subst))
+ (return-from table-rewriter none)) ;don't rewrite if an instance exists
+ false)))) ;false if there are no instances
+
+(defun table-lookup-pattern (args subst)
+ (mapcar
+ (lambda (arg)
+ (dereference
+ arg subst
+ :if-compound (return-from table-lookup-pattern none) ;inapplicable
+ :if-variable arg
+ :if-constant arg))
+ args))
+
+(defun simple-table-mapper (cc table exporters pattern subst)
+ ;; this mapper function just does linear search of the table
+ (let ((revvars nil))
+ (dolist (x pattern)
+ (when (variable-p x)
+ (push x revvars)))
+ (dolist (row table)
+ (do ((r row (rest r))
+ (p pattern (rest p)))
+ ((or (null r) (null p))
+ (when (and (null r) (null p))
+ (do ((r row (rest r))
+ (p pattern (rest p))
+ (e exporters (rest e))
+ (revvals nil))
+ ((null r)
+ (unify cc revvars revvals subst))
+ (when (variable-p (first p))
+ (push (if (first e)
+ (funcall (first e) (first r))
+ (declare-constant (first r)))
+ revvals)))))
+ (unless (or (equal (first r) (first p)) (variable-p (first p)))
+ (return))))
+ nil))
+
+(defun predicate-to-table (p)
+ (relation-to-table p))
+
+(defun relation-to-table (p)
+ ;; return table for relation p (could be filename or some other way to refer to a file),
+ ;; a mapper function (finds tuples in the table that match the pattern),
+ ;; and an export function for each column
+ (case p
+ ;; supervises example
+ ;; (in package SNARK-USER so it's largely invisible except for running the example)
+ (snark-user::supervises
+ (values '(("perrault" "lowrance")
+ ("lowrance" "stickel")
+ ("lowrance" "waldinger"))
+ 'simple-table-mapper
+ (consn (lambda (x) (declare-constant x :sort 'person)) nil 2)))
+ ))
+
+(defun test-table-resolver (&optional (test 1))
+ (initialize)
+ (use-resolution)
+ (declare-sort 'person)
+ (declare-relation
+ 'snark-user::supervises 2
+ :satisfy-code 'table-satisfier
+ :rewrite-code 'table-rewriter)
+ (declare-constant "lowrance" :sort 'person)
+ (declare-constant "stickel" :sort 'person)
+ (declare-constant 'stickel :sort 'person)
+ (ecase test
+ (1
+ (prove '(snark-user::supervises "lowrance" "stickel")))
+ (2
+ (prove '(snark-user::supervises "lowrance" ?person) :answer '(values ?person)))
+ (3
+ (prove '(snark-user::supervises ?person "stickel") :answer '(values ?person)))
+ (4
+ (prove '(snark-user::supervises ?person1 ?person2) :answer '(values ?person1 ?person2)))
+ (5
+ (prove '(not (snark-user::supervises "stickel" "perrault"))))
+ (6
+ (prove '(not (snark-user::supervises "stickel" ?person)) :answer '(values ?person)))
+ (7
+ ;; should fail (stickel isn't constructor)
+ (prove '(not (snark-user::supervises stickel "perrault"))))
+ (8
+ ;; should fail (stickel isn't constructor)
+ (prove '(not (snark-user::supervises stickel ?person))))
+ )
+ (loop
+ (when (eq :agenda-empty (closure))
+ (return)))
+ (print-rows))
+
+;;; resolve-code-tables.lisp EOF
diff --git a/snark-20120808r02/src/resolve-code.abcl b/snark-20120808r02/src/resolve-code.abcl
new file mode 100644
index 0000000..c6aeb9b
Binary files /dev/null and b/snark-20120808r02/src/resolve-code.abcl differ
diff --git a/snark-20120808r02/src/resolve-code.lisp b/snark-20120808r02/src/resolve-code.lisp
new file mode 100644
index 0000000..f1c76ed
--- /dev/null
+++ b/snark-20120808r02/src/resolve-code.lisp
@@ -0,0 +1,193 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: resolve-code.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun reflexivity-satisfier (cc atom subst)
+ ;; example: this is called when trying to resolve away (not (rel a b)) after
+ ;; doing (declare-relation 'rel 2 :satisfy-code 'reflexivity-satisfier)
+ ;; (rel a b) -> true after unifying a and b
+ (mvlet (((list a b) (args atom)))
+ (unify cc a b subst))) ;call cc with resulting substitutions
+
+(defun irreflexivity-falsifier (cc atom subst)
+ (reflexivity-satisfier cc atom subst))
+
+(defun constructor-reflexivity-satisfier (cc atom subst)
+ (mvlet (((list a b) (args atom)))
+ (when (or (constructor-term-p a subst) (constructor-term-p b subst))
+ (unify cc a b subst))))
+
+(defun constructor-irreflexivity-falsifier (cc atom subst)
+ (constructor-reflexivity-satisfier cc atom subst))
+
+(defun variables-reflexivity-satisfier (cc atom subst)
+ (mvlet (((list a b) (args atom)))
+ (when (and (dereference a subst :if-variable t) (dereference b subst :if-variable t))
+ (unify cc a b subst))))
+
+(defun variables-irreflexivity-falsifier (cc atom subst)
+ (variables-reflexivity-satisfier cc atom subst))
+
+(defun variable-satisfier (cc atom subst)
+ (let ((x (arg1 atom)))
+ (dereference
+ x subst
+ :if-variable (funcall cc subst))))
+
+(defun nonvariable-satisfier (cc atom subst)
+ (let ((x (arg1 atom)))
+ (dereference
+ x subst
+ :if-constant (funcall cc subst)
+ :if-compound (funcall cc subst))))
+
+(defun resolve-code-example1 (&optional (case 1))
+ (let ((mother-table (print '((alice betty)
+ (alice barbara)
+ (betty carol)
+ (betty claudia)))))
+ (flet ((mother-satisfier (cc atom subst)
+ ;; the two definitions below are equivalent
+ #+ignore
+ (let ((args (args atom)))
+ (mapc (lambda (pair) (unify cc args pair subst))
+ mother-table))
+ (prog->
+ (args atom -> args)
+ (mapc mother-table ->* pair)
+ (unify args pair subst ->* subst2)
+ (funcall cc subst2))))
+ (initialize)
+ (print-options-when-starting nil)
+ (print-rows-when-derived nil)
+ (print-summary-when-finished nil)
+ (case case
+ (1
+ (use-resolution t))
+ (2
+ (use-hyperresolution t))
+ (3
+ (use-negative-hyperresolution t)))
+ (declare-relation 'mother 2 :satisfy-code #'mother-satisfier)
+ (prove '(mother betty ?x) :answer '(values ?x) :name 'who-is-bettys-child?)
+ (loop
+ (when (eq :agenda-empty (closure))
+ (return)))
+ (mapcar (lambda (x) (arg1 x)) (answers)))))
+
+(defun resolve-code-example2 (&optional (case 1))
+ ;; silly example to illustrate satisfy/falsify code with residue
+ ;; suppose (* a b c) means a*b=c
+ ;; then use satisfy code with residue for the following resolution operations
+ ;; (not (* ?x a b)) -> (not (= a b)) with {?x <- 1}
+ ;; (not (* a ?x b)) -> (not (= a b)) with {?x <- 1}
+ (initialize)
+ (declare-constant 1)
+ (declare-relation '* 3 :satisfy-code 'resolve-code-example2-satisfier)
+ (case case
+ (1
+ (use-resolution t)
+ (prove '(and (not (p ?x ?y ?z)) (* ?x a b) (* c ?y d) (* e ?z ?z)))) ;nucleus
+ (2
+ (use-hyperresolution t)
+ (prove '(and (not (p ?x ?y ?z)) (* ?x a b) (* c ?y d) (* e ?z ?z)))) ;nucleus
+ (3
+ (use-negative-hyperresolution t)
+ (prove '(* ?x a b))) ;electron
+ (4
+ (use-ur-resolution t)
+ (prove '(and (not (p ?x ?y ?z)) (* ?x a b) (* c ?y d) (* e ?z ?z)))) ;nucleus
+ ))
+
+(defun resolve-code-example2-satisfier (cc atom subst)
+ (prog->
+ (args atom -> args)
+ (unify 1 (first args) subst ->* subst)
+ (funcall cc subst (make-compound *not* (make-compound *=* (second args) (third args)))))
+ (prog->
+ (args atom -> args)
+ (unify 1 (second args) subst ->* subst)
+ (funcall cc subst (make-compound *not* (make-compound *=* (first args) (third args))))))
+
+(define-plist-slot-accessor function :resolve-code-satisfy-code)
+(define-plist-slot-accessor function :resolve-code-falsify-code)
+
+(defun resolve-code-resolver1 (cc wff subst)
+ ;; resolve-code takes wff and substitution as input,
+ ;; calls continuation with new substitution and optional new wff (residue) as result
+ ;;
+ ;; this particular sample resolve-code uses functions, written in the style
+ ;; of function-satisfy-code and function-falsify-code, but stored as
+ ;; function-resolve-code-satisfy-code and function-resolve-code-falsify-code
+ ;; to simultaneously satisfy/falsify literals in a clause in all possible ways
+ (when (clause-p wff)
+ (mvlet (((values negatoms posatoms) (atoms-in-clause3 wff)))
+ (labels
+ ((resolver (negatoms posatoms subst residue)
+ (cond
+ (negatoms
+ (let ((atom (pop negatoms)))
+ (dereference
+ atom subst
+ :if-compound-appl
+ (prog->
+ ;; for every way of satisfying this atom by code,
+ ;; try to satisfy/falsify the remaining atoms by code
+ (dolist (function-resolve-code-satisfy-code (head atom)) ->* fun)
+ (funcall fun atom subst ->* subst res)
+ (resolver negatoms posatoms subst (if (and residue res)
+ (disjoin residue res)
+ (or residue res)))))
+ ;; also try to satisfy/falsify remaining atoms leaving this atom in residue
+ (resolver negatoms posatoms subst (if residue
+ (disjoin residue (negate atom))
+ (negate atom)))))
+ (posatoms
+ (let ((atom (pop posatoms)))
+ (dereference
+ atom subst
+ :if-compound-appl
+ (prog->
+ ;; for every way of falsifying this atom by code,
+ ;; try to satisfy/falsify the remaining atoms by code
+ (dolist (function-resolve-code-falsify-code (head atom)) ->* fun)
+ (funcall fun atom subst ->* subst res)
+ (resolver negatoms posatoms subst (if (and residue res)
+ (disjoin residue res)
+ (or residue res)))))
+ ;; also try to satisfy/falsify remaining atoms leaving this atom in residue
+ (resolver negatoms posatoms subst (if residue
+ (disjoin residue atom)
+ atom))))
+ (t
+ (funcall cc subst residue)))))
+ (resolver negatoms posatoms subst nil)))))
+
+(defun resolve-code-example3 ()
+ ;; silly example to illustrate resolve-code for whole formulas
+ ;; gives same result as resolve-code-example2, but in single rather than multiple steps
+ (initialize)
+ (declare-relation '* 3)
+ (setf (function-resolve-code-satisfy-code (input-relation-symbol '* 3))
+ '(resolve-code-example2-satisfier))
+ (use-resolve-code 'resolve-code-resolver1)
+ (prove '(and (not (p ?x ?y ?z)) (* ?x a b) (* c ?y d) (* e ?z ?z))))
+
+;;; resolve-code.lisp EOF
diff --git a/snark-20120808r02/src/rewrite-code.abcl b/snark-20120808r02/src/rewrite-code.abcl
new file mode 100644
index 0000000..a136e7b
Binary files /dev/null and b/snark-20120808r02/src/rewrite-code.abcl differ
diff --git a/snark-20120808r02/src/rewrite-code.lisp b/snark-20120808r02/src/rewrite-code.lisp
new file mode 100644
index 0000000..cde5f25
--- /dev/null
+++ b/snark-20120808r02/src/rewrite-code.lisp
@@ -0,0 +1,402 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: rewrite-code.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun equality-rewriter (atom subst)
+ ;; (= t t) -> true
+ ;; (= t s) -> false if t and s are headed by different constructors
+ ;; (= (f t1 ... tn) (f s1 ... sn)) -> (and (= t1 s1) ... (= tn sn)) if f is injective
+ ;; (= t s) -> false if t and s have disjoint sorts
+ ;; also try equality-rewrite-code functions for (= (f ...) (f ...))
+ ;; none otherwise
+ (mvlet ((*=* (head atom))
+ ((list x y) (args atom)))
+ (or (dereference2
+ x y subst
+ :if-variable*variable (cond
+ ((eq x y)
+ true))
+ :if-constant*constant (cond
+ ((eql x y)
+ true))
+ :if-compound*compound (cond
+ ((equal-p x y subst)
+ true)
+ (t
+ (let ((fn1 (head x)) (fn2 (head y)))
+ (cond
+ ((eq fn1 fn2)
+ (cond
+ ((dolist (fun (function-equality-rewrite-code fn1) nil)
+ (let ((v (funcall fun atom subst)))
+ (unless (eq none v)
+ (return v)))))
+ ((function-associative fn1)
+ nil)
+ ((and (function-constructor fn1) (function-commutative fn1))
+ (let ((xargs (args x))
+ (yargs (args y)))
+ (if (length= xargs yargs)
+ (conjoin (let ((x1 (first xargs)) (x2 (second xargs))
+ (y1 (first yargs)) (y2 (second yargs)))
+ (disjoin (conjoin (make-equality x1 y1) (make-equality x2 y2) subst)
+ (conjoin (make-equality x1 y2) (make-equality x2 y1) subst)
+ subst))
+ (conjoin* (mapcar #'make-equality (rrest xargs) (rrest yargs)) subst)
+ subst)
+ false)))
+ ((function-injective fn1)
+ (let ((xargs (args x))
+ (yargs (args y)))
+ (if (length= xargs yargs)
+ (conjoin* (mapcar #'make-equality xargs yargs) subst) ;may result in nonclause
+ false))))))))))
+ (let ((xconstant nil) (xcompound nil) (xconstructor nil) xsort
+ (yconstant nil) (ycompound nil) (yconstructor nil) ysort)
+ (dereference
+ x nil
+ :if-constant (setf xconstant t xconstructor (constant-constructor x))
+ :if-compound (setf xcompound t xconstructor (function-constructor (head x))))
+ (dereference
+ y nil
+ :if-constant (setf yconstant t yconstructor (constant-constructor y))
+ :if-compound (setf ycompound t yconstructor (function-constructor (head y))))
+ (cond
+ ((or (and xconstructor yconstructor (implies (and xcompound ycompound) (neq (head x) (head y))))
+ (sort-disjoint?
+ (setf xsort (if xcompound (compound-sort x subst) (if xconstant (constant-sort x) (variable-sort x))))
+ (setf ysort (if ycompound (compound-sort y subst) (if yconstant (constant-sort y) (variable-sort y)))))
+ (and (not (same-sort? xsort ysort))
+ (or (and xconstructor (not (subsort? xsort ysort)) (not (same-sort? xsort (sort-intersection xsort ysort))))
+ (and yconstructor (not (subsort? ysort xsort)) (not (same-sort? ysort (sort-intersection xsort ysort))))))
+ (and xconstructor
+ xcompound
+ (cond
+ (yconstant (constant-occurs-below-constructor-p y x subst))
+ (ycompound (compound-occurs-below-constructor-p y x subst))
+ (t (variable-occurs-below-constructor-p y x subst))))
+ (and yconstructor
+ ycompound
+ (cond
+ (xconstant (constant-occurs-below-constructor-p x y subst))
+ (xcompound (compound-occurs-below-constructor-p x y subst))
+ (t (variable-occurs-below-constructor-p x y subst)))))
+ false)))
+ none)))
+
+(defun make-characteristic-atom-rewriter (pred sort)
+ (setf sort (the-sort sort))
+ (lambda (atom subst)
+ (let ((term (arg1 atom)) s)
+ (or (dereference
+ term subst
+ :if-variable (progn (setf s (variable-sort term)) nil)
+ :if-constant (cond
+ ((funcall pred term)
+ true)
+ ((constant-constructor term)
+ false)
+ (t
+ (progn (setf s (constant-sort term)) nil)))
+ :if-compound-cons (cond
+ ((funcall pred term) ;for pred being listp or consp
+ true)
+ (t
+ false))
+ :if-compound-appl (cond
+ ((funcall pred term) ;for pred being bagp
+ true)
+ ((function-constructor (head term))
+ false)
+ (t
+ (progn (setf s (compound-sort term subst)) nil))))
+ (cond
+;; ((subsort? s sort)
+;; true)
+ ((sort-disjoint? s sort)
+ false))
+ none))))
+
+(defun reflexivity-rewriter (atom subst)
+ ;; example: this is called when trying to rewrite (rel a b) after
+ ;; doing (declare-relation 'rel 2 :rewrite-code 'reflexivity-rewriter)
+ ;; (rel a b) -> true after unifying a and b
+ ;; returns new value (true) or none (no rewriting done)
+ (let ((args (args atom)))
+ (if (equal-p (first args) (second args) subst) true none)))
+
+(defun irreflexivity-rewriter (atom subst)
+ ;; example: this is called when trying to rewrite (rel a b) after
+ ;; doing (declare-relation 'rel 2 :rewrite-code 'irreflexivity-rewriter)
+ ;; (rel a b) -> false after unifying a and b
+ ;; returns new value (false) or none (no rewriting done)
+ (let ((args (args atom)))
+ (if (equal-p (first args) (second args) subst) false none)))
+
+(defun associative-identity-rewriter (term subst)
+ ;; remove identities from argument list
+ ;; eliminate head when less than two arguments
+ (let* ((head (head term))
+ (identity (function-identity head)))
+ (unless (eq none identity)
+ (labels
+ ((simp (args)
+ (if (null args)
+ nil
+ (let* ((y (rest args))
+ (y* (simp y))
+ (x (first args)))
+ (if (dereference x subst :if-constant (eql identity x))
+ y*
+ (if (eq y y*) args (cons x y*)))))))
+ (let* ((args (flatargs term))
+ (args* (simp args)))
+ (cond
+ ((null args*)
+ identity)
+ ((null (rest args*))
+ (first args*))
+ ((neq args args*)
+ (make-compound* head args*))
+ (t
+ none)))))))
+
+(defun associative-identity-paramodulater (cc term subst0 &optional (collapse (test-option44?)))
+ (let* ((head (head term))
+ (identity (function-identity head)))
+ (unless (eq none identity)
+ (labels
+ ((param (args subst l)
+ (if (null args)
+ (unless (eq subst0 subst)
+ (funcall cc (make-a1-compound* head identity (reverse l)) subst))
+ (let ((x (first args)))
+ (dereference
+ x subst
+ :if-variable (unless (member x l)
+ (prog->
+ (unify x identity subst ->* subst)
+ (param (rest args) subst l))))
+ (cond
+ ((eql identity x)
+ (param (rest args) subst l))
+ ((implies collapse (null l))
+ (param (rest args) subst (cons x l))))))))
+ (param (flatargs term subst0) subst0 nil)))))
+
+(defun nonvariable-rewriter (atom subst)
+ (let ((x (arg1 atom)))
+ (dereference
+ x subst
+ :if-variable none
+ :if-constant true
+ :if-compound true)))
+
+(defun the-term-rewriter (term subst)
+ ;; (the sort value) -> value, if value's sort is a subsort of sort
+ (let* ((args (args term))
+ (arg1 (first args))
+ (arg2 (second args)))
+ (if (dereference
+ arg1 subst
+ :if-constant (and (sort-name? arg1) (subsort? (term-sort arg2 subst) (the-sort arg1))))
+ arg2
+ none)))
+
+(defun not-wff-rewriter (wff subst)
+ (declare (ignore subst))
+ (let ((arg (arg1 wff)))
+ (cond
+ ((eq true arg)
+ false)
+ ((eq false arg)
+ true)
+ (t
+ none))))
+
+(defun and-wff-rewriter (wff subst)
+ (let ((wff* (conjoin* (args wff) subst)))
+ (if (equal-p wff wff* subst) none wff*)))
+
+(defun or-wff-rewriter (wff subst)
+ (let ((wff* (disjoin* (args wff) subst)))
+ (if (equal-p wff wff* subst) none wff*)))
+
+(defun implies-wff-rewriter (wff subst)
+ (let ((args (args wff)))
+ (implies-wff-rewriter1 (first args) (second args) subst)))
+
+(defun implied-by-wff-rewriter (wff subst)
+ (let ((args (args wff)))
+ (implies-wff-rewriter1 (second args) (first args) subst)))
+
+(defun implies-wff-rewriter1 (x y subst)
+ (or (dereference2
+ x y subst
+ :if-variable*variable (cond
+ ((eq x y)
+ true))
+ :if-variable*constant (cond
+ ((eq true y)
+ true)
+ ((eq false y)
+ (negate x subst)))
+ :if-constant*variable (cond
+ ((eq true x)
+ y)
+ ((eq false x)
+ true))
+ :if-constant*constant (cond
+ ((eql x y)
+ true)
+ ((eq true x)
+ y)
+ ((eq false x)
+ true)
+ ((eq true y)
+ true)
+ ((eq false y)
+ (negate x subst)))
+ :if-variable*compound (cond
+ ((and (negation-p y) (eq x (arg1 y)))
+ false))
+ :if-compound*variable (cond
+ ((and (negation-p x) (eq (arg1 x) y))
+ false))
+ :if-constant*compound (cond
+ ((eq true x)
+ y)
+ ((eq false x)
+ true)
+ ((and (negation-p y) (eql x (arg1 y)))
+ false))
+ :if-compound*constant (cond
+ ((eq true y)
+ true)
+ ((eq false y)
+ (negate x subst))
+ ((and (negation-p x) (eql (arg1 x) y))
+ false))
+ :if-compound*compound (cond
+ ((equal-p x y subst)
+ true)
+ ((and (negation-p x) (equal-p (arg1 x) y subst))
+ false)
+ ((and (negation-p y) (equal-p x (arg1 y) subst))
+ false)))
+ none))
+
+(defun distributive-law1-p (lhs rhs &optional subst)
+ ;; checks if LHS=RHS is of form X*(Y+Z)=(X*Y)+(X*Z) for variables X,Y,Z and distinct function symbols *,+
+ (let (fn1 fn2 vars sort)
+ (and (dereference
+ lhs subst
+ :if-compound (progn (setf fn1 (head lhs)) t))
+ (dereference
+ rhs subst
+ :if-compound (neq (setf fn2 (head rhs)) fn1))
+ (= (length (setf vars (variables rhs subst (variables lhs subst)))) 3)
+ (same-sort? (setf sort (variable-sort (first vars))) (variable-sort (second vars)))
+ (same-sort? sort (variable-sort (third vars)))
+ (let ((x (make-variable sort))
+ (y (make-variable sort))
+ (z (make-variable sort)))
+ (variant-p (cons (make-compound fn1 x (make-compound fn2 y z))
+ (make-compound fn2 (make-compound fn1 x y) (make-compound fn1 x z)))
+ (cons lhs rhs)
+ subst)))))
+
+(defun cancel1 (eq fn identity terms1 terms2 subst)
+ (prog->
+ (count-arguments fn terms2 subst (count-arguments fn terms1 subst) -1 -> terms-and-counts cancel)
+ (cond
+ ((null cancel)
+ none)
+ (t
+ (quote nil -> args1)
+ (quote nil -> args2)
+ (progn
+ (dolist terms-and-counts ->* v)
+ (tc-count v -> count)
+ (cond
+ ((> count 0)
+ (setf args1 (consn (tc-term v) args1 count)))
+ ((< count 0)
+ (setf args2 (consn (tc-term v) args2 (- count))))))
+ (if (or (and (null args1) args2 (null (cdr args2)) (eql identity (car args2)))
+ (and (null args2) args1 (null (cdr args1)) (eql identity (car args1)))) ;don't simplify x+0=x
+ none
+ (make-compound eq
+ (make-a1-compound* fn identity args1)
+ (make-a1-compound* fn identity args2)))))))
+
+(defun make-cancel (eq fn identity)
+ (lambda (equality subst)
+ (prog->
+ (args equality -> args)
+ (first args -> x)
+ (second args -> y)
+ (cond
+ ((dereference x subst :if-compound (eq fn (head x)))
+ (cancel1 eq fn identity (args x) (list y) subst))
+ ((dereference y subst :if-compound (eq fn (head y)))
+ (cancel1 eq fn identity (list x) (args y) subst))
+ (t
+ none)))))
+
+(defun declare-cancellation-law (equality-relation-symbol function-symbol identity-symbol)
+ (let ((eq (input-relation-symbol equality-relation-symbol 2))
+ (fn (input-function-symbol function-symbol 2))
+ (id (input-constant-symbol identity-symbol)))
+ (declare-relation equality-relation-symbol 2 :locked nil :rewrite-code (make-cancel eq fn id))))
+
+(defun distributivity-rewriter (term subst op2)
+ ;; distributes (head term) over op2 (e.g., * over + in (* (+ a b) c))
+ ;; flattens argument lists of both operators
+ (let* ((head (head term))
+ (args (argument-list-a1 head (args term) subst)))
+ (cond
+ ((member-if #'(lambda (arg) (dereference arg subst :if-compound-appl (eq op2 (heada arg)))) args)
+ (labels
+ ((distribute (args)
+ (if (null args)
+ (list nil)
+ (let ((l (distribute (rest args)))
+ (arg (first args)))
+ (if (dereference arg subst :if-compound-appl (eq op2 (heada arg)))
+ (prog->
+ (mapcan (argument-list-a1 op2 (args arg) subst) ->* x)
+ (mapcar l ->* y)
+ (cons x y))
+ (prog->
+ (mapcar l ->* y)
+ (cons arg y)))))))
+ (make-compound* op2 (mapcar #'(lambda (x) (make-compound* head x)) (distribute args)))))
+ (t
+ none))))
+
+(defun declare-distributive-law (fn1 fn2)
+ (let ((fn1 (input-function-symbol fn1 2)) ;sum
+ (fn2 (input-function-symbol fn2 2))) ;product
+ (declare-function
+ fn2 (function-arity fn2)
+ :rewrite-code (lambda (term subst) (distributivity-rewriter term subst fn1)))))
+
+;;; rewrite-code.lisp EOF
diff --git a/snark-20120808r02/src/rewrite.abcl b/snark-20120808r02/src/rewrite.abcl
new file mode 100644
index 0000000..dc3c78f
Binary files /dev/null and b/snark-20120808r02/src/rewrite.abcl differ
diff --git a/snark-20120808r02/src/rewrite.lisp b/snark-20120808r02/src/rewrite.lisp
new file mode 100644
index 0000000..cea6f62
--- /dev/null
+++ b/snark-20120808r02/src/rewrite.lisp
@@ -0,0 +1,488 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: rewrite.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(declaim (special *subsuming* *frozen-variables* *processing-row*))
+
+(defstruct (rewrite
+ (:constructor make-rewrite (row pattern value condition pattern-symbol-count new-value-variables polarity)))
+ row
+ pattern
+ value
+ condition
+ pattern-symbol-count
+ new-value-variables
+ (embeddings nil)
+ (polarity nil)
+ )
+
+(defvar *redex-path* nil) ;(polarity-n function-n ... polarity-1 function-1)
+
+(defun rewrite-patterns-and-values (function pattern value pattern-symbol-count embeddings symbol-count)
+ ;; calls function with rewrite's pattern and value, and patterns and values for any embeddings,
+ ;; provided size of the pattern does not exceed size of the term
+ (prog->
+ (when (symbol-count-not-greaterp pattern-symbol-count symbol-count)
+ (funcall function pattern value)
+ (when embeddings
+ (- (symbol-count-total symbol-count) (symbol-count-total pattern-symbol-count) -> size-difference)
+ (unless (< size-difference 2)
+ (dereference pattern nil)
+ (head pattern -> head)
+ (function-sort head -> sort)
+ (make-variable sort -> newvar1)
+ (ecase embeddings
+ (:l
+ (funcall function
+ (make-compound head newvar1 pattern) ;left embedding
+ (make-compound head newvar1 value)))
+ (:r
+ (funcall function
+ (make-compound head pattern newvar1) ;right embedding
+ (make-compound head value newvar1)))
+ (:l&r
+ (funcall function
+ (make-compound head newvar1 pattern) ;left embedding
+ (make-compound head newvar1 value))
+ (funcall function
+ (make-compound head pattern newvar1) ;right embedding
+ (make-compound head value newvar1))
+ (unless (< size-difference 4)
+ (make-variable sort -> newvar2)
+ (funcall function
+ (make-compound head newvar1 pattern newvar2) ;left & right embedding
+ (make-compound head newvar1 value newvar2))))))))))
+
+(defvar *rewrites-used*)
+
+(defvar rewrite-strategy :innermost)
+;; options:
+;; :innermost simplifies subterms first
+;; :outermost tries to simplify outer terms first, subterms in left-to-right order otherwise
+
+(defvar fully-rewritten-compounds)
+
+(defun redex-at-top? ()
+ (null *redex-path*))
+
+(defun redex-polarity (&optional (rp *redex-path*))
+ (if (null rp)
+ :pos
+ (first rp)))
+
+(defun set-redex-polarity (polarity)
+ (setf (first *redex-path*) polarity))
+
+(defun redex-literal? (&optional (rp *redex-path*))
+ (or (null rp)
+ (and (eq 'not (function-logical-symbol-p (second rp)))
+ (redex-literal? (cddr rp)))))
+
+(defun redex-clause? (&optional (rp *redex-path*))
+ (or (null rp)
+ (and (redex-clause? (cddr rp))
+ (let ((c (function-logical-symbol-p (second rp))))
+ (or (not c)
+ (case c
+ (not
+ t)
+ (and
+ (eq :neg (redex-polarity (cddr rp))))
+ (or
+ (eq :pos (redex-polarity (cddr rp))))
+ (implies
+ (eq :pos (redex-polarity (cddr rp))))
+ (implied-by
+ (eq :pos (redex-polarity (cddr rp))))
+ (otherwise
+ nil)))))))
+
+(defun rewriter (term subst)
+ (dereference
+ term subst
+ :if-variable term
+ :if-constant (if (or (eq true term) (eq false term))
+ term
+ (let ((*subsuming* t)
+ (*frozen-variables* *frozen-variables*)
+ (fully-rewritten-compounds nil))
+ (ecase rewrite-strategy
+ (:innermost
+ (rewrite-innermost term subst nil))
+ (:outermost
+ (rewrite-outermost term subst nil)))))
+ :if-compound (let ((*subsuming* t)
+ (*frozen-variables* (variables term subst *frozen-variables*))
+ (fully-rewritten-compounds nil))
+ (ecase rewrite-strategy
+;; (:innermost
+;; (rewrite-innermost term subst nil))
+ (:innermost ;rewrite at top first, then do innermost simplification
+ (let ((term* (rewrite-compound term subst (head term))))
+ (cond
+ ((eq none term*)
+ (rewrite-innermost term subst :top))
+ ((or (eq true term*) (eq false term*))
+ term*)
+ (t
+ (rewrite-innermost term* subst nil)))))
+ (:outermost
+ (rewrite-outermost term subst nil))))))
+
+(defun rewrite-constant (term)
+ ;; it is assumed that the lhs of any applicable rewrite must be identical to term
+ (prog->
+ (dolist (rewrites term) ->* rewrite)
+ (rewrite-row rewrite -> w)
+ (rewrite-condition rewrite -> cond)
+ (when (and (implies w (and (eq t (context-subsumes? (row-context-live? w) *rewriting-row-context*)) (not (row-hint-p w))))
+ (implies (rewrite-polarity rewrite) (eq (rewrite-polarity rewrite) (redex-polarity)))
+ (or (eq cond t) (funcall cond (rewrite-pattern rewrite) (rewrite-value rewrite) nil))
+ (term-subsort-p (rewrite-value rewrite) term nil))
+ (pushnew-unless-nil w *rewrites-used*)
+ (return-from rewrite-constant
+ (rewrite-value rewrite))))
+ none)
+
+(defun rewrite-compound (term subst head)
+ (let* ((funs (function-rewrite-code head))
+ (v (if funs (rewrite-compound-by-code term subst funs) none)))
+ (cond
+ ((neq none v)
+ v)
+ ((function-rewritable-p head)
+ (rewrite-compound-by-rule term subst (symbol-count term subst)))
+ (t
+ none))))
+
+(defun rewrite-compound-by-code (term subst funs)
+ (dolist (fun funs none)
+ (let ((result (funcall fun term subst)))
+ (unless (eq none result)
+;; (setf result (declare-constants result))
+ (when (term-subsort-p result term subst)
+ (let ((head (head term)))
+ (pushnew-unless-nil
+ (and (not (function-logical-symbol-p head))
+ (function-code-name head))
+ *rewrites-used*))
+ (return result))))))
+
+(defun declare-constants (x &optional subst)
+ (prog->
+ (map-terms-in-term-and-compose-result x subst ->* term polarity)
+ (declare (ignore polarity))
+ (if (constant-p term) (declare-constant term) term)))
+
+(defun rewrite-compound-by-rule (term subst symbol-count)
+ (prog->
+ ;; ASSUME THAT IF EMBEDDED REWRITE IS NEEDED, ITS UNEMBEDDED FORM WILL BE RETRIEVED
+ (when (trace-rewrite?)
+ (format t "~2%; REWRITE-COMPOUND-BY-RULE will try to rewrite~%; ~A." (term-to-lisp term subst)))
+ (retrieve-generalization-entries term subst #'tme-rewrites ->* e rewrites)
+ (declare (ignore e))
+ (dolist rewrites ->* rewrite)
+ (rewrite-row rewrite -> w)
+ (when (and (implies w (and (eq t (context-subsumes? (row-context-live? w) *rewriting-row-context*)) (not (row-hint-p w))))
+ (implies (rewrite-polarity rewrite) (eq (rewrite-polarity rewrite) (redex-polarity))))
+ (rewrite-condition rewrite -> cond)
+ (rewrite-pattern rewrite -> pattern)
+ (rewrite-value rewrite -> value)
+ (when (eq :verbose (trace-rewrite?))
+ (format t "~%; Try ~A -> ~A." pattern value))
+ (rewrite-pattern-symbol-count rewrite -> pattern-symbol-count)
+ (quote nil -> v)
+ (cond
+ ((and (setf v (ac-inverse-rule-p pattern value cond subst))
+ (setf v (apply-ac-inverse-rule (args term) (car v) (cadr v) (caddr v) subst)))
+ (return-from rewrite-compound-by-rule v))
+ (t
+ (rewrite-patterns-and-values
+ pattern
+ value
+ pattern-symbol-count
+ (rewrite-embeddings rewrite)
+ symbol-count
+ ->* pattern* value*)
+ (when (eq :verbose (trace-rewrite?))
+ (format t "~%; Try ~A LHS." pattern*)
+;; (format t "~%; FROZEN: ~A" (setf *frz* *frozen-variables*))
+;; (format t "~%; PATTERN*: ~A" (setf *pat* pattern*))
+;; (format t "~%; TERM: ~A" (setf *trm* term))
+;; (format t "~%; SUBST: ~A" (setf *subst* subst))
+;; (format t "~%; Unifiable: ") (unless (prin1 (unify-p pattern* term subst)) (break))
+ )
+ (unify pattern* term subst ->* subst)
+ (when (and (or (eq cond t) (funcall cond pattern value subst)) ;CHECK ORDER OF UNEMBEDDED REWRITE
+ (term-subsort-p value* pattern* subst))
+ (pushnew-unless-nil w *rewrites-used*)
+ (dolist (var (rewrite-new-value-variables rewrite))
+ (let ((v (make-variable (variable-sort var))))
+ (setf subst (bind-variable-to-term var v subst))
+ (push v *frozen-variables*)))
+ (instantiate value* subst -> term*)
+ (when (trace-rewrite?)
+ (format t "~%; REWRITE-COMPOUND-BY-RULE rewrote it to~%; ~A" (term-to-lisp term* subst))
+ (format t "~%; by ~A -> ~A." pattern* value*))
+ (return-from rewrite-compound-by-rule term*))))))
+ (when (trace-rewrite?)
+ (format t "~%; REWRITE-COMPOUND-BY-RULE failed to rewrite it."))
+ none)
+
+(defun rewrite-list (term subst)
+ (rewrite-list-by-rule term subst (symbol-count term subst)))
+
+(defun rewrite-list-by-rule (term subst symbol-count)
+ (prog->
+ (retrieve-generalization-entries term subst #'tme-rewrites ->* e rewrites)
+ (declare (ignore e))
+ (dolist rewrites ->* rewrite)
+ (rewrite-row rewrite -> w)
+ (when (implies w (and (eq t (context-subsumes? (row-context-live? w) *rewriting-row-context*)) (not (row-hint-p w))))
+ (rewrite-condition rewrite -> cond)
+ (rewrite-pattern rewrite -> pattern)
+ (rewrite-value rewrite -> value)
+ (rewrite-pattern-symbol-count rewrite -> pattern-symbol-count)
+ (rewrite-patterns-and-values
+ pattern
+ value
+ pattern-symbol-count
+ (rewrite-embeddings rewrite)
+ symbol-count
+ ->* pattern* value*)
+ (unify pattern* term subst ->* subst)
+ (when (and (or (eq cond t) (funcall cond pattern value subst)) ;CHECK ORDER OF UNEMBEDDED REWRITE
+ (term-subsort-p value* pattern* subst))
+ (pushnew-unless-nil w *rewrites-used*)
+ (dolist (var (rewrite-new-value-variables rewrite))
+ (let ((v (make-variable (variable-sort var))))
+ (setf subst (bind-variable-to-term var v subst))))
+ (instantiate value* subst -> term*)
+ (return-from rewrite-list-by-rule
+ term*))))
+ none)
+
+(defvar *rewrite-count-warning* t)
+
+(defmacro rewrite-*most (appl-code)
+ `(block rewrite-*most
+ (let ((term original-term) (count 0))
+ (loop
+ (when *rewrite-count-warning*
+ (when (and (eql 0 (rem count 1000)) (not (eql 0 count)))
+ (warn "~A has been rewritten ~D times;~%value now is ~A." (term-to-lisp original-term subst) count (term-to-lisp term subst))))
+ (incf count)
+ (dereference
+ term subst
+ :if-variable (return-from rewrite-*most term)
+ :if-constant (cond
+ ((or (eq true term) (eq false term))
+ (return-from rewrite-*most term))
+ (t
+ (let ((result (rewrite-constant term)))
+ (cond
+ ((neq none result)
+ (setf term result))
+ (t
+ (return-from rewrite-*most term))))))
+ :if-compound (cond
+ ((member term fully-rewritten-compounds :test #'eq)
+ (return-from rewrite-*most term))
+ (t
+ ,appl-code)))))))
+
+(defun eq-args (term args)
+ (dereference
+ term nil
+ :if-compound-cons (and (eql (carc term) (first args))
+ (eql (cdrc term) (second args)))
+ :if-compound-appl (eq (argsa term) args)))
+
+(defun rewrite-innermost (original-term subst head-if-associative)
+ ;; requires that original-term be fully dereferenced IF REWRITE CACHE IS USED
+ ;; (otherwise, input-outputs of dereferencing put into rewrite cache)
+ (rewrite-*most
+ (let ((head (head term))
+ (args (args term))
+ args*)
+ (cond
+ ((or (null args)
+ (eq args (setf args* (let ((*redex-path* (list* nil head *redex-path*)))
+ (rewrite-list-innermost
+ args subst
+ (if (function-associative head) head nil)
+ (function-polarity-map head))))))
+ )
+ (t
+ (setf term (fancy-make-compound* head args*))))
+ (dereference term subst)
+ (cond
+ ((not (and (compound-p term) ;fancy-make-compound changed it?
+ (eq (head term) head)
+ (eq-args term args*)))
+ (when (eq :top head-if-associative)
+ (setf head-if-associative nil)))
+ ((and (eq :top head-if-associative)
+ (progn (setf head-if-associative nil) t)
+ (compound-p term)
+ (eq (head term) head)
+ (eq-args term args))
+ (return-from rewrite-*most term))
+ ((and head-if-associative (eq head head-if-associative))
+ (return-from rewrite-*most term))
+ (t
+ (let ((result (rewrite-compound term subst head)))
+ (cond
+ ((neq none result)
+ (setf term result))
+ (t
+ (pushnew term fully-rewritten-compounds :test #'eq)
+ (return-from rewrite-*most term)))))))))
+
+(defun rewrite-outermost (original-term subst head-if-associative)
+ ;; requires that original-term be fully dereferenced IF REWRITE CACHE IS USED
+ ;; (otherwise, input-outputs of dereferencing put into rewrite cache)
+ (rewrite-*most
+ (let ((head (head term)))
+ (cond
+ ((and head-if-associative (eq head head-if-associative))
+ (let ((args (args term)) args*)
+ (cond
+ ((or (null args)
+ (eq args (setf args* (let ((*redex-path* (list* nil head *redex-path*)))
+ (rewrite-list-outermost
+ args subst
+ (if (function-associative head) head nil)
+ (function-polarity-map head))))))
+ (return-from rewrite-*most term))
+ (t
+ (setf term (fancy-make-compound* head args*))))))
+ (t
+ (let ((result (rewrite-compound term subst head)))
+ (cond
+ ((neq none result)
+ (setf term result))
+ (t
+ (let ((args (args term)) args*)
+ (cond
+ ((or (null args)
+ (eq args (setf args* (rewrite-list-outermost
+ args subst
+ (if (function-associative head) head nil)
+ (function-polarity-map head)))))
+ (return-from rewrite-*most term))
+ (t
+ (setf term (fancy-make-compound* head args*)))))))))))))
+
+(defun rewrite-list-innermost (terms subst head-if-associative polarity-map &optional rewrite-alist)
+ ;; rewrite nonempty list of terms, using innermost simplification first
+ (let* ((x (first terms))
+ (newly-simplified nil)
+ (x* (let ((v (assoc x rewrite-alist :test (lambda (x y) (equal-p x y subst)))))
+ (cond
+ (v
+ (cdr v))
+ (t
+ (setf newly-simplified t)
+ (set-redex-polarity (map-polarity (first polarity-map) (redex-polarity (cddr *redex-path*))))
+ (rewrite-innermost x subst head-if-associative)))))
+ (y (rest terms)))
+ (lcons x*
+ (rewrite-list-innermost y subst head-if-associative (rest polarity-map)
+ (if newly-simplified
+ (acons x x* rewrite-alist)
+ rewrite-alist))
+ terms)))
+
+(defun rewrite-list-outermost (terms subst head-if-associative polarity-map)
+ ;; rewrite nonempty list of terms, using outermost simplification first
+ (let* ((x (first terms))
+ (x* (progn
+ (set-redex-polarity (map-polarity (first polarity-map) (redex-polarity (cddr *redex-path*))))
+ (rewrite-outermost x subst head-if-associative))))
+ (cond
+ ((neql x* x)
+ (cons x* (rest terms)))
+ (t
+ (let ((y (rest terms)))
+ (cond
+ ((null y)
+ terms)
+ (t
+ (let ((y* (rewrite-list-outermost y subst head-if-associative (rest polarity-map))))
+ (if (eq y* y) terms (cons x* y*))))))))))
+
+(defun ac-inverse-rule-p (pattern value cond subst)
+ (and
+ (eq cond t)
+ (ground-p value subst)
+ (dereference
+ pattern subst
+ :if-compound (let ((f (head pattern)))
+ (and
+ (function-associative f)
+ (function-commutative f)
+ (let ((args (args pattern)))
+ (and
+ (eql 2 (length args))
+ (let ((arg1 (first args)) (arg2 (second args)))
+ (dereference2
+ arg1 arg2 subst
+ :if-variable*compound (let ((g (head arg2)))
+ (and
+ (eql (function-arity g) 1)
+ (equal-p arg1 (arg1 arg2) subst)
+ (list f g value)))
+ :if-compound*variable (let ((g (head arg1)))
+ (and
+ (eql (function-arity g) 1)
+ (equal-p arg2 (arg1 arg1) subst)
+ (list f g value))))))))))))
+
+(defun apply-ac-inverse-rule (args f g e subst)
+ ;; f(x,g(x)) -> e
+ (apply-ac-inverse-rule* (count-arguments f args subst) f g e subst))
+
+(defun apply-ac-inverse-rule* (terms-and-counts f g e subst)
+ (prog->
+ (dolist terms-and-counts ->* tc)
+ (when (> (tc-count tc) 0)
+ (tc-term tc -> term)
+ (when (dereference term subst :if-compound (eq g (head term)))
+ (recount-arguments f
+ (list* (make-tc term -1)
+ (make-tc (arg1 term) -1)
+ (make-tc e 1)
+ terms-and-counts)
+ subst
+ -> new-terms-and-counts)
+ (when (loop for tc in new-terms-and-counts
+ never (< (tc-count tc) 0))
+ (return-from apply-ac-inverse-rule*
+ (or
+ (apply-ac-inverse-rule* new-terms-and-counts f g e subst)
+ (let ((args nil))
+ (prog->
+ (dolist new-terms-and-counts ->* tc)
+ (setf args (consn (tc-term tc) args (tc-count tc))))
+ (make-a1-compound* f nil args))))))))
+ nil)
+
+;;; rewrite.lisp EOF
diff --git a/snark-20120808r02/src/row-contexts.abcl b/snark-20120808r02/src/row-contexts.abcl
new file mode 100644
index 0000000..82edefe
Binary files /dev/null and b/snark-20120808r02/src/row-contexts.abcl differ
diff --git a/snark-20120808r02/src/row-contexts.lisp b/snark-20120808r02/src/row-contexts.lisp
new file mode 100644
index 0000000..8e4700d
--- /dev/null
+++ b/snark-20120808r02/src/row-contexts.lisp
@@ -0,0 +1,184 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: row-contexts.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2008.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; assertions ordinarily go into root context
+;;; assumptions and negated conjectures go into (current-row-context)
+;;; inferred rows go into the maximum of the contexts of the rows they're inferred from
+
+;;; add assert-context-type snark option?
+;;; add assume-context-type snark option?
+
+(defvar *root-row-context*)
+(defvar *current-row-context*)
+
+(defmacro root-row-context ()
+ `*root-row-context*)
+
+(defmacro current-row-context ()
+ `*current-row-context*)
+
+(defun initialize-row-contexts ()
+ (setf (root-row-context) (make-feature :name '#:root-row-context :children-incompatible t))
+ (setf (current-row-context) (make-feature :parent (root-row-context) :children-incompatible t))
+ nil)
+
+(definline context-parent (c)
+ (feature-parent c))
+
+(definline context-live? (c)
+ (feature-live? c))
+
+(defun print-row-context-tree ()
+ (print-feature-tree :node (root-row-context)))
+
+(defun the-row-context (context &optional action)
+ (cond
+ ((or (eq :root context) (eql 1 context))
+ (root-row-context))
+ ((eq :current context)
+ (current-row-context))
+ (t
+ (the-feature context action)))) ;should verify that it's really a row-context, not just a feature
+
+(defun make-row-context (&key name parent (children-incompatible t))
+ (make-feature :name name
+ :children-incompatible children-incompatible
+ :parent (if parent (the-row-context parent 'error) (current-row-context))))
+
+(defun delete-row-context (context)
+ (when (setf context (the-row-context context 'warn))
+ (cond
+ ((eq (root-row-context) context)
+ (warn "Cannot delete root row context ~A." context))
+ (t
+ (when (eq (current-row-context) context)
+ (let ((parent (context-parent context)))
+ (setf (current-row-context) parent)
+ (warn "Deleting current row context; now in parent row context ~A." parent)))
+ (delete-feature context)
+ (delete-rows :test (lambda (row) (not (row-context-live? row))))
+ t))))
+
+(defun in-row-context (context)
+ (setf context (the-row-context context 'error))
+ (setf (current-row-context) context))
+
+(defun push-row-context (&key name (children-incompatible t))
+ (setf (current-row-context) (make-row-context :name name :children-incompatible children-incompatible)))
+
+(defun pop-row-context ()
+ (let* ((context (current-row-context))
+ (parent (context-parent context)))
+ (cond
+ ((null parent)
+ (warn "Cannot delete root row context ~A." context))
+ (t
+ (setf (current-row-context) parent)
+ (delete-row-context context)
+ parent))))
+
+(defun new-row-context (&key name (children-incompatible t))
+ (pop-row-context)
+ (push-row-context :name name :children-incompatible children-incompatible))
+
+;;; when partitions are used
+;;; row-context is represented as list of elements of the form
+;;; (partition-id . row-context)
+
+(defun the-row-context2 (context partitions)
+ ;; (use-partitions?) is either nil (partitions are not being used)
+ ;; or a list of partition ids
+ (setf context (the-row-context context 'error))
+ (let ((all-partitions (use-partitions?)))
+ (cond
+ (all-partitions
+ (mapcar (lambda (part)
+ (if (member part all-partitions)
+ (cons part context)
+ (error "~A is not a partition." part)))
+ (mklist partitions)))
+ (t
+ context))))
+
+(defun row-context-live? (row)
+ (let ((context (row-context row)))
+ (cond
+ ((use-partitions?)
+ (mapcan (lambda (pcd)
+ (let* ((part (car pcd))
+ (cd (cdr pcd))
+ (cd* (context-live? cd)))
+ (when cd*
+ (list (if (eq cd cd*) pcd (cons part cd*))))))
+ context))
+ (t
+ (context-live? context)))))
+
+(defun context-intersection-p (x y)
+ (cond
+ ((use-partitions?)
+ (mapcan (lambda (pcd)
+ (let* ((part (car pcd))
+ (cd (cdr pcd))
+ (cd* (feature-union (cdr (assoc part x)) cd)))
+ (when cd*
+ (list (if (eq cd cd*) pcd (cons part cd*))))))
+ y))
+ (t
+ (feature-union x y))))
+
+(defun context-subsumes? (x y)
+ (cond
+ ((use-partitions?)
+ (let ((w (mapcan (lambda (pcd)
+ (let* ((part (car pcd))
+ (cd (cdr pcd))
+ (v (cdr (assoc part x))))
+ (cond
+ ((null v)
+ (list pcd))
+ (t
+ (let ((cd* (feature-subsumes? v cd)))
+ (cond
+ ((null cd*)
+ (list pcd))
+ ((eq t cd*)
+ nil)
+ (t
+ (list (cons part cd*)))))))))
+ y)))
+ (cond
+ ((null w) ;x always includes y
+ t)
+ ((equal x w) ;x never includes y
+ nil)
+ (t ;x partly includes y
+ w))))
+ (t
+ (feature-subsumes? x y))))
+
+;;; *rewriting-row-context* is rebound around the code for rewriting to
+;;; restrict what rewrites are available and thus prevent application of
+;;; a rewrite to a row in a lower context
+
+(defvar *rewriting-row-context* nil)
+
+;;; row-contexts.lisp EOF
diff --git a/snark-20120808r02/src/rows.abcl b/snark-20120808r02/src/rows.abcl
new file mode 100644
index 0000000..920e40a
Binary files /dev/null and b/snark-20120808r02/src/rows.abcl differ
diff --git a/snark-20120808r02/src/rows.lisp b/snark-20120808r02/src/rows.lisp
new file mode 100644
index 0000000..27b277f
--- /dev/null
+++ b/snark-20120808r02/src/rows.lisp
@@ -0,0 +1,387 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: rows.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defvar *rowsets*)
+(defvar *rows*)
+(defvar *row-count* 0)
+(defvar *number-of-rows* 0)
+(defvar *row-names*)
+(declaim (type integer *row-count* *number-of-rows*))
+
+(defun uninitialized (slot-name)
+ (error "Value of row slot ~A was not supplied to make-row." slot-name))
+
+(defstruct (row
+ (:constructor make-row0)
+ (:print-function print-row3))
+ (number nil)
+ (wff nil)
+ (constraints nil) ;alist of theory names and wffs
+ (answer false)
+ (reason (uninitialized 'reason))
+ (hints-subsumed nil) ;hint rows that are backward subsumed by this row
+ (context (uninitialized 'context)) ;row was added to/deleted from this pair of contexts
+ (children nil)
+ (rewrites nil) ;list of rewrites formed from this row
+ (supported nil)
+ (sequential nil) ;only leftmost literal usable
+ (positive-or-negative none)
+ (subsumption-mark nil)
+ (status nil)
+ (agenda-entries nil)
+ (level0 nil) ;computed and set by row-level function
+ (wff-symbol-counts0 nil)
+ (selections-alist nil)
+ (plist nil)) ;property list for more properties
+
+(define-plist-slot-accessor row :documentation)
+(define-plist-slot-accessor row :author)
+(define-plist-slot-accessor row :source)
+(define-plist-slot-accessor row :name)
+(define-plist-slot-accessor row :conc-name)
+(define-plist-slot-accessor row :input-wff)
+
+(defun row-wff-symbol-counts (row)
+ (or (row-wff-symbol-counts0 row)
+ (setf (row-wff-symbol-counts0 row) (wff-symbol-counts (row-wff row)))))
+
+(defun row-name-or-number (row)
+ (or (row-name row) (row-number row)))
+
+(defmacro make-row (&rest args)
+ (let ((args0 nil) args0-last
+ (plist nil) plist-last
+ (v (gensym)))
+ (do ((l args (cddr l)))
+ ((endp l))
+ (cond
+ ((member (first l) '(:documentation :author :source :name :conc-name :input-wff))
+ (collect `(let ((,v ,(second l))) (if ,v (list ,(first l) ,v) nil)) plist))
+ (t
+ (collect (first l) args0)
+ (collect (second l) args0))))
+ (when plist
+ (collect :plist args0)
+ (collect (if (rest plist) (cons 'nconc plist) (first plist)) args0))
+ `(prog1
+ (make-row0 ,@args0)
+ (incf *row-count*))))
+
+(defun initialize-rows ()
+ ;; row structures can be stored in sets called rowsets
+ ;; *rowsets* is a matrix that stores all of the rowsets
+ ;; each row-index is (row-number row-defstruct)
+ ;; each column is one of the rowsets
+ ;; (the column-index is arbitrary because they are not accessed by number)
+ ;; the value of each entry is the row-defstruct
+ (setf *rowsets* (make-sparse-matrix))
+ (setf *rows* (make-rowset))
+ (setf *row-names* (make-hash-table))
+ nil)
+
+(defun row-given-p (row)
+ (eq :given (row-status row)))
+
+(defun row-deleted-p (row)
+ (eq :deleted (row-status row)))
+
+(defun row-hint-p (row)
+ (eq 'hint (row-reason row)))
+
+(defun row-input-p (row)
+ (= 0 (row-level row)))
+
+(defun row-nonassertion-p (x)
+ (when (row-p x)
+ (setf x (row-reason x)))
+ (if (consp x)
+ (some #'row-nonassertion-p (rest x))
+ (member x '(assumption negated_conjecture))))
+
+(defun row-from-conjecture-p (x)
+ (when (row-p x)
+ (setf x (row-reason x)))
+ (if (consp x)
+ (some #'row-from-conjecture-p (rest x))
+ (member x '(negated_conjecture))))
+
+(defun row-parents (row)
+ (rows-in-reason (row-reason row)))
+
+(defun row-parent (row)
+ (let ((l (row-parents row)))
+ (cl:assert (and l (null (rest l))))
+ (first l)))
+
+(defun row-embedding-p (row)
+ (let ((reason (row-reason row)))
+ (and (consp reason)
+ (eq 'embed (first reason))
+ (or (third reason) t))))
+
+(defun row-rewrites-used (row)
+ (let ((reason (row-reason row)))
+ (cond
+ ((and (consp reason) (eq 'rewrite (first reason)))
+ (rrest reason))
+ (t
+ nil))))
+
+(defun (setf row-rewrites-used) (value row)
+ (let ((reason (row-reason row)))
+ (cond
+ ((and (consp reason) (eq 'rewrite (first reason)))
+ (cl:assert (tailp (rrest reason) value))
+ (setf (row-reason row) (list* 'rewrite (second reason) value)))
+ (value
+ (setf (row-reason row) (list* 'rewrite reason value))))
+ value))
+
+(defun row-level (row)
+ (or (row-level0 row)
+ (setf (row-level0 row)
+ (labels
+ ((row-level* (reason)
+ (ecase (if (consp reason) (first reason) reason)
+ ((resolve hyperresolve negative-hyperresolve ur-resolve ur-pttp paramodulate combine)
+ (+ 1 (loop for parent in (rest reason)
+ when (row-p parent)
+ maximize (row-level parent))))
+ ((rewrite factor condense embed case-split purify)
+ ;; ignore level of rewriters
+ (let ((parent (second reason)))
+ (if (row-p parent)
+ (row-level parent)
+ (row-level* parent))))
+ ((assertion assumption negated_conjecture hint)
+ 0)
+ (and
+ (loop for reason in (rest reason)
+ minimize (row-level* reason))))))
+ (row-level* (row-reason row))))))
+
+(defun row-clause-p (row)
+ (clause-p (row-wff row)))
+
+(defun row-unit-p (row)
+ (literal-p (row-wff row)))
+
+(defun row-bare-p (row)
+ (and (eq false (row-answer row))
+ (not (row-constrained-p row))
+;; (null (row-dp-alist row))
+ ))
+
+(defun row-bare-unit-p (row)
+ (and (row-unit-p row)
+ (row-bare-p row)))
+
+(defun row-positive-p (row)
+ (let ((v (row-positive-or-negative row)))
+ (when (eq none v)
+ (setf v (setf (row-positive-or-negative row) (wff-positive-or-negative (row-wff row)))))
+ (eq :pos v)))
+
+(defun row-negative-p (row)
+ (let ((v (row-positive-or-negative row)))
+ (when (eq none v)
+ (setf v (setf (row-positive-or-negative row) (wff-positive-or-negative (row-wff row)))))
+ (eq :neg v)))
+
+(defun row-variables (row &optional vars)
+ (setf vars (variables (row-wff row) nil vars))
+ (setf vars (variables (row-constraints row) nil vars))
+ (setf vars (variables (row-answer row) nil vars))
+ vars)
+
+(defun row-supported-inheritably (row)
+ (let ((supported (row-supported row)))
+ (and supported
+ (neq :uninherited supported))))
+
+(defun row-sequential-inheritably (row)
+ (let ((sequential (row-sequential row)))
+ (and sequential
+ (neq :uninherited sequential))))
+
+(defun make-rowset (&optional (rowsets *rowsets*))
+ (if rowsets
+ (let ((n (nonce)))
+ (values (setf (sparse-matrix-column rowsets n) t) n))
+ (make-sparse-vector)))
+
+(defun rowset-size (rowset)
+ (sparse-vector-count rowset))
+
+(defun rowset-insert (row rowset)
+ (let ((num (row-number row)))
+ (and (not (sparef rowset num))
+ (setf (sparef rowset num) row))))
+
+(defun rowset-delete (row rowset)
+ (when rowset
+ (let ((num (row-number row)))
+ (setf (sparef rowset num) nil))))
+
+(defun rowsets-delete (row &optional (rowsets *rowsets*))
+ ;; delete row from every rowset it is in
+ (when rowsets
+ (let ((num (row-number row)))
+ (setf (sparse-matrix-row rowsets num) nil))))
+
+(defun rowsets-delete-column (rowset)
+ (when rowset
+ (let ((type (snark-sparse-array::sparse-vector-type rowset)))
+ (when (eq 'snark-sparse-array::column (first type))
+ (setf (sparse-matrix-column (second type) (third type)) nil)))))
+
+(defun rowset-empty? (rowset)
+ (or (null rowset) (eql 0 (sparse-vector-count rowset))))
+
+(defun map-rows-in-reason (fn x)
+ (cond
+ ((consp x)
+ (map-rows-in-reason fn (car x))
+ (map-rows-in-reason fn (cdr x)))
+ ((row-p x)
+ (funcall fn x)
+ nil)))
+
+(defun rows-in-reason (x &optional rows)
+ (cond
+ ((consp x)
+ (rows-in-reason (cdr x) (rows-in-reason (car x) rows)))
+ ((row-p x)
+ (adjoin x rows))
+ (t
+ rows)))
+
+(defun row-ancestry-rowset (rows)
+ (let ((rowset (make-rowset nil)))
+ (labels
+ ((row-ancestry-rowset* (x)
+ (when (and (row-p x) (rowset-insert x rowset))
+ (dolist (x (rows-in-reason (row-rewrites-used x) (rows-in-reason (row-reason x))))
+ (row-ancestry-rowset* x)))))
+ (dolist (row rows)
+ (row-ancestry-rowset* row))
+ rowset)))
+
+(defun row-ancestry (row)
+ (let ((result nil) result-last)
+ (prog->
+ (map-sparse-vector (row-ancestry-rowset (list row)) ->* row)
+ (collect row result))
+ result))
+
+(defun row (name-or-number &optional not-found-action)
+ ;; Return the row named or numbered by the argument.
+ ;; If error-p is true, it is an error if the row cannot be found;
+ ;; otherwise, nil is returned if the row cannot be found.
+ (cond
+ ((row-p name-or-number) ;also allow a row itself as argument
+ name-or-number)
+ ((numberp name-or-number)
+ (when (minusp name-or-number)
+ (setf name-or-number (+ *number-of-rows* name-or-number 1)))
+ (or (sparef *rows* name-or-number)
+ (and not-found-action (funcall not-found-action "There is no row numbered ~D." name-or-number))))
+ (t
+ (let ((number (gethash name-or-number *row-names*)))
+ (or (and number (sparef *rows* number))
+ (and not-found-action (funcall not-found-action "There is no row named ~S." name-or-number)))))))
+
+(defun mapnconc-rows (cc &key (rowset *rows*) min max reverse test)
+ (when rowset
+ (let ((result nil) result-last)
+ (prog->
+ (map-sparse-vector rowset :min min :max max :reverse reverse ->* row)
+ (when (implies test (funcall test row))
+ (cond
+ ((null cc)
+ (collect row result))
+ (t
+ (ncollect (funcall cc row) result)))))
+ result)))
+
+(defun map-rows (cc &key (rowset *rows*) min max reverse test)
+ (when rowset
+ (if (null test)
+ (map-sparse-vector cc rowset :min min :max max :reverse reverse)
+ (prog->
+ (map-sparse-vector rowset :min min :max max :reverse reverse ->* row)
+ (when (funcall test row)
+ (funcall cc row))))))
+
+(defun rows (&key (rowset *rows*) min max reverse test collect)
+ (when rowset
+ (let ((result nil) result-last)
+ (prog->
+ (map-sparse-vector rowset :min min :max max :reverse reverse ->* row)
+ (when (implies test (funcall test row))
+ (collect (if collect (funcall collect row) row) result)))
+ result)))
+
+(defun last-row ()
+ (last-sparef *rows*))
+
+(defun set-row-number (row number)
+ (cl:assert (null (row-number row)))
+ (setf (row-number row) number)
+ (let (v)
+ (cond
+ ((setf v (row-name row))
+ (setf (row-name row) nil)
+ (name-row row v))
+ ((setf v (row-conc-name row))
+ (name-row row (intern (to-string v number)))))))
+
+(defun name-row (row-id name)
+ (when (can-be-row-name name 'warn)
+ (let* ((row (if (row-p row-id) row-id (row row-id 'error)))
+ (number (row-number row)))
+ (cl:assert (integerp number))
+ (let ((number2 (gethash name *row-names*)))
+ (when (and number2 (neql number number2))
+ (warn "Naming row ~D ~A, but row ~D is already named ~A. Reusing the name." number name number2 name)))
+ (let ((name2 (row-name row)))
+ (when (and name2 (neql name name2))
+ (warn "Naming row ~D ~A, but row ~D is already named ~A. Renaming the row." number name number name2)))
+ (setf (gethash name *row-names*) number)
+ (setf (row-name row) name))))
+
+(defun print-ancestry (row &key more-rows format)
+ (prog->
+ (map-rows :rowset (row-ancestry-rowset (cons row more-rows)) ->* row)
+ (terpri)
+ (when more-rows
+ (princ (if (member row more-rows) "*" " ")))
+ (print-row row :format format)))
+
+(defun print-rows (&key (rowset *rows*) min max reverse (test (print-rows-test?)) ancestry format)
+ (if ancestry
+ (print-rows :rowset (row-ancestry-rowset (rows :rowset rowset :min min :max max :test test)) :reverse reverse :format format)
+ (prog->
+ (map-rows :rowset rowset :min min :max max :reverse reverse :test test ->* row)
+ (terpri)
+ (print-row row :format format))))
+
+;;; rows.lisp EOF
diff --git a/snark-20120808r02/src/simplification-ordering.abcl b/snark-20120808r02/src/simplification-ordering.abcl
new file mode 100644
index 0000000..e2169ca
Binary files /dev/null and b/snark-20120808r02/src/simplification-ordering.abcl differ
diff --git a/snark-20120808r02/src/simplification-ordering.lisp b/snark-20120808r02/src/simplification-ordering.lisp
new file mode 100644
index 0000000..e8d9181
--- /dev/null
+++ b/snark-20120808r02/src/simplification-ordering.lisp
@@ -0,0 +1,356 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: simplification-ordering.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(declaim
+ (special
+ *manual-ordering-results*
+ *negative-hyperresolution*))
+
+(defun manual-ordering-compare-terms (x y subst)
+ (setf x (renumber x subst))
+ (setf y (renumber y subst))
+ (let (v)
+ (cond
+ ((setf v (assoc (list x y) *manual-ordering-results* :test #'subsumed-p))
+ (cdr v))
+ ((setf v (assoc (list y x) *manual-ordering-results* :test #'subsumed-p))
+ (opposite-order (cdr v)))
+ (t
+ (loop
+ (format t "~%You must answer the following simplification-ordering question:")
+ (format t "~%~S~% is < or > or ? to~%~S" x y)
+ (format t "~%Answer =")
+ (setf v (read))
+ (cond
+ ((member v '(< > ?))
+ (setf *manual-ordering-results* (acons (list x y) v *manual-ordering-results*))
+ (return v))
+ (t
+ (format t "~&You must answer < or > or ?."))))))))
+
+(defun definition-p (x y)
+ (and (compound-p x)
+ (let ((args nil))
+ (and (not (function-occurs-p (head x) y nil))
+ (dolist (arg (args x) t)
+ (cond
+ ((and (variable-p arg)
+ (top-sort? (variable-sort arg))
+ (not (member arg args :test #'eq)))
+ (push arg args))
+ (t
+ (return nil))))
+ (member (instantiating-direction1 args (variables y)) '(> <>))))))
+
+(defun simplification-ordering-compare-terms0 (x y subst testval)
+ (let ((x x) (y y))
+ (when (dereference2
+ x y subst
+ :if-constant*constant (and (constant-boolean-valued-p x) (constant-boolean-valued-p y))
+ :if-constant*compound (and (function-boolean-valued-p (setf y (head y))) (constant-boolean-valued-p x))
+ :if-compound*constant (and (function-boolean-valued-p (setf x (head x))) (constant-boolean-valued-p y))
+ :if-compound*compound (and (function-boolean-valued-p (setf x (head x))) (function-boolean-valued-p (setf y (head y))) (not (eq x y))))
+ (return-from simplification-ordering-compare-terms0
+ (symbol-ordering-compare x y))))
+ (case (use-term-ordering?)
+ (:rpo
+ (rpo-compare-terms-top x y subst testval))
+ (:kbo
+ (kbo-compare-terms x y subst testval))
+ ((nil :manual)
+ (cond
+ ((equal-p x y subst)
+ '=)
+ ((occurs-p x y subst)
+ '<)
+ ((occurs-p y x subst)
+ '>)
+ ((use-term-ordering?)
+ (manual-ordering-compare-terms x y subst))
+ (t
+ '?)))
+ (otherwise
+ (funcall (use-term-ordering?) x y subst testval))))
+
+(defun simplification-ordering-compare-terms1 (x y &optional subst testval warn row)
+ (let ((dir (simplification-ordering-compare-terms0 x y subst testval)))
+ (when warn
+ (when (and (print-rewrite-orientation?)
+ (not (member (print-rows-when-derived?) '(nil :signal)))
+ (member dir '(< >))
+ row (row-number row))
+ (with-clock-on printing
+ (terpri-comment)
+ (format t "Oriented ~A ~A "
+ (row-name-or-number row)
+ (cond
+ ((eq '> dir) "left-to-right")
+ ((eq '< dir) "right-to-left")))))
+ (when (and (print-unorientable-rows?)
+ (not (member (print-rows-when-derived?) '(nil :signal)))
+ (not (member dir '(< > =))))
+ (with-clock-on printing
+ (terpri-comment)
+ (cond
+ ((and row (row-number row))
+ (format t "Could not orient ~A " (row-name-or-number row)))
+ (t
+ (format t "Could not orient ~A=~A " x y))))))
+ dir))
+
+(defun simplification-ordering-compare-terms (x y &optional subst testval warn row)
+ (with-clock-on ordering
+ (simplification-ordering-compare-terms1 x y subst testval warn row)))
+
+(defvar *simplification-ordering-compare-equality-arguments-hash-table*)
+
+(defun initialize-simplification-ordering-compare-equality-arguments-hash-table ()
+ (setf *simplification-ordering-compare-equality-arguments-hash-table*
+ (if (test-option2?)
+ (make-hash-table)
+ nil)))
+
+(defun simplification-ordering-compare-equality-arguments (equality subst &optional warn row)
+ (if (test-option2?)
+ (let* ((table *simplification-ordering-compare-equality-arguments-hash-table*)
+ (v (gethash equality table)))
+ (cond
+ ((null v)
+ (setf v (let ((args (args equality)))
+ (simplification-ordering-compare-terms
+ (first args) (second args) subst nil warn row)))
+ (cl:assert v)
+ (when (or (null subst) (eq '? v))
+ (setf (gethash equality table) v))
+ v)
+ ((or (null subst) (neq '? v))
+ v)
+ (t
+ (let ((args (args equality)))
+ (simplification-ordering-compare-terms
+ (first args) (second args) subst nil warn row)))))
+ (let ((args (args equality)))
+ (simplification-ordering-compare-terms
+ (first args) (second args) subst nil warn row))))
+
+(defun simplification-ordering-greaterp (x y subst)
+ (eq '> (simplification-ordering-compare-terms x y subst '>)))
+
+(defun instantiating-direction1 (xvars yvars)
+ (let ((x-has-var-not-in-y (dolist (xv xvars)
+ (when (dolist (yv yvars t)
+ (when (eql xv yv)
+ (return nil)))
+ (return t))))
+ (y-has-var-not-in-x (dolist (yv yvars)
+ (when (dolist (xv xvars t)
+ (when (eql xv yv)
+ (return nil)))
+ (return t)))))
+ (cond
+ (x-has-var-not-in-y
+ (cond
+ (y-has-var-not-in-x
+ nil)
+ (t
+ '>)))
+ (y-has-var-not-in-x
+ '<)
+ (t
+ '<>))))
+
+(defun instantiating-direction (x y subst)
+ ;; returns <> x and y have the same variables
+ ;; returns > if y's variables are proper subset of x's
+ ;; returns < if x's variables are proper subset of y's
+ ;; returns nil otherwise
+ (with-clock-on ordering
+ (instantiating-direction1 (variables x subst) (variables y subst))))
+
+
+(defun literal-ordering-a (atom1 polarity1 atom2 polarity2 &optional subst testval)
+ (declare (ignore polarity1 polarity2))
+ (simplification-ordering-compare-terms atom1 atom2 subst testval))
+
+(defun literal-ordering-p (atom1 polarity1 atom2 polarity2 &optional subst testval)
+ ;; positive literals are ordered; no ordering between negative literals
+ ;; negative literals are greater than positive literals
+ (case polarity1
+ (:pos
+ (case polarity2
+ (:pos
+ (simplification-ordering-compare-terms atom1 atom2 subst testval))
+ (:neg
+ '<)
+ (otherwise
+ '?)))
+ (:neg
+ (case polarity2
+ (:pos
+ '>)
+ (otherwise
+ '?)))
+ (otherwise
+ '?)))
+
+(defun literal-ordering-n (atom1 polarity1 atom2 polarity2 &optional subst testval)
+ ;; negative literals are ordered; no ordering between positive literals
+ ;; positive literals are greater than negative literals
+ (case polarity1
+ (:neg
+ (case polarity2
+ (:neg
+ (simplification-ordering-compare-terms atom1 atom2 subst testval))
+ (:pos
+ '<)
+ (otherwise
+ '?)))
+ (:pos
+ (case polarity2
+ (:neg
+ '>)
+ (otherwise
+ '?)))
+ (otherwise
+ '?)))
+
+
+(defun literal-is-not-dominated-in-clause-p (orderfun atom polarity clause subst)
+ (prog->
+ (map-atoms-in-clause clause ->* atom2 polarity2)
+ (when (and (neq atom atom2)
+ (not (do-not-resolve atom2))
+ (eq '< (funcall orderfun atom polarity atom2 polarity2 subst '<)))
+ (return-from literal-is-not-dominated-in-clause-p nil)))
+ t)
+
+(defun literal-is-not-dominating-in-clause-p (orderfun atom polarity clause subst)
+ (prog->
+ (map-atoms-in-clause clause ->* atom2 polarity2)
+ (when (and (neq atom atom2)
+ (not (do-not-resolve atom2))
+ (eq '> (funcall orderfun atom polarity atom2 polarity2 subst '>)))
+ (return-from literal-is-not-dominating-in-clause-p nil)))
+ t)
+
+(defun literal-satisfies-ordering-restriction-p (orderfun atom polarity wff &optional subst n)
+ (implies (clause-p wff)
+ (literal-is-not-dominated-in-clause-p
+ orderfun
+ (if (and subst n) (instantiate atom n) atom)
+ polarity
+ (if (and subst n) (instantiate wff n) wff)
+ subst)))
+
+
+(defun selected-atoms-in-row (row orderfun)
+ ;; which atoms in row are selected by orderfun before considering instantiation
+ (let* ((selections (row-selections-alist row))
+ (v (assoc (or orderfun 'no-literal-ordering) selections)))
+ (cond
+ (v
+ (cdr v))
+ (t
+ (let ((l nil))
+ (cond
+ ((row-sequential row) ;if sequential, select only the first atom
+ (prog->
+ (map-atoms-in-wff (row-wff row) ->* atom polarity)
+ (unless (do-not-resolve atom)
+ (setf l (list (list atom polarity)))
+ (return-from prog->))))
+ ((or (null orderfun) ;else if no orderfun or row is nonclausal,
+ (not (clause-p (row-wff row)))) ;select all of the atoms
+ (setf l (remove-if #'do-not-resolve (atoms-in-wff2 (row-wff row)) :key #'first)))
+ (t ;else use orderfun on literals of clause and
+ (prog-> ;return eq subset of (selected-atoms-in-row row nil)
+ (dolist (selected-atoms-in-row row nil) ->* x)
+ (values-list x -> atom polarity)
+ (cond
+ ((null l)
+ (setf l (list x)))
+ ((dolist (y l t) ;select atom if it is not dominated by any atom2
+ (mvlet (((list atom2 polarity2) y))
+ (when (eq '> (funcall orderfun atom2 polarity2 atom polarity nil '>))
+ (return nil))))
+ (setf l (nconc
+ (delete-if (lambda (y) ;deselect every atom2 that is dominated by atom
+ (mvlet (((list atom2 polarity2) y))
+ (eq '< (funcall orderfun atom2 polarity2 atom polarity nil '<))))
+ l)
+ (list x))))))))
+ (setf (row-selections-alist row) (acons (or orderfun 'no-literal-ordering) l selections))
+ l)))))
+
+(defun selected-atom-in-row-p (atom polarity row orderfun &optional subst n atom*)
+ (selected-atom-p atom polarity (selected-atoms-in-row row orderfun) orderfun subst n atom*))
+
+(defun selected-atom-p (atom polarity selected-atoms orderfun &optional subst n atom*)
+ ;; selected-atoms was computed by (selected-atoms-in-row row orderfun)
+ ;; to list which atoms are selected before considering instantiation
+ ;; both (p ?x ?y) and (p ?y ?x) might be in selected-atoms,
+ ;; but only one might be acceptable to selected-atom-p when ?x and ?y are instantiated
+ (let ((atom&polarity (literal-member-p atom polarity selected-atoms)))
+ (and atom&polarity ;is (atom polarity) in selected-atoms?
+ (implies (and orderfun subst)
+ (dolist (x selected-atoms t) ;is it still undominated after applying subst?
+ (unless (eq atom&polarity x)
+ (let ((atom2 (first x)) (polarity2 (second x)))
+ (when (eq '> (funcall orderfun
+ (instantiate atom2 n)
+ polarity2
+ (setq-once atom* (instantiate atom n))
+ polarity
+ subst
+ '>))
+ (return nil)))))))))
+
+(defun selected-atoms-in-hyperresolution-electrons-p (electrons subst)
+ (prog->
+ (hyperresolution-orderfun -> orderfun)
+ (hyperresolution-electron-polarity -> polarity)
+ (+ (length electrons) 1 -> k)
+ (dolist electrons t ->* x)
+ (values-list x -> rowk atomk atomk*)
+ (selected-atoms-in-row rowk orderfun -> selected-atoms-in-rowk)
+ (unless (selected-atom-p atomk polarity selected-atoms-in-rowk orderfun subst k atomk*)
+ (return nil))
+ (decf k)))
+
+
+(defmethod theory-rewrite (wff (theory (eql 'ordering)))
+ wff)
+
+(defmethod theory-simplify (wff (theory (eql 'ordering)))
+ ;; no decision procedure:
+ ;; only tests conjuncts singly
+ ;; only treats variables as universally quantified
+ (prog->
+ (map-atoms-in-wff-and-compose-result wff :neg ->* atom polarity)
+ (declare (ignore polarity))
+ (args atom -> args)
+ (ecase (function-name (head atom))
+ (ordering>
+ (ecase (simplification-ordering-compare-terms (first args) (second args)) (? atom) (> true) (< false) (= false)))
+ (ordering>=
+ (ecase (simplification-ordering-compare-terms (first args) (second args)) (? atom) (> true) (< false) (= true))))))
+
+;;; simplification-ordering.lisp EOF
diff --git a/snark-20120808r02/src/snark-pkg.lisp b/snark-20120808r02/src/snark-pkg.lisp
new file mode 100644
index 0000000..3e50807
--- /dev/null
+++ b/snark-20120808r02/src/snark-pkg.lisp
@@ -0,0 +1,308 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
+;;; File: snark-pkg.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :common-lisp-user)
+
+;;; package definitions for snark system
+
+(defpackage :snark
+ (:use :common-lisp
+ :snark-lisp
+ :snark-deque
+ :snark-sparse-array
+ :snark-numbering
+ :snark-agenda
+ :snark-infix-reader
+ :snark-feature
+ :snark-dpll)
+ (:import-from :common-lisp-user #:*compile-me*)
+ (:shadow #:terpri)
+ #-gcl (:shadow #:assert #:substitute #:variable #:row #:rows)
+ (:export
+ #:*hash-dollar-package* #:*hash-dollar-readtable* #:hash-dollar-prin1 #:hash-dollar-print
+ #:*compile-me*
+ #:profile #:sprofile
+ #:can-be-constant-name
+ #:can-be-free-variable-name
+ #:declare-cancellation-law
+ #:declare-snark-option
+ #:derivation-subsort-forms
+ #:function-logical-symbol-p
+ #:function-symbol-p
+ #:input-constant-symbol
+ #:input-function-symbol
+ #:input-relation-symbol
+ #:input-proposition-symbol
+ #:input-term
+ #:input-wff
+ #:atom-with-keywords-inputter
+ #:set-options #:let-options
+ #:make-snark-system
+ #:map-rows
+ #:matches-compound ;rewrite-compiler
+ #:matches-constant ;rewrite-compiler
+ #:print-agendas
+ #:print-ancestry
+ #:print-options
+ #:print-rewrites
+ #:print-row
+ #:print-rows
+ #:print-feature-tree
+ #:print-row-term
+ #:print-sort-theory
+ #:print-summary
+ #:print-symbol-ordering
+ #:print-symbol-table
+ #:print-term
+ #:read-assertion-file
+ #:refute-file
+ #:do-tptp-problem #:do-tptp-problem0 #:do-tptp-problem1
+ #:sort-name-p
+ #:sortal
+ #:temporal
+ #:term-to-lisp
+ #:var
+
+ #:initialize #:assume #:prove #:hint #:closure #:proof #:proofs #:answer #:answers
+ #:new-prove
+
+ #:give #:factor #:resolve #:hyperresolve #:negative-hyperresolve
+ #:paramodulate #:paramodulate-by #:ur-resolve #:rewrite #:condense
+ #:row #:rows #:name-row #:last-row #:it #:mark-as-given
+ #:delete-row #:delete-rows
+ #:assert-rewrite
+
+ #:make-row-context #:delete-row-context #:in-row-context
+ #:push-row-context #:pop-row-context #:new-row-context
+ #:current-row-context #:root-row-context
+
+ #:dereference
+ #:variable-p #:constant-p #:compound-p #:head #:args #:arg1 #:arg2
+ #:make-compound #:make-compound*
+ #:equal-p #:unify
+ #:constant-sort #:variable-sort #:term-sort
+ #:constant-name
+ #:function-name #:function-arity
+ #:row-name #:row-number #:row-name-or-number #:row-wff #:row-answer #:row-constraints
+ #:row-constrained-p #:row-ancestry #:row-reason #:row-rewrites-used #:row-parents
+
+ #:constant-documentation #:constant-author #:constant-source
+ #:function-documentation #:function-author #:function-source
+ #:sort-documentation #:sort-author #:sort-source
+ #:row-documentation #:row-author #:row-source #:row-input-wff
+
+ #:answer-if
+ #:~ #:&
+ #:=> #:<=>
+ #:? #:?x #:?y #:?z #:?u #:?v #:?w #:_
+ #:-- #:---
+
+ #:symbol-table-entries #:symbol-table-constant? #:symbol-table-function? #:symbol-table-relation?
+
+ #:read-infix-term
+ #:initialize-operator-syntax #:declare-operator-syntax #:declare-tptp-operators
+
+ #:assertion #:assumption #:conjecture #:negated_conjecture #:combine #:embed #:purify
+
+ #:|cnf| #:|fof| #:|tff| ;for TPTP
+ #:|axiom| #:|conjecture| #:|negated_conjecture| #:|assumption| #:|hypothesis|
+ #:|question| #:|negated_question|
+ #:|type|
+ #:|$tType| #:|$i| #:|$o| #:|$int| #:|$rat| #:|$real|
+ #:|$true| #:|$false|
+ #:|file|
+ #:|include|
+
+ #:declare-constant #:declare-proposition
+ #:declare-function #:declare-relation
+ #:declare-variable
+
+ #:declare-ordering-greaterp
+
+ #:declare-sort #:declare-subsort #:declare-sorts-incompatible
+ #:the-sort
+ #:sort-name
+ #:sort-intersection
+ #:subsort? #:sort-disjoint?
+
+ #:top-sort #:top-sort-a
+
+ #:declare-tptp-sort #:tptp-nonnumber
+
+ #:literal-ordering-a #:literal-ordering-n #:literal-ordering-p
+
+ #:checkpoint-theory #:uncheckpoint-theory #:restore-theory
+ #:suspend-snark #:resume-snark #:suspend-and-resume-snark
+
+ #:fifo #:lifo
+ #:row-depth #:row-size #:row-weight #:row-level
+ #:row-size+depth #:row-weight+depth
+ #:row-size+depth+level #:row-weight+depth+level
+ #:row-weight-limit-exceeded #:row-weight-before-simplification-limit-exceeded
+ #:row-wff&answer-weight+depth #:row-neg-size+depth
+ #:row-priority
+
+ #:in-language #:in-kb
+ #:when-system
+ #:has-author #:has-source #:my-source
+ #:has-documentation #:has-name
+ #:undefined
+
+ #:declare-jepd-relations
+ #:declare-rcc8-relations
+ #:declare-time-relations
+ #:region #:time-interval #:time-point
+ #:$$date-point #:$$utime-point
+ #:$$date-interval #:$$utime-interval
+
+ #:$$rcc8-dc #:$$rcc8-ec #:$$rcc8-po #:$$rcc8-tpp #:$$rcc8-ntpp #:$$rcc8-tppi #:$$rcc8-ntppi #:$$rcc8-eq
+ #:$$rcc8-dr #:$$rcc8-pp #:$$rcc8-p #:$$rcc8-ppi #:$$rcc8-pi #:$$rcc8-o #:$$rcc8-c
+ #:$$rcc8-tp #:$$rcc8-tpi
+ #:$$rcc8-not-tpp #:$$rcc8-not-ntpp #:$$rcc8-not-ec #:$$rcc8-not-po #:$$rcc8-not-eq #:$$rcc8-not-ntppi
+ #:$$rcc8-not-tppi #:$$rcc8-not-pp #:$$rcc8-not-p #:$$rcc8-not-ppi #:$$rcc8-not-pi #:$$rcc8-not-tp #:$$rcc8-not-tpi
+
+ ;; 3 primitive temporal point-point relations
+ #:$$time-pp-before #:$$time-pp-equal #:$$time-pp-after
+
+ ;; nonprimitive temporal point-point relations
+ #:$$time-pp-not-before #:$$time-pp-not-equal #:$$time-pp-not-after
+
+ ;; 13 primitive temporal interval-interval relations
+ #:$$time-ii-before #:$$time-ii-during #:$$time-ii-overlaps #:$$time-ii-meets #:$$time-ii-starts
+ #:$$time-ii-finishes #:$$time-ii-equal #:$$time-ii-finished-by #:$$time-ii-started-by
+ #:$$time-ii-met-by #:$$time-ii-overlapped-by #:$$time-ii-contains #:$$time-ii-after
+ #:$$time-ii-contained-by ;alias of time-ii-during
+
+ ;; nonprimitive temporal interval-interval relations
+ #:$$time-ii-starts-before #:$$time-ii-starts-equal #:$$time-ii-starts-after
+ #:$$time-ii-finishes-before #:$$time-ii-finishes-equal #:$$time-ii-finishes-after
+ #:$$time-ii-subsumes #:$$time-ii-subsumed-by
+ #:$$time-ii-disjoint #:$$time-ii-intersects
+ #:$$time-ii-not-before #:$$time-ii-not-during #:$$time-ii-not-overlaps #:$$time-ii-not-meets
+ #:$$time-ii-not-starts #:$$time-ii-not-finishes #:$$time-ii-not-equal
+ #:$$time-ii-not-finished-by #:$$time-ii-not-started-by
+ #:$$time-ii-not-met-by #:$$time-ii-not-overlapped-by #:$$time-ii-not-contains #:$$time-ii-not-after
+ #:$$time-ii-not-starts-before #:$$time-ii-not-starts-equal #:$$time-ii-not-starts-after
+ #:$$time-ii-not-finishes-before #:$$time-ii-not-finishes-equal #:$$time-ii-not-finishes-after
+ #:$$time-ii-not-subsumes #:$$time-ii-not-subsumed-by
+
+ ;; 5 primitive temporal point-interval relations
+ #:$$time-pi-before #:$$time-pi-starts #:$$time-pi-during #:$$time-pi-finishes #:$$time-pi-after
+ #:$$time-ip-before #:$$time-ip-started-by #:$$time-ip-contains #:$$time-ip-finished-by #:$$time-ip-after
+ #:$$time-pi-contained-by ;alias of time-pi-during
+
+ ;; nonprimitive temporal point-interval relations
+ #:$$time-pi-disjoint #:$$time-pi-intersects
+ #:$$time-pi-not-before #:$$time-pi-not-starts #:$$time-pi-not-during #:$$time-pi-not-finishes #:$$time-pi-not-after
+ #:$$time-ip-disjoint #:$$time-ip-intersects
+ #:$$time-ip-not-after #:$$time-ip-not-started-by #:$$time-ip-not-contains #:$$time-ip-not-finished-by #:$$time-ip-not-before
+
+ #:$$numberp #:$$realp #:$$rationalp #:$$integerp #:$$naturalp #:$$complexp
+
+ #:$$eq
+ #:$$less
+ #:$$lesseq
+ #:$$greater
+ #:$$greatereq
+ #:$$sum
+ #:$$product
+ #:$$difference
+ #:$$uminus
+ #:$$quotient
+ #:$$reciprocal
+ #:$$abs
+ #:$$realpart
+ #:$$imagpart
+ #:$$floor
+ #:$$ceiling
+ #:$$truncate
+ #:$$round
+ #:$$quotient_f #:$$quotient_c #:$$quotient_t #:$$quotient_r #:$$quotient_e
+ #:$$remainder_f #:$$remainder_c #:$$remainder_t #:$$remainder_r #:$$remainder_e
+
+ #:$$$less #:$$$lesseq #:$$$greater #:$$$greatereq
+
+ #:$$eqe
+
+ #:$$quote
+
+ #:$$cons #:$$list #:$$list*
+ #:$$listp
+;; #:$$term-to-list #:$$list-to-term #:$$list-to-atom
+
+ #:$$stringp #:$$string-to-list #:$$list-to-string
+
+ #:$$bag #:$$bag*
+ #:$$bag-union
+ #:$$bagp
+ #:$$bag-to-list #:$$list-to-bag
+
+ #:bag
+
+ #:$$flat-bag #:$$flat-list #:$$empty-flat-bag #:$$empty-flat-list
+
+ #:positive #:positive-real #:positive-rational #:positive-integer #:positive-number
+ #:negative #:negative-real #:negative-rational #:negative-integer #:negative-number
+ #:nonnegative #:nonnegative-real #:nonnegative-rational #:nonnegative-integer #:nonnegative-number
+ #:nonzero #:nonzero-real #:nonzero-rational #:nonzero-integer #:nonzero-number
+ #:nonpositive
+ #:zero
+ #:natural
+
+ #:the-string
+ #:the-list
+ #:the-bag
+ #:the-number #:the-real #:the-complex
+ #:the-rational
+ #:the-integer
+
+ #:the-positive
+ #:the-negative
+ #:the-nonpositive
+ #:the-nonnegative
+ #:the-nonzero
+ #:the-zero
+
+ #:the-positive-integer
+ #:the-nonnegative-integer
+ #:the-natural
+
+ #:*tptp-environment-variable*
+ #:*tptp-format*
+ #:*tptp-input-directory*
+ #:*tptp-input-directory-has-domain-subdirectories*
+ #:*tptp-input-file-type*
+ #:*tptp-output-directory*
+ #:*tptp-output-directory-has-domain-subdirectories*
+ #:*tptp-output-file-type*
+
+ #:save-snark-system
+ #:with-no-output
+ ))
+
+(defpackage :snark-user
+ (:use :common-lisp
+ :snark-lisp
+ :snark-deque
+ :snark-sparse-array
+ :snark-dpll
+ :snark)
+ (:shadowing-import-from :snark #:assert))
+
+;;; snark-pkg.lisp EOF
diff --git a/snark-20120808r02/src/solve-sum.abcl b/snark-20120808r02/src/solve-sum.abcl
new file mode 100644
index 0000000..46c7452
Binary files /dev/null and b/snark-20120808r02/src/solve-sum.abcl differ
diff --git a/snark-20120808r02/src/solve-sum.lisp b/snark-20120808r02/src/solve-sum.lisp
new file mode 100644
index 0000000..e6e53b1
--- /dev/null
+++ b/snark-20120808r02/src/solve-sum.lisp
@@ -0,0 +1,95 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: solve-sum.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun solve-sum (cc sum coefs &optional bounds)
+ ;; find xi such that 0 <= xi <= boundi and coef1*x1 + ... + coefn*xn = sum
+ ;; sum >= 0, each coefi > 0, each boundi >= 0, all integers
+ ;; |coefs| = |bounds| > 0 (bounds can also be nil)
+ ;; applies cc to each solution
+ ;; returns nil if unsolvable due to bounds
+ ;; (solve-sum #'print 29 '(1 5 10 25) '(4 3))
+ ;; prints how to make 29 cents using at most 4 pennies and 3 nickels
+ (cond
+ ((eql 0 sum)
+ (funcall cc nil) ;use nil instead of final zeroes
+ t)
+ (t
+ (let ((c (pop coefs))
+ (b (pop bounds)))
+ (cond
+ ((null coefs)
+ (mvlet (((values q r) (truncate sum c)))
+ (when (or (null b) (>= b q))
+ (when (eql 0 r)
+ (funcall cc (list q)))
+ t)))
+ ((eql 0 b)
+ (solve-sum (lambda (sol) (funcall cc (cons 0 sol))) sum coefs bounds))
+ (t
+ (let* ((k (if b (min b (truncate sum c)) (truncate sum c)))
+ (k1 k))
+ (decf sum (* k1 c))
+ (loop
+ (cond
+ ((solve-sum (lambda (sol) (funcall cc (cons k1 sol))) sum coefs bounds)
+ (cond
+ ((eql 0 k1)
+ (return t))
+ (t
+ (decf k1)
+ (incf sum c))))
+ (t
+ (return (neql k k1))))))))))))
+
+(defun solve-sum-p (sum coefs &optional bounds)
+ (or (eql 0 sum)
+ (and (null bounds)
+ (member 1 coefs))
+ (block it
+ (solve-sum (lambda (sol)
+ (declare (ignore sol))
+ (return-from it t))
+ sum coefs bounds)
+ nil)))
+
+(defun solve-sum-solutions (sum coefs &optional bounds)
+ (cond
+ ;; handle some frequent special cases first
+ ;; (solve-sum-solutions 1 '(1)) => ((1))
+ ((and (eql 1 sum)
+ (null (rest coefs)))
+ (and (eql 1 (first coefs))
+ (neql 0 (first bounds))
+ '((1))))
+ ;; (solve-sum-solutions 1 '(1 1)) => ((1) (0 1))
+ ((and (eql 1 sum)
+ (null (rrest coefs))
+ (eql 1 (first coefs))
+ (neql 0 (first bounds))
+ (eql 1 (second coefs))
+ (neql 0 (second bounds)))
+ '((1) (0 1)))
+ (t
+ (let ((sols nil) sols-last)
+ (solve-sum (lambda (sol) (collect sol sols)) sum coefs bounds)
+ sols))))
+
+;;; solve-sum.lisp EOF
diff --git a/snark-20120808r02/src/sorts-functions.abcl b/snark-20120808r02/src/sorts-functions.abcl
new file mode 100644
index 0000000..35ae964
Binary files /dev/null and b/snark-20120808r02/src/sorts-functions.abcl differ
diff --git a/snark-20120808r02/src/sorts-functions.lisp b/snark-20120808r02/src/sorts-functions.lisp
new file mode 100644
index 0000000..a421551
--- /dev/null
+++ b/snark-20120808r02/src/sorts-functions.lisp
@@ -0,0 +1,81 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: sorts-functions.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; an argument-sort-alist (asa) is an alist of argument-ids and argument-sorts like
+;;; ((2 . arg2-sort) (1 . arg1-sort) (t . default-arg-sort))
+
+(defun asa-arg-sort (asa argid)
+ ;; find in asa the sort restriction for argument argid
+ ;; argid is an argument number or a key in the case of alist/plist functions/relations
+ (dolist (p asa (top-sort))
+ (let ((key (car p)))
+ (when (or (eql argid key) (eq t key))
+ (return (cdr p))))))
+
+(defun input-argument-sort-alist (function l)
+ ;; input-argument-sort-alist inputs argument sort restrictions of the form
+ ;; ((2 arg2-sort) (1 arg1-sort) (t default-arg-sort))
+ ;; that are recognized by can-be-argument-sort-alist-p1
+ ;;
+ ;; it also converts old-style declarations of the form
+ ;; (arg1-sort arg2-sort)
+ ;; that are recognized by can-be-argument-sort-alist-p2
+ (cond
+ ((null l)
+ nil)
+ ((can-be-argument-sort-alist-p1 function l)
+ (mapcar (lambda (p) (cons (first p) (the-sort (second p)))) l))
+ ((can-be-argument-sort-alist-p2 function l)
+ (let ((i 0)) (mapcar (lambda (s) (cons (incf i) (the-sort s))) l)))
+ (t
+ (with-standard-io-syntax2
+ (error "The sort of the argument list of ~A ~S cannot be ~S." ;not very informative
+ (function-kind function) (function-name function) l)))))
+
+(defun can-be-argument-sort-alist-p1 (function l)
+ (and (consp l)
+ (let* ((arity (function-arity function))
+ (can-be-key-p (cond
+ ((naturalp arity)
+ (lambda (x) (and (integerp x) (<= 1 x arity))))
+ (t
+ (ecase arity
+ (:any #'naturalp))))))
+ (dotails (l l t)
+ (let ((p (first l)))
+ (unless (and (consp p)
+ (if (eq t (first p))
+ (null (rest l))
+ (funcall can-be-key-p (first p)))
+ (consp (rest p))
+ (null (rrest p))
+ (the-sort (second p)))
+ (return nil)))))))
+
+(defun can-be-argument-sort-alist-p2 (function l)
+ (and (consp l)
+ (let ((arity (function-arity function)))
+ (and (or (naturalp arity) (eq :any arity))
+ (every (lambda (s)
+ (the-sort s))
+ l)))))
+
+;;; sorts-functions.lisp EOF
diff --git a/snark-20120808r02/src/sorts-interface.abcl b/snark-20120808r02/src/sorts-interface.abcl
new file mode 100644
index 0000000..974ec45
Binary files /dev/null and b/snark-20120808r02/src/sorts-interface.abcl differ
diff --git a/snark-20120808r02/src/sorts-interface.lisp b/snark-20120808r02/src/sorts-interface.lisp
new file mode 100644
index 0000000..340c7bb
--- /dev/null
+++ b/snark-20120808r02/src/sorts-interface.lisp
@@ -0,0 +1,180 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: sorts-interface.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; this file implements SNARK's sort system based on snark-features
+;;; interfacing to a different sort system in SNARK should be possible by replacing this file
+
+(defvar *top-sort*)
+
+(definline top-sort-name ()
+ 'top-sort)
+
+(defun top-sort-name? (x)
+ (or (eq 'top-sort x) (eq :top-sort x) (eq t x) (eq 'true x) (eq true x)))
+
+(defun initialize-sort-theory ()
+ (setf *top-sort* (declare-feature (top-sort-name)))
+ nil)
+
+(defun print-sort-theory ()
+ (print-feature-tree :node (top-sort)))
+
+(definline top-sort ()
+ *top-sort*)
+
+(definline same-sort? (x y)
+ (eq x y))
+
+(definline top-sort? (x)
+ (same-sort? (top-sort) x))
+
+(defun subsort0 (x y)
+ (with-clock-on sortal-reasoning
+ (feature-subsumes? y x)))
+
+(definline subsort? (x y)
+ ;; returns true for both identical sorts and strict subsorts
+ (or (same-sort? x y)
+ (top-sort? y)
+ (if (top-sort? x) nil (subsort0 x y))))
+
+(definline subsort1? (x y)
+;;(cl:assert (not (top-sort? y)))
+ (or (same-sort? x y)
+ (if (top-sort? x) nil (subsort0 x y))))
+
+(defun sort-intersection0 (x y)
+ ;; returns canonical intersection of x and y, nil if x and y are incompatible
+ (with-clock-on sortal-reasoning
+ (feature-union x y)))
+
+(definline sort-intersection (x y)
+ (cond
+ ((or (same-sort? x y) (top-sort? x))
+ y)
+ ((top-sort? y)
+ x)
+ (t
+ (sort-intersection0 x y))))
+
+(definline sort-disjoint? (x y)
+ (null (sort-intersection x y)))
+
+(defun sort? (x)
+ (and (or (feature? x) (snark-feature::feature-combo? x))
+ (feature-subsumes? (top-sort) x)))
+
+(defun sort-name (sort)
+ (let ((sort-name (snark-feature::feature-sym sort)))
+ (cl:assert (not (null sort-name)) () "There is no sort named ~S." sort)
+ sort-name))
+
+(defun sort-name? (x &optional action)
+ ;; returns actual sort if x is a sort-name, nil otherwise
+ (or (and (top-sort-name? x) (top-sort))
+ (let ((v (find-symbol-table-entry x :sort)))
+ (and (neq none v) v))
+ (and action (funcall action "There is no sort named ~S." x))))
+
+(defun sort-name-expression? (x &optional action)
+ ;; allows conjunction of sort names too
+ (cond
+ ((atom x)
+ (sort-name? x action))
+ ((eq 'and (first x))
+ (every #'(lambda (x) (sort-name-expression? x action)) (rest x)))
+ (t
+ (and action (funcall action "~S is not a sort expression." x)))))
+
+(defun fix-sort-name-expression (x)
+ (cond
+ ((atom x)
+ (sort-name? x 'error))
+ ((eq 'and (first x))
+ (cons 'and (mapcar #'fix-sort-name-expression (rest x))))))
+
+(defun the-sort (sort-expr &optional (action 'error))
+ (or (sort-name? sort-expr)
+ (let ((x (the-feature (fix-sort-name-expression sort-expr) nil 'error)))
+ (and x (feature-subsumes? (top-sort) x) x)) ;make sure the feature is specifically a sort
+ (and action (funcall action "~S has not been declared as a sort." sort-expr))))
+
+;;; user operations for defining a sort theory:
+;;; declare-sort
+;;; declare-subsort
+;;; declare-sorts-incompatible
+;;;
+;;; sorts can be declared only once
+;;; sorts must be declared before they are used
+;;; sort incompatibilities must be declared before incompatible sorts are used
+
+(defun declare-sort1 (sort-name sort)
+ (can-be-sort-name sort-name 'error)
+ (find-or-create-symbol-table-entry sort-name :sort nil sort)
+ (let ((sort-name* (intern (symbol-name sort-name) :snark-user)))
+ (unless (eq sort-name sort-name*)
+ ;; put the sort name into snark-user package so that sort-from-variable-name can find it
+ (find-or-create-symbol-table-entry sort-name* :sort nil sort)))
+ (when (test-option30?)
+ (declare-the-sort-function-symbol sort-name sort))
+ sort)
+
+(defun declare-sort (sort-name &key iff subsorts-incompatible alias)
+ (cl:assert (not (and iff subsorts-incompatible)))
+ (let ((sort (sort-name? sort-name)))
+ (cond
+ (sort
+ (when (or iff subsorts-incompatible (null alias))
+ (warn "Ignoring sort declaration; ~S has already been declared." sort-name)))
+ (t
+ (setf sort (declare-sort1
+ sort-name
+ (cond
+ (iff
+ (with-clock-on sortal-reasoning
+ (declare-feature sort-name :iff (the-sort iff))))
+ (t
+ (with-clock-on sortal-reasoning
+ (declare-feature sort-name :parent (the-sort (declare-root-sort?)) :children-incompatible subsorts-incompatible))))))))
+ (when alias
+ (create-aliases-for-symbol sort alias))
+ sort))
+
+(defun declare-subsort (sort-name supersort-expr &key subsorts-incompatible alias)
+ (let ((sort (sort-name? sort-name)))
+ (cond
+ (sort
+ (when (or subsorts-incompatible (null alias))
+ (warn "Ignoring sort declaration; ~S has already been declared." sort-name)))
+ (t
+ (setf sort (declare-sort1
+ sort-name
+ (with-clock-on sortal-reasoning
+ (declare-feature sort-name :implies (the-sort supersort-expr) :children-incompatible subsorts-incompatible))))))
+ (when alias
+ (create-aliases-for-symbol sort alias))
+ sort))
+
+(defun declare-sorts-incompatible (sort-name1 sort-name2 &rest more-sort-names)
+ (with-clock-on sortal-reasoning
+ (apply 'declare-features-incompatible sort-name1 sort-name2 more-sort-names)))
+
+;;; sorts-interface.lisp EOF
diff --git a/snark-20120808r02/src/sorts.abcl b/snark-20120808r02/src/sorts.abcl
new file mode 100644
index 0000000..4df4249
Binary files /dev/null and b/snark-20120808r02/src/sorts.abcl differ
diff --git a/snark-20120808r02/src/sorts.lisp b/snark-20120808r02/src/sorts.lisp
new file mode 100644
index 0000000..a927dd1
--- /dev/null
+++ b/snark-20120808r02/src/sorts.lisp
@@ -0,0 +1,284 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: sorts.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun declare-the-sort-function-symbol (name sort)
+ (declare-function
+ (intern (to-string :the- name) :snark-user) 1
+ :sort name
+ :rewrite-code (lambda (term subst)
+ (let ((x (arg1 term)))
+ (if (subsort? (term-sort x subst) sort) x none)))))
+
+(defun declare-constant-sort (constant sort)
+ "assigns a sort to a constant"
+ (let* ((sort (the-sort sort))
+ (old-sort (constant-sort constant))
+ (new-sort (sort-intersection old-sort sort)))
+ (cond
+ ((same-sort? old-sort new-sort)
+ )
+ ((null new-sort)
+ (error "Cannot declare ~A as constant of sort ~A; ~A is of incompatible sort ~A." constant sort constant old-sort))
+ (t
+ (setf (constant-sort constant) new-sort))))
+ constant)
+
+(defun declare-function-sort (function sort-spec)
+ (cond
+ ((function-boolean-valued-p function)
+ (setf (function-argument-sort-alist function) (input-argument-sort-alist function sort-spec)))
+ ((sort-name-expression? sort-spec nil)
+ (setf (function-sort function) (the-sort sort-spec)))
+ (t
+ (setf (function-sort function) (the-sort (first sort-spec)))
+ (setf (function-argument-sort-alist function) (input-argument-sort-alist function (rest sort-spec)))))
+ (when (function-associative function)
+ (check-associative-function-sort function))
+ nil)
+
+(defvar *%check-for-well-sorted-atom%* t)
+
+(defun check-for-well-sorted-atom (atom &optional subst)
+ (when *%check-for-well-sorted-atom%*
+ (assert-atom-is-well-sorted atom subst))
+ atom)
+
+(defun assert-atom-is-well-sorted (atom &optional subst)
+ (or (well-sorted-p atom subst)
+ (error "Atomic formula ~A is not well sorted." (term-to-lisp atom subst))))
+
+(defun check-well-sorted (x &optional subst)
+ (unless (well-sorted-p x subst)
+ (error "~A is not well sorted." (term-to-lisp x subst)))
+ x)
+
+(defvar *%checking-well-sorted-p%* nil)
+
+(defun well-sorted-p (x &optional subst (sort (top-sort)))
+ ;; determines if expression is well sorted
+ ;; it does this by doing well-sorting on the expression
+ ;; with the restriction that no instantiation be done
+ (prog->
+ (quote t -> *%checking-well-sorted-p%*)
+ (well-sort x subst sort ->* subst)
+ (declare (ignore subst))
+ (return-from prog-> t)))
+
+(defun well-sorted-args-p (args subst fsd &optional (argcount 0))
+ (prog->
+ (quote t -> *%checking-well-sorted-p%*)
+ (well-sort-args args subst fsd argcount ->* subst)
+ (declare (ignore subst))
+ (return-from prog-> t)))
+
+(defun term-sort (term &optional subst)
+ ;; return sort of well-sorted term
+ (dereference
+ term subst
+ :if-variable (variable-sort term)
+ :if-constant (constant-sort term)
+ :if-compound (compound-sort term subst)))
+
+(defun compound-sort (term &optional subst)
+ (let ((head (head term)))
+ (dolist (fun (function-sort-code head) (function-sort head))
+ (let ((v (funcall fun term subst)))
+ (unless (or (null v) (eq none v))
+ (return v))))))
+
+(defun well-sort (cc x &optional subst (sort (top-sort)))
+ (dereference
+ x subst
+ :if-variable (cond
+ ((variable-sort-p x sort)
+ (funcall cc subst))
+ (*%checking-well-sorted-p%*
+ )
+ ((subsort? sort (variable-sort x))
+ (funcall cc (bind-variable-to-term x (make-variable sort) subst)))
+ (t
+ (let ((sort (sort-intersection sort (variable-sort x))))
+ (unless (null sort)
+ (funcall cc (bind-variable-to-term x (make-variable sort) subst))))))
+ :if-constant (when (constant-sort-p x sort)
+ (funcall cc subst))
+ :if-compound (prog->
+ (well-sort-args (args x) subst (function-argument-sort-alist (head x)) ->* subst)
+ (when (subsort? (term-sort x subst) sort)
+ (funcall cc subst))))
+ nil)
+
+(defun well-sort-args (cc args subst asa &optional (argcount 0))
+ (dereference
+ args subst
+ :if-constant (funcall cc subst)
+ :if-variable (funcall cc subst)
+ :if-compound-appl (funcall cc subst)
+ :if-compound-cons (prog->
+ (well-sort (carc args) subst (asa-arg-sort asa (incf argcount)) ->* subst)
+ (well-sort-args (cdrc args) subst asa argcount ->* subst)
+ (funcall cc subst)))
+ nil)
+
+(defun well-sort-atoms (cc atoms subst)
+ (cond
+ ((null atoms)
+ (funcall cc subst))
+ (t
+ (prog->
+ (well-sort (first atoms) subst ->* subst)
+ (well-sort-atoms (rest atoms) subst ->* subst)
+ (funcall cc subst)))))
+
+(defun well-sort-atoms1 (cc atoms subst)
+ (prog->
+ (quote t -> first)
+ (well-sort-which-atoms atoms subst -> atoms)
+ (replace-skolem-terms-by-variables-in-atoms atoms subst -> atoms2 sksubst)
+ (well-sort-atoms atoms2 subst ->* subst)
+ (unless (fix-skolem-term-sorts sksubst first subst)
+ (cerror "Use only first instance."
+ "Input wff has more than well-sorted instance of existentially quantifed variable.")
+ (return-from prog->))
+ (setf first nil)
+ (funcall cc subst)))
+
+(defun well-sort-which-atoms (atoms &optional subst)
+ (prog->
+ (delete-if atoms ->* atom)
+ (cond
+ ((well-sorted-p atom subst)
+ t)
+ ((eq :terms (use-well-sorting?))
+ (cond
+ ((well-sorted-p (args atom) subst)
+ (warn "Atomic formula ~A is not well sorted.~%Its arguments are well sorted, so will continue." (term-to-lisp atom subst))
+ t)
+ (t
+ (warn "Atomic formula ~A is not well sorted.~%Will try to make its arguments well sorted and continue." (term-to-lisp atom subst))
+ nil)))
+ (t
+ (warn "Atomic formula ~A is not well sorted." (term-to-lisp atom subst))
+ nil))))
+
+(defun well-sort-wff (cc wff &optional subst)
+ (cond
+ ((use-well-sorting?)
+ (well-sort-atoms1 cc (atoms-in-wff wff subst) subst))
+ (t
+ (funcall cc subst))))
+
+(defun well-sort-wffs (cc wffs &optional subst)
+ (cond
+ ((use-well-sorting?)
+ (well-sort-atoms1 cc (atoms-in-wffs wffs subst) subst))
+ (t
+ (funcall cc subst))))
+
+(defun replace-skolem-terms-by-variables-in-atoms (atoms &optional subst)
+ ;; this garbage is for HPKB and is needed for
+ ;; automatic well-sorting of unsorted wffs with existential quantifiers,
+ ;; which shouldn't even be allowed
+ ;; intended for freshly skolemized formulas; no skolem terms embedded in skolem terms
+ (let ((sksubst nil))
+ (values
+ (prog->
+ (mapcar atoms ->* atom)
+ (map-terms-in-atom-and-compose-result atom subst ->* term polarity)
+ (declare (ignore polarity))
+ (dereference
+ term subst
+ :if-variable term
+ :if-constant (if (constant-skolem-p term)
+ (let ((v (lookup-value-in-substitution term sksubst)))
+ (when (eq none v)
+ (setf v (make-variable (constant-sort term)))
+ (setf sksubst (bind-variable-to-term v term sksubst)))
+ v)
+ term)
+ :if-compound (let ((fn (head term)))
+ (if (function-skolem-p fn)
+ (let ((v (lookup-value-in-substitution2 term sksubst subst)))
+ (when (eq none v)
+ (setf v (make-variable (function-sort fn)))
+ (setf sksubst (bind-variable-to-term v term sksubst)))
+ v)
+ term))))
+ sksubst)))
+
+(defun fix-skolem-term-sorts (sksubst first subst)
+ (dobindings (binding sksubst t)
+ (let ((sort (let ((var (binding-var binding)))
+ (dereference var subst)
+ (variable-sort var)))
+ (val (binding-value binding)))
+ (dereference
+ val nil
+ :if-constant (unless (same-sort? sort (constant-sort val))
+ (if first
+ (setf (constant-sort val) sort)
+ (return nil)))
+ :if-compound (let ((head (head val)))
+ (unless (same-sort? sort (function-sort head)))
+ (if first
+ (setf (function-sort head) sort)
+ (return nil)))))))
+
+
+(definline constant-sort-p (constant sort)
+ (or (top-sort? sort)
+ (subsort1? (constant-sort constant) sort)))
+
+(definline variable-sort-p (variable sort)
+ (or (top-sort? sort)
+ (subsort1? (variable-sort variable) sort)))
+
+(defun term-sort-p (term sort &optional subst)
+ (or (top-sort? sort)
+ (subsort1? (term-sort term subst) sort)))
+
+(defun term-subsort-p (term1 term2 &optional subst)
+ (or (dereference ;allows wffs for rewriting
+ term2 subst
+ :if-constant (constant-boolean-valued-p term2)
+ :if-compound-appl (function-boolean-valued-p (heada term2))
+ :if-variable (dereference
+ term1 subst
+ :if-constant (constant-boolean-valued-p term1)
+ :if-compound-appl (function-boolean-valued-p (head term1))))
+ (term-sort-p term1 (term-sort term2 subst) subst)))
+
+(defun sort-compatible-p (term1 term2 &optional subst)
+ (let ((sort2 (term-sort term2 subst)))
+ (or (top-sort? sort2) (not (sort-disjoint? (term-sort term1 subst) sort2)))))
+
+
+(defun check-associative-function-sort (fn)
+ ;; force sort specification to be of form (sort (t sort))
+ (let ((sort (function-sort fn))
+ (asa (function-argument-sort-alist fn)))
+ (unless (and (eq t (car (first asa))) (same-sort? sort (cdr (first asa))))
+ (setf (function-argument-sort-alist fn) (list (cons t sort)))
+ (unless (and (same-sort? sort (asa-arg-sort asa 1)) (same-sort? sort (asa-arg-sort asa 2)))
+ (warn "The associative function ~A is required to have arguments of sort ~A." fn sort)))
+ sort))
+
+;;; sorts.lisp EOF
diff --git a/snark-20120808r02/src/sparse-array-system.lisp b/snark-20120808r02/src/sparse-array-system.lisp
new file mode 100644
index 0000000..e9a2504
--- /dev/null
+++ b/snark-20120808r02/src/sparse-array-system.lisp
@@ -0,0 +1,49 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
+;;; File: sparse-array-system.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :common-lisp-user)
+
+(defpackage :snark-sparse-array
+ (:use :common-lisp :snark-lisp)
+ (:export
+ #:sparef
+ #:sparse-vector #:make-sparse-vector #:sparse-vector-p
+ #:sparse-vector-boolean #:sparse-vector-default-value
+ #:sparse-vector-count
+ #:map-sparse-vector #:map-sparse-vector-with-indexes #:map-sparse-vector-indexes-only
+ #:with-sparse-vector-iterator
+ #:first-sparef #:last-sparef #:pop-first-sparef #:pop-last-sparef
+ #:copy-sparse-vector #:spacons
+ #:sparse-matrix #:make-sparse-matrix #:sparse-matrix-p
+ #:sparse-matrix-boolean #:sparse-matrix-default-value
+ #:sparse-matrix-count
+ #:sparse-matrix-row #:sparse-matrix-column #:sparse-matrix-rows #:sparse-matrix-columns
+ #:map-sparse-matrix #:map-sparse-matrix-with-indexes #:map-sparse-matrix-indexes-only
+
+ #:sparse-vector-expression-p
+ #:map-sparse-vector-expression
+ #:map-sparse-vector-expression-with-indexes
+ #:map-sparse-vector-expression-indexes-only
+ #:optimize-sparse-vector-expression
+ #:uniond
+ ))
+
+(loads "sparse-vector5" "sparse-array" "sparse-vector-expression")
+
+;;; sparse-array-system.lisp EOF
diff --git a/snark-20120808r02/src/sparse-array.abcl b/snark-20120808r02/src/sparse-array.abcl
new file mode 100644
index 0000000..4a969ab
Binary files /dev/null and b/snark-20120808r02/src/sparse-array.abcl differ
diff --git a/snark-20120808r02/src/sparse-array.lisp b/snark-20120808r02/src/sparse-array.lisp
new file mode 100644
index 0000000..e26668e
--- /dev/null
+++ b/snark-20120808r02/src/sparse-array.lisp
@@ -0,0 +1,465 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-sparse-array -*-
+;;; File: sparse-array.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2006.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-sparse-array)
+
+;;; functions in this file should not depend on implementation details of sparse-vectors
+
+#+cormanlisp
+(defun (setf sparef1) (value sparse-vector index)
+ (declare (ignore value sparse-vector index))
+ (unimplemented))
+
+#+cormanlisp
+(defun (setf sparse-matrix-row) (value sparse-matrix index)
+ (declare (ignore value sparse-matrix index))
+ (unimplemented))
+
+#+cormanlisp
+(defun (setf sparse-matrix-column) (value sparse-matrix index)
+ (declare (ignore value sparse-matrix index))
+ (unimplemented))
+
+;;; ****s* snark-sparse-array/sparse-matrix
+;;; NAME
+;;; sparse-matrix structure
+;;; sparse-matrix type
+;;; SOURCE
+
+(defstruct (sparse-matrix
+ (:constructor make-sparse-matrix0 (default-value boolean rows columns))
+ (:print-function print-sparse-matrix3)
+ (:copier nil))
+ (default-value nil :read-only t)
+ (boolean nil :read-only t)
+ (rows nil :read-only t)
+ (columns nil :read-only t))
+;;; ***
+
+;;; ****f* snark-sparse-array/make-sparse-matrix
+;;; USAGE
+;;; (make-sparse-matrix &key boolean default-value rows columns)
+;;; RETURN VALUE
+;;; sparse-matrix
+;;; SOURCE
+
+(defun make-sparse-matrix (&key boolean default-value (rows t rows-supplied) (columns t columns-supplied))
+ (when boolean
+ (unless (null default-value)
+ (error "Default-value must be NIL for Boolean sparse-arrays.")))
+ (let ((rows (and (or (not columns) (if rows-supplied rows (not columns-supplied)))
+ (make-sparse-vector)))
+ (columns (and (or (not rows) (if columns-supplied columns (not rows-supplied)))
+ (make-sparse-vector))))
+ (let ((sparse-matrix (make-sparse-matrix0 default-value boolean rows columns)))
+ (when rows
+ (setf (sparse-vector-type rows) `(rows ,sparse-matrix)))
+ (when columns
+ (setf (sparse-vector-type columns) `(columns ,sparse-matrix)))
+ sparse-matrix)))
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-matrix-p
+;;; USAGE
+;;; (sparse-matrix-p x)
+;;; RETURN VALUE
+;;; true if x if a sparse-matrix, false otherwise
+;;; SOURCE
+
+ ;;sparse-matrix-p is defined by the sparse-matrix defstruct
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-matrix-boolean
+;;; USAGE
+;;; (sparse-matrix-boolean sparse-matrix)
+;;; RETURN VALUE
+;;; true if x is a boolean sparse-matrix, false otherwise
+;;; SOURCE
+ ;;sparse-matrix-boolean is defined as a slot in the sparse-matrix structure
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-matrix-default-value
+;;; USAGE
+;;; (sparse-matrix-boolean sparse-matrix)
+;;; RETURN VALUE
+;;; the default-value for unstored entries of sparse-matrix
+;;; SOURCE
+ ;;sparse-matrix-default-value is defined as a slot in the sparse-matrix structure
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-matrix-rows
+;;; USAGE
+;;; (sparse-matrix-rows sparse-matrix)
+;;; RETURN VALUE
+;;; sparse-vector of rows indexed by row-numbers or
+;;; nil if sparse-matrix is stored only by columns
+;;; SOURCE
+
+ ;;sparse-matrix-rows is defined as a slot in the sparse-matrix structure
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-matrix-columns
+;;; USAGE
+;;; (sparse-matrix-columns sparse-matrix)
+;;; RETURN VALUE
+;;; sparse-vector of columns indexed by column-numbers or
+;;; nil if sparse-matrix is stored only by rows
+;;; SOURCE
+
+ ;;sparse-matrix-columns is defined as a slot in the sparse-matrix structure
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-matrix-count
+;;; USAGE
+;;; (sparse-matrix-count sparse-matrix)
+;;; RETURN VALUE
+;;; integer number of entries in sparse-matrix
+;;; SOURCE
+
+(defun sparse-matrix-count (sparse-matrix)
+ (let ((n 0))
+ (prog->
+ (map-sparse-vector
+ (or (sparse-matrix-rows sparse-matrix) (sparse-matrix-columns sparse-matrix)) ->* v)
+ (incf n (sparse-vector-count v)))
+ n))
+;;; ***
+
+;;; ****if* snark-sparse-array/sparef2
+;;; USAGE
+;;; (sparef2 sparse-matrix row-index col-index)
+;;; NOTES
+;;; (sparef sparse-matrix row-index col-index) macroexpands to this
+;;; SOURCE
+
+(defun sparef2 (sparse-matrix row-index col-index)
+ (let ((rows (sparse-matrix-rows sparse-matrix)))
+ (if rows
+ (let ((row (sparef rows row-index)))
+ (if row (sparef row col-index) (sparse-matrix-default-value sparse-matrix)))
+ (let ((col (sparef (sparse-matrix-columns sparse-matrix) col-index)))
+ (if col (sparef col row-index) (sparse-matrix-default-value sparse-matrix))))))
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-matrix-row
+;;; USAGE
+;;; (sparse-matrix-row sparse-matrix index)
+;;; (setf (sparse-matrix-row sparse-matrix index) sparse-vector)
+;;; (setf (sparse-matrix-row sparse-matrix index) nil)
+;;; (setf (sparse-matrix-row sparse-matrix index) t)
+;;; RETURN VALUE
+;;; sparse-vector or nil
+;;; DESCRIPTION
+;;; (sparse-matrix-row sparse-matrix index) returns
+;;; the index-th row of sparse-matrix if it exists, nil otherwise.
+;;;
+;;; (setf (sparse-matrix-row sparse-matrix index) sparse-vector) replaces
+;;; the index-th row of sparse-matrix by sparse-vector.
+;;;
+;;; (setf (sparse-matrix-row sparse-matrix index) nil) deletes
+;;; the index-th row of sparse-matrix.
+;;;
+;;; (setf (sparse-matrix-row sparse-matrix index) t) returns
+;;; the index-th row of sparse-matrix if it exists
+;;; or adds and returns a new one otherwise.
+;;; It is equivalent to
+;;; (or (sparse-matrix-row sparse-matrix index)
+;;; (setf (sparse-matrix-row sparse-matrix index)
+;;; (make-sparse-vector :boolean (sparse-matrix-boolean sparse-matrix)
+;;; :default-value (sparse-matrix-default-value sparse-matrix))))
+;;; SOURCE
+
+(defun sparse-matrix-row (sparse-matrix index)
+ (let ((rows (sparse-matrix-rows sparse-matrix)))
+ (and rows (sparef rows index))))
+
+(defun (setf sparse-matrix-row) (value sparse-matrix index)
+ (let ((rows (sparse-matrix-rows sparse-matrix)))
+ (if rows
+ (setf (sparef rows index) value)
+ (error "No row vectors for sparse-matrix ~A." sparse-matrix))))
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-matrix-column
+;;; USAGE
+;;; (setf (sparse-matrix-column sparse-matrix index) sparse-vector)
+;;; (setf (sparse-matrix-column sparse-matrix index) nil)
+;;; (setf (sparse-matrix-column sparse-matrix index) t)
+;;; RETURN VALUE
+;;; sparse-vector or nil
+;;; DESCRIPTION
+;;; Defined analogously to sparse-matrix-row.
+;;; SOURCE
+
+(defun sparse-matrix-column (sparse-matrix index)
+ (let ((cols (sparse-matrix-columns sparse-matrix)))
+ (and cols (sparef cols index))))
+
+(defun (setf sparse-matrix-column) (value sparse-matrix index)
+ (let ((cols (sparse-matrix-columns sparse-matrix)))
+ (if cols
+ (setf (sparef cols index) value)
+ (error "No column vectors for sparse-matrix ~A." sparse-matrix))))
+;;; ***
+
+;;; ****if* snark-sparse-array/add-sparse-matrix-row-or-column
+;;; USAGE
+;;; (add-sparse-matrix-row-or-column rows-or-cols index new-row-or-col)
+;;; SOURCE
+
+(defun add-sparse-matrix-row-or-column (rows-or-cols index new-row-or-col)
+ (let ((type (sparse-vector-type rows-or-cols))
+ sparse-matrix cols-or-rows)
+ (ecase (first type)
+ (rows
+ (setf sparse-matrix (second type))
+ (setf cols-or-rows (sparse-matrix-columns sparse-matrix))
+ (setf type `(row ,sparse-matrix ,index)))
+ (columns
+ (setf sparse-matrix (second type))
+ (setf cols-or-rows (sparse-matrix-rows sparse-matrix))
+ (setf type `(column ,sparse-matrix ,index))))
+ (unless (eql 0 (sparse-vector-count new-row-or-col))
+ (when cols-or-rows
+ (prog->
+ (map-sparse-vector-with-indexes new-row-or-col ->* value index2)
+ (sparse-vector-setter
+ value (or (sparef cols-or-rows index2) (setf (sparef cols-or-rows index2) t)) index))))
+ (setf (sparse-vector-type new-row-or-col) type)
+ (sparse-vector-setter new-row-or-col rows-or-cols index)))
+;;; ***
+
+;;; ****if* snark-sparse-array/delete-sparse-matrix-row-or-column
+;;; USAGE
+;;; (delete-sparse-matrix-row-or-column rows-or-cols index &optional keep)
+;;; SOURCE
+
+(defun delete-sparse-matrix-row-or-column (rows-or-cols index &optional keep)
+ ;; removes indexth sparse-vector from rows-or-cols
+ ;; and deletes its entries from cols-or-rows
+ ;; but leaves contents of removed sparse-vector intact
+ (let ((sparse-vector (sparef rows-or-cols index)))
+ (when sparse-vector
+ (unless (eql 0 (sparse-vector-count sparse-vector))
+ (let ((cols-or-rows (let ((type (sparse-vector-type rows-or-cols)))
+ (ecase (first type)
+ (rows (sparse-matrix-columns (second type)))
+ (columns (sparse-matrix-rows (second type))))))
+ (default-value (sparse-vector-default-value sparse-vector)))
+ (prog->
+ (map-sparse-vector-indexes-only sparse-vector ->* index2)
+ (sparse-vector-setter default-value (sparef cols-or-rows index2) index))))
+ (setf (sparse-vector-type sparse-vector) nil)
+ (unless keep
+ (sparse-vector-setter nil rows-or-cols index)))))
+;;; ***
+
+;;; ****if* snark-sparse-array/(setf_sparef1)
+;;; USAGE
+;;; (setf (sparef1 sparse-vector index) value)
+;;; SOURCE
+
+(defun (setf sparef1) (value sparse-vector index)
+ (let ((type (sparse-vector-type sparse-vector)))
+ (if (null type)
+ (sparse-vector-setter value sparse-vector index)
+ (ecase (first type)
+ (row
+ (let ((matrix (second type))
+ (row-index (third type)))
+ (if (eql value (sparse-vector-default-value sparse-vector))
+ (let ((col (sparse-matrix-column matrix index)))
+ (when col
+ (sparse-vector-setter value col row-index)))
+ (when (sparse-matrix-columns matrix)
+ (sparse-vector-setter value (setf (sparse-matrix-column matrix index) t) row-index))))
+ (sparse-vector-setter value sparse-vector index))
+ (column
+ (let ((matrix (second type))
+ (col-index (third type)))
+ (if (eql value (sparse-vector-default-value sparse-vector))
+ (let ((row (sparse-matrix-row matrix index)))
+ (when row
+ (sparse-vector-setter value row col-index)))
+ (when (sparse-matrix-rows matrix)
+ (sparse-vector-setter value (setf (sparse-matrix-row matrix index) t) col-index))))
+ (sparse-vector-setter value sparse-vector index))
+ ((rows columns)
+ (cond
+ ((null value)
+ (delete-sparse-matrix-row-or-column sparse-vector index nil))
+ ((eq t value)
+ (or (sparef sparse-vector index)
+ (progn
+ (let ((matrix (second type)))
+ (setf value (make-sparse-vector
+ :default-value (sparse-matrix-default-value matrix)
+ :boolean (sparse-matrix-boolean matrix))))
+ (delete-sparse-matrix-row-or-column sparse-vector index t)
+ (add-sparse-matrix-row-or-column sparse-vector index value))))
+ (t
+ (let ((matrix (second type)))
+ (cl:assert (and (sparse-vector-p value)
+ (null (sparse-vector-type value))
+ (if (sparse-vector-boolean value)
+ (sparse-vector-boolean matrix)
+ (and (not (sparse-vector-boolean matrix))
+ (eql (sparse-vector-default-value value)
+ (sparse-vector-default-value matrix)))))))
+ (delete-sparse-matrix-row-or-column sparse-vector index t)
+ (add-sparse-matrix-row-or-column sparse-vector index value))))))))
+;;; ***
+
+;;; ****if* snark-sparse-array/(setf_sparef2)
+;;; USAGE
+;;; (setf (sparef2 sparse-matrix row-index col-index) value)
+;;; SOURCE
+
+(defun (setf sparef2) (value sparse-matrix row-index col-index)
+ (let ((rows (sparse-matrix-rows sparse-matrix))
+ (cols (sparse-matrix-columns sparse-matrix)))
+ (cond
+ ((eql value (sparse-matrix-default-value sparse-matrix))
+ (let ((col (and cols (sparef cols col-index))))
+ (when col
+ (sparse-vector-setter value col row-index)))
+ (let ((row (and rows (sparef rows row-index))))
+ (if row
+ (sparse-vector-setter value row col-index)
+ value)))
+ (t
+ (when cols
+ (sparse-vector-setter value (setf (sparse-matrix-column sparse-matrix col-index) t) row-index))
+ (if rows
+ (sparse-vector-setter value (setf (sparse-matrix-row sparse-matrix row-index) t) col-index)
+ value)))))
+;;; ***
+
+;;; ****f* snark-sparse-array/map-sparse-matrix
+;;; USAGE
+;;; (map-sparse-matrix function sparse-matrix)
+;;; RETURN VALUE
+;;; nil
+;;; DESCRIPTION
+;;; The map-sparse-matrix function applies its unary-function argument
+;;; to each value in sparse-matrix.
+;;; SEE ALSO
+;;; map-sparse-matrix-with-indexes
+;;; map-sparse-matrix-indexes-only
+;;; SOURCE
+
+(defun map-sparse-matrix (function sparse-matrix)
+ (let ((rows (sparse-matrix-rows sparse-matrix)))
+ (if rows
+ (prog->
+ (map-sparse-vector rows ->* row)
+ (map-sparse-vector row ->* value)
+ (funcall function value))
+ (prog->
+ (map-sparse-vector (sparse-matrix-columns sparse-matrix) ->* col)
+ (map-sparse-vector col ->* value)
+ (funcall function value)))))
+;;; ***
+
+;;; ****f* snark-sparse-array/map-sparse-matrix-with-indexes
+;;; USAGE
+;;; (map-sparse-matrix-with-indexes function sparse-matrix)
+;;; RETURN VALUE
+;;; nil
+;;; DESCRIPTION
+;;; The map-sparse-matrix-with-indexes function applies its ternary-function argument
+;;; to each value, row-index, and column-index in sparse-matrix.
+;;; SEE ALSO
+;;; map-sparse-matrix
+;;; map-sparse-matrix-indexes-only
+;;; SOURCE
+
+(defun map-sparse-matrix-with-indexes (function sparse-matrix)
+ (let ((rows (sparse-matrix-rows sparse-matrix)))
+ (if rows
+ (prog->
+ (map-sparse-vector-with-indexes rows ->* row row-index)
+ (map-sparse-vector-with-indexes row ->* value col-index)
+ (funcall function value row-index col-index))
+ (prog->
+ (map-sparse-vector-with-indexes (sparse-matrix-columns sparse-matrix) ->* col col-index)
+ (map-sparse-vector-with-indexes col ->* value row-index)
+ (funcall function value row-index col-index)))))
+;;; ***
+
+;;; ****f* snark-sparse-array/map-sparse-matrix-indexes-only
+;;; USAGE
+;;; (map-sparse-matrix-indexes-only function sparse-matrix)
+;;; RETURN VALUE
+;;; nil
+;;; DESCRIPTION
+;;; The map-sparse-matrix-indexes-only function applies its binary-function argument
+;;; to each row-index and column-index in sparse-matrix.
+;;; SEE ALSO
+;;; map-sparse-matrix
+;;; map-sparse-matrix-with-indexes
+;;; SOURCE
+
+(defun map-sparse-matrix-indexes-only (function sparse-matrix)
+ (let ((rows (sparse-matrix-rows sparse-matrix)))
+ (if rows
+ (prog->
+ (map-sparse-vector-with-indexes rows ->* row row-index)
+ (map-sparse-vector-indexes-only row ->* col-index)
+ (funcall function row-index col-index))
+ (prog->
+ (map-sparse-vector-with-indexes (sparse-matrix-columns sparse-matrix) ->* col col-index)
+ (map-sparse-vector-indexes-only col ->* row-index)
+ (funcall function row-index col-index)))))
+;;; ***
+
+;;; ****if* snark-sparse-array/print-sparse-vector3
+;;; USAGE
+;;; (print-sparse-vector3 sparse-vector stream depth)
+;;; NOTES
+;;; specified as print-function in the sparse-vector defstruct
+;;; SOURCE
+
+(defun print-sparse-vector3 (sparse-vector stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (sparse-vector stream :type t :identity t)
+ (princ "count " stream)
+ (princ (sparse-vector-count sparse-vector) stream)))
+;;; ***
+
+;;; ****if* snark-sparse-array/print-sparse-matrix3
+;;; USAGE
+;;; (print-sparse-matrix3 sparse-matrix stream depth)
+;;; NOTES
+;;; specified as print-function in the sparse-matrix defstruct
+;;; SOURCE
+
+(defun print-sparse-matrix3 (sparse-matrix stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (sparse-matrix stream :type t :identity t)
+ (let ((rows (sparse-matrix-rows sparse-matrix)))
+ (princ (if rows (sparse-vector-count rows) "?") stream))
+ (princ " rows" stream)
+ (princ " * " stream)
+ (let ((cols (sparse-matrix-columns sparse-matrix)))
+ (princ (if cols (sparse-vector-count cols) "?") stream))
+ (princ " cols" stream)))
+;;; ***
+
+;;; sparse-array.lisp EOF
diff --git a/snark-20120808r02/src/sparse-vector-expression.abcl b/snark-20120808r02/src/sparse-vector-expression.abcl
new file mode 100644
index 0000000..a3627e9
Binary files /dev/null and b/snark-20120808r02/src/sparse-vector-expression.abcl differ
diff --git a/snark-20120808r02/src/sparse-vector-expression.lisp b/snark-20120808r02/src/sparse-vector-expression.lisp
new file mode 100644
index 0000000..f211788
--- /dev/null
+++ b/snark-20120808r02/src/sparse-vector-expression.lisp
@@ -0,0 +1,343 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-sparse-array -*-
+;;; File: sparse-vector-expression.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2005.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-sparse-array)
+
+;;; compute intersection and union of sparse-vectors
+;;; ::=
+;;; |
+;;; (intersection +) |
+;;; (union +) |
+;;; (uniond +)
+;;; assumes that default-value for sparse-vectors is nil
+;;; elements of unions are not mapped in order
+
+(defun sparse-vector-expression-p (x)
+ (cond
+ ((atom x)
+ (and (sparse-vector-p x) (null (sparse-vector-default-value x))))
+ (t
+ (let ((fn (first x))
+ (args (rest x)))
+ (and (or (eq 'intersection fn) (eq 'union fn) (eq 'uniond fn))
+ args
+ (dolist (arg args t)
+ (unless (sparse-vector-expression-p arg)
+ (return nil))))))))
+
+(definline mem-sparse-vector-expression (index expr)
+ (if (atom expr) (sparef expr index) (mem-sparse-vector-expression1 index expr)))
+
+(defun mem-sparse-vector-expression1 (index expr)
+ (declare (type cons expr))
+ (cond
+ ((eq 'intersection (first expr))
+ (dolist (e (rest expr) t)
+ (unless (mem-sparse-vector-expression index e)
+ (return nil))))
+ (t ;union, uniond
+ (dolist (e (rest expr) nil)
+ (when (mem-sparse-vector-expression index e)
+ (return t))))))
+
+;;; (intersection sve1 sve2 ... sven) is mapped by generating elements of
+;;; sve1 and testing them for membership in sve2 ... sven
+;;;
+;;; (union sve1 sve2 ... sven) is mapped by generating elements of each svei
+;;; and testing them for membership in sve1 ... svei-1 to omit duplicates
+;;;
+;;; (uniond sve1 sve2 ... sven) is mapped by generating elements of each svei;
+;;; either the union of sets is assumed to be disjoint or we don't care about duplicates,
+;;; so there is no duplicate elimination during mapping for uniond
+
+(defmacro map-sparse-vector-expression-macro (mapexp2 mapexp funcallexp)
+ `(cond
+ ((atom expr)
+ ,mapexp2)
+ (t
+ (ecase (pop expr)
+ (intersection
+ (prog->
+ (first expr -> e1)
+ (rest expr -> l2)
+ (if l2 (cons 'intersection l2) nil -> exprest)
+ (if exprest (sparse-vector-expression-index-bounds exprest) nil -> min max)
+ (when (implies exprest (and (<= min max)
+ (prog->
+ (sparse-vector-expression-index-bounds e1 -> min1 max1)
+ (and (<= min1 max1) (<= min max1) (>= max min1)))))
+ (if exprest (sparse-vector-expression-generates-in-order-p e1) nil -> inorder)
+ ,mapexp
+ ;; avoid membership tests if index k is out of range
+ ;; return quickly if generating indexes in order and beyond range
+ (when (implies exprest (if reverse
+ (and (>= max k) (or (<= min k) (if inorder (return-from prog->) nil)))
+ (and (<= min k) (or (>= max k) (if inorder (return-from prog->) nil)))))
+ (dolist l2 ,funcallexp ->* e2)
+ (unless (mem-sparse-vector-expression k e2)
+ (return))))))
+ (uniond
+ (prog->
+ (dolist expr ->* e1)
+ ,mapexp
+ (declare (ignorable k))
+ ,funcallexp))
+ (union
+ (prog->
+ (dolist expr ->* e1)
+ ,mapexp
+ (dolist expr ->* e2)
+ (cond
+ ((eq e1 e2)
+ ,funcallexp
+ (return))
+ ((mem-sparse-vector-expression k e2)
+ (return)))))))))
+
+;;; if it is provided, the predicate 'filter' is applied to elements immediately
+;;; when mapped (e.g., before checking membership in rest of intersection)
+;;; in order to ignore unwanted elements quickly
+
+(defun map-sparse-vector-expression-with-indexes0 (function expr reverse filter)
+ (map-sparse-vector-expression-macro
+ (if (null filter)
+ (map-sparse-vector-with-indexes function expr :reverse reverse)
+ (prog->
+ (map-sparse-vector-with-indexes expr :reverse reverse ->* v k)
+ (when (funcall filter v k)
+ (funcall function v k))))
+ (map-sparse-vector-expression-with-indexes0 e1 reverse filter ->* v k)
+ (funcall function v k)))
+
+(defun map-sparse-vector-expression-indexes-only0 (function expr reverse filter)
+ (map-sparse-vector-expression-macro
+ (if (null filter)
+ (map-sparse-vector-indexes-only function expr :reverse reverse)
+ (prog->
+ (map-sparse-vector-indexes-only expr :reverse reverse ->* k)
+ (when (funcall filter k)
+ (funcall function k))))
+ (map-sparse-vector-expression-indexes-only0 e1 reverse filter ->* k)
+ (funcall function k)))
+
+(defun map-sparse-vector-expression0 (function expr reverse filter)
+ (map-sparse-vector-expression-macro
+ (if (null filter)
+ (map-sparse-vector function expr :reverse reverse)
+ (prog->
+ (map-sparse-vector expr :reverse reverse ->* v)
+ (when (funcall filter v)
+ (funcall function v))))
+ (map-sparse-vector-expression-values2 e1 reverse filter ->* v k)
+ (funcall function v)))
+
+(defun map-sparse-vector-expression-values2 (function expr reverse filter)
+ (map-sparse-vector-expression-macro
+ (if (null filter)
+ (map-sparse-vector-with-indexes function expr :reverse reverse)
+ (prog->
+ (map-sparse-vector-with-indexes expr :reverse reverse ->* v k)
+ (when (funcall filter v)
+ (funcall function v k))))
+ (map-sparse-vector-expression-values2 e1 reverse filter ->* v k)
+ (funcall function v k)))
+
+(definline map-sparse-vector-expression (function expr &key reverse filter)
+ (map-sparse-vector-expression0 function expr reverse filter))
+
+(definline map-sparse-vector-expression-with-indexes (function expr &key reverse filter)
+ (map-sparse-vector-expression-with-indexes0 function expr reverse filter))
+
+(definline map-sparse-vector-expression-indexes-only (function expr &key reverse filter)
+ (map-sparse-vector-expression-indexes-only0 function expr reverse filter))
+
+(defun sparse-vector-expression-size (expr)
+ ;; number of sparse-vectors in expression
+ (cond
+ ((atom expr)
+ 1)
+ (t
+ (setf expr (rest expr))
+ (let ((size (sparse-vector-expression-size (first expr))))
+ (dolist (e (rest expr) size)
+ (incf size (sparse-vector-expression-size e)))))))
+
+(defun sparse-vector-expression-maxcount (expr)
+ ;; upper bound on count for expression
+ (cond
+ ((atom expr)
+ (sparse-vector-count expr))
+ ((eq 'intersection (pop expr))
+ (let ((count (sparse-vector-expression-maxcount (first expr))))
+ (dolist (e (rest expr) count)
+ (let ((n (sparse-vector-expression-maxcount e)))
+ (when (< n count)
+ (setf count n))))))
+ (t ;union, uniond
+ (let ((count (sparse-vector-expression-maxcount (first expr))))
+ (dolist (e (rest expr) count)
+ (incf count (sparse-vector-expression-maxcount e)))))))
+
+(defun optimized-sparse-vector-expression-maxcount (expr)
+ ;; upper bound on count for expression
+ ;; assumes that intersections are ordered in ascending value
+ (cond
+ ((atom expr)
+ (sparse-vector-count expr))
+ ((eq 'intersection (pop expr))
+ (optimized-sparse-vector-expression-maxcount (first expr)))
+ (t ;union, uniond
+ (let ((count (optimized-sparse-vector-expression-maxcount (first expr))))
+ (dolist (e (rest expr) count)
+ (incf count (optimized-sparse-vector-expression-maxcount e)))))))
+
+(defun sparse-vector-expression-index-bounds (expr)
+ ;; returns smallest and largest indexes that might be expr
+ (cond
+ ((atom expr)
+ (values (nth-value 1 (first-sparef expr)) (nth-value 1 (last-sparef expr))))
+ ((eq 'intersection (pop expr))
+ (prog->
+ (sparse-vector-expression-index-bounds (first expr) -> min max)
+ (dolist (rest expr) (values min max) ->* e)
+ (sparse-vector-expression-index-bounds e -> m n)
+ ;; narrow bounds of intersections
+ (when (< min m)
+ (setf min m))
+ (when (> max n)
+ (setf max n))))
+ (t ;union, uniond
+ (prog->
+ (sparse-vector-expression-index-bounds (first expr) -> min max)
+ (dolist (rest expr) (values min max) ->* e)
+ (sparse-vector-expression-index-bounds e -> m n)
+ ;; widen bounds of unions
+ (when (> min m)
+ (setf min m))
+ (when (< max n)
+ (setf max n))))))
+
+(defun sparse-vector-expression-generates-in-order-p (expr)
+ (or (atom expr)
+ (and (eq 'intersection (first expr))
+ (sparse-vector-expression-generates-in-order-p (second expr)))))
+
+(defun equal-sparse-vector-expression-p (x y)
+ (or (eq x y)
+ (and (consp x)
+ (consp y)
+ (eq (pop x) (pop y))
+ (subsetp x y :test #'equal-sparse-vector-expression-p)
+ (subsetp y x :test #'equal-sparse-vector-expression-p))))
+
+(defun equal-optimized-sparse-vector-expression-p (x y)
+ (or (eq x y)
+ (and (consp x)
+ (consp y)
+ (eq (pop x) (pop y))
+ (length= x y)
+ (subsetp x y :test #'equal-optimized-sparse-vector-expression-p))))
+
+(definline optimize-sparse-vector-expression (expr)
+ (cond
+ ((atom expr)
+ expr)
+ ((eq 'intersection (first expr))
+ (optimize-sparse-vector-expression1 expr #'<)) ;intersection ordered by increasing maxcount
+ (t
+ (optimize-sparse-vector-expression1 expr #'>)))) ;union, uniond ordered by decreasing maxcount
+
+(definline optimize-and-sort-short-lists-of-sparse-vector-expressions (l1 predicate)
+ ;; returns t and destructively stably sorts l1 if length is <= 3, returns nil otherwise
+ (if (null l1)
+ t
+ (let ((l2 (rest l1)))
+ (if (null l2)
+ t
+ (let ((l3 (rest l2)))
+ (if (null l3)
+ (let* ((v1 (optimize-sparse-vector-expression (first l1)))
+ (v2 (optimize-sparse-vector-expression (first l2)))
+ (n1 (optimized-sparse-vector-expression-maxcount v1))
+ (n2 (optimized-sparse-vector-expression-maxcount v2)))
+ (cond
+ ((funcall predicate n2 n1)
+ (setf (first l1) v2 (first l2) v1)))
+ t)
+ (if (null (rest l3))
+ (let* ((v1 (optimize-sparse-vector-expression (first l1)))
+ (v2 (optimize-sparse-vector-expression (first l2)))
+ (v3 (optimize-sparse-vector-expression (first l3)))
+ (n1 (optimized-sparse-vector-expression-maxcount v1))
+ (n2 (optimized-sparse-vector-expression-maxcount v2))
+ (n3 (optimized-sparse-vector-expression-maxcount v3)))
+ (cond
+ ((funcall predicate n2 n1)
+ (cond
+ ((funcall predicate n3 n2)
+ (setf (first l1) v3 (first l2) v2 (first l3) v1))
+ ((funcall predicate n3 n1)
+ (setf (first l1) v2 (first l2) v3 (first l3) v1))
+ (t
+ (setf (first l1) v2 (first l2) v1))))
+ ((funcall predicate n3 n2)
+ (cond
+ ((funcall predicate n3 n1)
+ (setf (first l1) v3 (first l2) v1 (first l3) v2))
+ (t
+ (setf (first l2) v3 (first l3) v2)))))
+ t)
+ nil)))))))
+
+(defun optimize-sparse-vector-expression1 (expr predicate)
+ ;; destructive
+ (let ((fn (first expr))
+ (args (rest expr)))
+;; (cl:assert args)
+ (cond
+ ((null (rest args))
+ (optimize-sparse-vector-expression (first args)))
+ (t
+ ;; optimize and sort arguments
+ (or (optimize-and-sort-short-lists-of-sparse-vector-expressions args predicate)
+ (progn
+ (dotails (l args)
+ (let ((x (optimize-sparse-vector-expression (car l))))
+ (setf (car l) (cons (optimized-sparse-vector-expression-maxcount x) x))))
+ (setf args (stable-sort args predicate :key #'car))
+ (dotails (l args)
+ (setf (car l) (cdar l)))))
+ ;; eliminate duplicate arguments
+ (setf args (delete-duplicates args :test #'equal-optimized-sparse-vector-expression-p :from-end t))
+ ;; apply absorption laws
+ ;; (union a (intersection a b) c) -> (union a c)
+ ;; (intersection a (union a b) c) -> (intersection a c)
+ (setf args (delete-if (lambda (arg)
+ (and (consp arg)
+ (not (iff (eq 'intersection fn) (eq 'intersection (first arg))))
+ (dolist (x args)
+ (cond
+ ((eq arg x)
+ (return nil))
+ ((member x (rest arg) :test #'equal-optimized-sparse-vector-expression-p)
+ (return t))))))
+ args))
+ (if (null (rest args)) (first args) (rplacd expr args))))))
+
+;;; sparse-vector-expression.lisp EOF
diff --git a/snark-20120808r02/src/sparse-vector5.abcl b/snark-20120808r02/src/sparse-vector5.abcl
new file mode 100644
index 0000000..4f391d7
Binary files /dev/null and b/snark-20120808r02/src/sparse-vector5.abcl differ
diff --git a/snark-20120808r02/src/sparse-vector5.lisp b/snark-20120808r02/src/sparse-vector5.lisp
new file mode 100644
index 0000000..6f6ca6b
--- /dev/null
+++ b/snark-20120808r02/src/sparse-vector5.lisp
@@ -0,0 +1,982 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-sparse-array -*-
+;;; File: sparse-vector5.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-sparse-array)
+
+;;; ****if* snark-sparse-array/sparse-vector-types
+;;; SOURCE
+
+(deftype sparse-vector-index () 'integer) ;indexes are integers
+(deftype sparse-vector-count () 'fixnum) ;number of entries is a fixnum
+;;; ***
+
+;;; more implementation independent sparse-vector functions are defined in sparse-array.lisp
+
+;;; ****s* snark-sparse-array/sparse-vector
+;;; NAME
+;;; sparse-vector structure
+;;; sparse-vector type
+;;; SOURCE
+
+(defstruct (sparse-vector
+ (:constructor make-sparse-vector0 (default-value0))
+ (:print-function print-sparse-vector3)
+ (:copier nil))
+ (default-value0 nil :read-only t) ;default value, or 'bool (unexported symbol denotes boolean sparse-vector)
+ (type nil)
+ (count0 0 :type sparse-vector-count)
+ (cached-key 0 :type sparse-vector-index)
+ cached-value ;initialize in make-sparse-vector
+ (b-tree-root-node nil))
+;;; ***
+
+;;; ****f* snark-sparse-array/make-sparse-vector
+;;; USAGE
+;;; (make-sparse-vector &key boolean default-value)
+;;; RETURN VALUE
+;;; sparse-vector
+;;; SOURCE
+
+(defun make-sparse-vector (&key boolean default-value)
+ (when boolean
+ (unless (null default-value)
+ (error "Default-value must be NIL for Boolean sparse-arrays.")))
+ (let ((sparse-vector (make-sparse-vector0 (if boolean 'bool default-value))))
+ (setf (sparse-vector-cached-value sparse-vector) default-value)
+ sparse-vector))
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-vector-p
+;;; USAGE
+;;; (sparse-vector-p x)
+;;; RETURN VALUE
+;;; true if x if a sparse-vector, false otherwise
+;;; SOURCE
+
+ ;;sparse-vector-p is defined by the sparse-vector defstruct
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-vector-boolean
+;;; USAGE
+;;; (sparse-vector-boolean sparse-vector)
+;;; RETURN VALUE
+;;; true if x is a boolean sparse-vector, false otherwise
+;;; SOURCE
+
+(definline sparse-vector-boolean (sparse-vector)
+ (eq 'bool (sparse-vector-default-value0 sparse-vector)))
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-vector-default-value
+;;; USAGE
+;;; (sparse-vector-boolean sparse-vector)
+;;; RETURN VALUE
+;;; the default-value for unstored entries of sparse-vector
+;;; SOURCE
+
+(definline sparse-vector-default-value (sparse-vector)
+ (let ((v (sparse-vector-default-value0 sparse-vector)))
+ (if (eq 'bool v) nil v)))
+;;; ***
+
+;;; ****f* snark-sparse-array/sparse-vector-count
+;;; USAGE
+;;; (sparse-vector-count sparse-vector)
+;;; RETURN VALUE
+;;; integer number of entries in sparse-vector
+;;; NOTES
+;;; returns 0 if sparse-vector is nil
+;;; SOURCE
+
+(definline sparse-vector-count (sparse-vector)
+ (if (null sparse-vector) 0 (sparse-vector-count0 sparse-vector)))
+;;; ***
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant b-tree-node-size 16) ;must be even
+ (defconstant b-tree-node-size-1 (- b-tree-node-size 1))
+ (defconstant b-tree-node-size/2 (floor b-tree-node-size 2))
+ (defconstant b-tree-node-size/2+1 (+ b-tree-node-size/2 1))
+ (defconstant b-tree-node-size/2-1 (- b-tree-node-size/2 1)))
+
+#+ignore
+(defstruct (b-tree-node
+ (:constructor make-b-tree-node (alist nonleaf-last-value))
+ )
+ ;; b-tree nodes must be nonempty
+ ;; leaf nodes have at least one key and the same number of values
+ ;; nonleaf nodes have at one key and one more value
+ (alist nil :read-only t) ;alist of keys and values (or just list of keys for leaf nodes of boolean sparse vectors)
+ (nonleaf-last-value nil :read-only t)) ;nonleaf nodes have one more value than keys, nil for leaf nodes
+
+(defmacro make-b-tree-node (alist nonleaf-last-value)
+ `(cons ,alist ,nonleaf-last-value))
+
+(defmacro b-tree-node-alist (n)
+ `(carc ,n))
+
+(defmacro b-tree-node-nonleaf-last-value (n)
+ `(cdrc ,n))
+
+(definline b-tree-nonleaf-node-alist-search (alist index)
+ ;; each node has one or more keys in descending order
+ (declare (type sparse-vector-index index))
+ (loop
+ (when (or (>= index (the sparse-vector-index (carc (carc alist)))) (null (setf alist (cdrc alist))))
+ (return alist))))
+
+(definline lastc (list)
+ (let (rest)
+ (loop
+ (if (null (setf rest (cdrc list)))
+ (return (carc list))
+ (setf list rest)))))
+
+(definline smallest-key (x)
+ (let ((p (lastc x)))
+ (if (atom p) p (carc p))))
+
+(definline largest-key (x)
+ (let ((p (carc x)))
+ (if (atom p) p (carc p))))
+
+(definline b-tree-node-smallest-key* (n)
+ (loop
+ (let ((last-value (b-tree-node-nonleaf-last-value n)))
+ (cond
+ ((null last-value)
+ ;; leaf node
+ (let ((v (lastc (b-tree-node-alist n))))
+ (if (atom v) ;boolean sparse vector?
+ (return (values v v))
+ (return (values (carc v) (cdrc v))))))
+ (t
+ (setf n last-value))))))
+
+(definline b-tree-node-largest-key* (n)
+ (loop
+ (let ((last-value (b-tree-node-nonleaf-last-value n)))
+ (cond
+ ((null last-value)
+ ;; leaf node
+ (let ((v (carc (b-tree-node-alist n))))
+ (if (atom v) ;boolean sparse vector?
+ (return (values v v))
+ (return (values (carc v) (cdrc v))))))
+ (t
+ (setf n (cdrc (carc (b-tree-node-alist n)))))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun nestn (x y n)
+ (dotimes (i n)
+ (setf y (subst y '*** x)))
+ y))
+
+(defmacro unroll-sparef1-leaf ()
+ `(let ((p (carc alist)))
+ (if (atom p)
+ ;; boolean sparse-vector leaf node, alist is nonempty list of indexes in descending order
+ ,(let ((l nil))
+ (dotimes (i b-tree-node-size)
+ (cond
+ ((= 0 i)
+ (push `((or (null (setf alist (cdrc alist))) (>= index k)) (= index k)) l))
+ ((> b-tree-node-size-1 i)
+ (push `((progn (setf k (carc alist)) (or (null (setf alist (cdrc alist))) (>= index k))) (= index k)) l))
+ (t
+ (push `(t (= index (the sparse-vector-index (carc alist)))) l))))
+ `(let ((k p))
+ (declare (type sparse-vector-index k))
+ (if (cond ,@(reverse l)) index nil)))
+ ;; nonboolean sparse-vector leaf node, alist is nonempty alist of keys (in descending order) and values
+ ,(let ((l nil))
+ (dotimes (i b-tree-node-size)
+ (cond
+ ((= 0 i)
+ (push `((or (null (setf alist (cdrc alist))) (>= index k)) (= index k)) l))
+ ((> b-tree-node-size-1 i)
+ (push `((progn (setf k (carc (setf p (carc alist)))) (or (null (setf alist (cdrc alist))) (>= index k))) (= index k)) l))
+ (t
+ (push `(t (= index (the sparse-vector-index (carc (setf p (carc alist)))))) l))))
+ `(let ((k (carc p)))
+ (declare (type sparse-vector-index k))
+ (if (cond ,@(reverse l)) (cdrc p) (sparse-vector-default-value sparse-vector)))))))
+
+(defmacro unroll-sparef1-nonleaf ()
+ ;; nonleaf node, alist is nonempty alist of keys (in descending order) and values
+ (let ((l nil))
+ (dotimes (i b-tree-node-size)
+ (cond
+ ((= 0 i)
+ (push `((>= index (the sparse-vector-index (carc p))) (cdrc p)) l))
+ (t
+ (push `((null (setf alist (cdrc alist))) nil) l)
+ (push `((>= index (the sparse-vector-index (carc (setf p (carc alist))))) (cdrc p)) l))))
+ `(let* ((p (carc alist)))
+ (cond ,@(reverse l)))))
+
+(defmacro unroll-full-alist ()
+ (let ((l nil))
+ (dotimes (i b-tree-node-size-1)
+ (push `(setf l (cdrc l)) l))
+ `(and ,@l)))
+
+(definline full-alist (l)
+ (unroll-full-alist))
+
+;;; ****if* snark-sparse-array/sparef1
+;;; USAGE
+;;; (sparef1 sparse-vector index)
+;;; NOTES
+;;; (sparef sparse-vector index) macroexpands to this
+;;; SOURCE
+
+(defun sparef1 (sparse-vector index)
+ (declare (type sparse-vector sparse-vector) (type sparse-vector-index index))
+ (let ((n (sparse-vector-b-tree-root-node sparse-vector)))
+ (cond
+ ((null n)
+ (sparse-vector-default-value sparse-vector))
+ ((= (sparse-vector-cached-key sparse-vector) index)
+ (sparse-vector-cached-value sparse-vector))
+ (t
+ (loop
+ (let ((alist (b-tree-node-alist n))
+ (last-value (b-tree-node-nonleaf-last-value n)))
+ (cond
+ ((null last-value)
+ ;; leaf node
+ (setf (sparse-vector-cached-key sparse-vector) index)
+ (return (setf (sparse-vector-cached-value sparse-vector) (unroll-sparef1-leaf))))
+ (t
+ (setf n (or (unroll-sparef1-nonleaf) last-value))))))))))
+;;; ***
+
+;;; ****f* snark-sparse-array/sparef
+;;; USAGE
+;;; (sparef sparse-vector index)
+;;; (setf (sparef sparse-vector index) value)
+;;;
+;;; (sparef sparse-matrix row-index column-index)
+;;; (setf (sparef sparse-matrix row-index column-index) value)
+;;; SOURCE
+
+(defmacro sparef (sparse-array index1 &optional index2)
+ (if (null index2)
+ `(sparef1 ,sparse-array ,index1)
+ `(sparef2 ,sparse-array ,index1 ,index2)))
+;;; ***
+
+;;; ****if* snark-sparse-array/sparse-vector-setter
+;;; USAGE
+;;; (sparse-vector-setter value sparse-vector index)
+;;; SOURCE
+
+(defun sparse-vector-setter (value sparse-vector index &optional copy)
+ ;; sparse-vector-setter destructively modifies slots of sparse-vector
+ ;; it will make a copy of sparse-vector and modify it instead if copy is true
+ ;; this is used by spacons that returns a new sparse-vector and leaves the original unmodified
+ ;; the b-tree structure nodes themselves are not destructively modified
+ ;; so that map-sparse-vector traversals are unaltered by
+ ;; additions, deletions, and modifications done during the traversal
+ (declare (type sparse-vector sparse-vector) (type sparse-vector-index index))
+ (when (and (= (sparse-vector-cached-key sparse-vector) index)
+ (if (sparse-vector-boolean sparse-vector)
+ (iff (sparse-vector-cached-value sparse-vector) value)
+ (eql (sparse-vector-cached-value sparse-vector) value)))
+ (return-from sparse-vector-setter (if copy sparse-vector value)))
+ (let ((n (sparse-vector-b-tree-root-node sparse-vector)))
+ (cond
+ ((null n)
+ ;; sparse-vector is empty
+ (unless (eql (sparse-vector-default-value sparse-vector) value)
+ ;; add single element
+ (when copy
+ (setf sparse-vector (copy-sparse-vector sparse-vector)))
+ (setf (sparse-vector-count0 sparse-vector) 1)
+ (setf (sparse-vector-b-tree-root-node sparse-vector) (make-b-tree-node (if (sparse-vector-boolean sparse-vector) (list index) (list (cons index value))) nil))))
+ (t
+ (labels
+ ((split-leaf-alist (list num)
+ (declare (type fixnum num))
+ (let (rest)
+ (labels
+ ((spl ()
+ (cond
+ ((= 0 num)
+ (setf rest list)
+ nil)
+ (t
+ (cons (carc list) (progn (setf list (cdrc list)) (setf num (- num 1)) (spl)))))))
+ (values (spl) rest))))
+ (split-nonleaf-alist (list num)
+ (declare (type fixnum num))
+ (let (k v rest)
+ (labels
+ ((spl ()
+ (cond
+ ((= 0 num)
+ (let ((p (carc list)))
+ (setf k (carc p))
+ (setf v (cdrc p))
+ (setf rest (cdrc list)))
+ nil)
+ (t
+ (cons (carc list) (progn (setf list (cdrc list)) (setf num (- num 1)) (spl)))))))
+ (values (spl) k v rest))))
+ (list-update (list index value)
+ (declare (type sparse-vector-index index))
+ (let ((diff 0))
+ (labels
+ ((update (list)
+ (cond
+ ((null list)
+ (cond
+ ((null value)
+ nil)
+ (t
+ (setf diff +1)
+ (cons index nil))))
+ (t
+ (let ((k (carc list)))
+ (declare (type sparse-vector-index k))
+ (cond
+ ((>= index k)
+ (if (= index k)
+ (cond
+ ((null value)
+ (setf diff -1)
+ (cdrc list))
+ (t
+ list))
+ (cond
+ ((null value)
+ list)
+ (t
+ (setf diff +1)
+ (cons index list)))))
+ (t
+ (let* ((l (cdrc list))
+ (l* (update l)))
+ (if (eq l l*) list (cons k l*))))))))))
+ (values (update list) diff))))
+ (alist-update (alist index value default-value)
+ (declare (type sparse-vector-index index))
+ (let ((diff 0))
+ (labels
+ ((update (alist)
+ (cond
+ ((null alist)
+ (cond
+ ((eql default-value value)
+ nil)
+ (t
+ (setf diff +1)
+ (cons (cons index value) nil))))
+ (t
+ (let* ((p (carc alist))
+ (k (carc p)))
+ (declare (type sparse-vector-index k))
+ (cond
+ ((>= index k)
+ (if (= index k)
+ (cond
+ ((eql default-value value)
+ (setf diff -1)
+ (cdrc alist))
+ ((eql value (cdrc p))
+ alist)
+ (t
+ (cons (cons index value) (cdrc alist))))
+ (cond
+ ((eql default-value value)
+ alist)
+ (t
+ (setf diff +1)
+ (cons (cons index value) alist)))))
+ (t
+ (let* ((l (cdrc alist))
+ (l* (update l)))
+ (if (eq l l*) alist (cons p l*))))))))))
+ (values (update alist) diff))))
+ (sparse-vector-setter1 (n)
+ (let ((alist (b-tree-node-alist n))
+ (last-value (b-tree-node-nonleaf-last-value n)))
+ (cond
+ ((null last-value)
+ ;; leaf node of b-tree index
+ (mvlet (((values alist1 diff)
+ (if (atom (carc alist)) ;boolean sparse vector?
+ (list-update alist index value)
+ (alist-update alist index value (sparse-vector-default-value sparse-vector)))))
+ (declare (type fixnum diff))
+ (cond
+ ((eq alist alist1)
+ n)
+ (t
+ (when copy
+ (setf sparse-vector (copy-sparse-vector sparse-vector)))
+ (unless (= 0 diff)
+ (incf (sparse-vector-count0 sparse-vector) diff))
+ (cond
+ ((null alist1)
+ :delete)
+ ((and (= 1 diff) (full-alist alist))
+ (mvlet (((values alist2 alist1) (split-leaf-alist alist1 b-tree-node-size/2)))
+ (values
+ (make-b-tree-node alist1 nil) ;replacement for this node
+ (make-b-tree-node alist2 nil) ;new node to go before it
+ (floor (+ (smallest-key alist2) (+ (largest-key alist1) 1)) 2))))
+ (t
+ (make-b-tree-node alist1 nil)))))))
+ (t
+ ;; descend toward correct leaf node of b-tree index
+ (let ((tail (b-tree-nonleaf-node-alist-search alist index)))
+ (if tail
+ (mvlet* ((p (carc tail))
+ (k (carc p))
+ (v (cdrc p))
+ ((values v1 n2 k2) (sparse-vector-setter1 v)))
+ (cond
+ ((eq v v1)
+ n)
+ ((eq :delete v1)
+ (cond
+ ((null (cdrc alist)) ;if only one value remains
+ last-value) ;move it up in b-tree
+ (t
+ (make-b-tree-node (alist-update alist k nil nil) last-value))))
+ (n2
+ (let ((alist1 (alist-update (alist-update alist k v1 nil) k2 n2 nil)))
+ (cond
+ ((full-alist alist)
+ (mvlet (((values alist2 k v alist1) (split-nonleaf-alist alist1 b-tree-node-size/2)))
+ (values
+ (make-b-tree-node alist1 last-value)
+ (make-b-tree-node alist2 v)
+ k)))
+ (t
+ (make-b-tree-node alist1 last-value)))))
+ (t
+ (make-b-tree-node (alist-update alist k v1 nil) last-value))))
+ (mvlet* ((v last-value)
+ ((values v1 n2 k2) (sparse-vector-setter1 v)))
+ (cond
+ ((eq v v1)
+ n)
+ ((eq :delete v1)
+ (cond
+ ((null (cdrc alist)) ;if only one value remains
+ (cdrc (carc alist))) ;move it up in b-tree
+ (t
+ (make-b-tree-node (butlast alist) (cdrc (lastc alist))))))
+ (n2
+ (let ((alist1 (alist-update alist k2 n2 nil)))
+ (cond
+ ((full-alist alist)
+ (mvlet (((values alist2 k v alist1) (split-nonleaf-alist alist1 b-tree-node-size/2)))
+ (values
+ (make-b-tree-node alist1 v1)
+ (make-b-tree-node alist2 v)
+ k)))
+ (t
+ (make-b-tree-node alist1 v1)))))
+ (t
+ (make-b-tree-node alist v1)))))))))))
+ (mvlet (((values n1 n2 k2) (sparse-vector-setter1 n)))
+ (cond
+ ((eq n n1)
+ )
+ ((eq :delete n1)
+ (setf (sparse-vector-b-tree-root-node sparse-vector) nil))
+ (n2
+ (setf (sparse-vector-b-tree-root-node sparse-vector) (make-b-tree-node (list (cons k2 n2)) n1)))
+ (t
+ (setf (sparse-vector-b-tree-root-node sparse-vector) n1))))))))
+ (setf (sparse-vector-cached-key sparse-vector) index)
+ (setf (sparse-vector-cached-value sparse-vector) (if value (if (sparse-vector-boolean sparse-vector) index value) nil))
+ (if copy sparse-vector value))
+;;; ***
+
+(defun copy-sparse-vector (sparse-vector)
+ (declare (type sparse-vector sparse-vector))
+ (cond
+ ((null (sparse-vector-type sparse-vector))
+ (copy-structure sparse-vector))
+ (t
+ (error "Type ~A sparse-vector cannot be copied." (sparse-vector-type sparse-vector)))))
+
+(definline spacons (index value sparse-vector)
+ ;; does the following, except does not copy sparse-vector if it is not changed by the assignment
+ ;; (let ((sv (copy-sparse-vector sparse-vector)))
+ ;; (setf (sparef sv index) value)
+ ;; sv)
+ (sparse-vector-setter value sparse-vector index t))
+
+(defmacro do-map-sparse-vector-backward (min max boolean map)
+ ;; always returns nil
+ (let ((p (and (not boolean) (not (eq :indexes-only map))))
+ (k (or boolean map min max)))
+ `(labels
+ ((map1 (n)
+ (let ((alist (b-tree-node-alist n))
+ (last-value (b-tree-node-nonleaf-last-value n)))
+ (cond
+ ((null last-value)
+ ;; leaf node
+ (let (,@(when p (list `p)) ,@(when k (list `(k 0))))
+ ,@(when (and k (or min max)) (list `(declare (type sparse-vector-index k))))
+ (loop
+ ,@(cond
+ (boolean
+ (list
+ `(setf k (carc alist))))
+ ((and p k)
+ (list
+ `(setf k (carc (setf p (carc alist))))))
+ (p
+ (list
+ `(setf p (carc alist))))
+ (k
+ (list
+ `(setf k (carc (carc alist))))))
+ (cond
+ ,@(when max (list
+ `((and max (or (< (the sparse-vector-index max) k) (setf max nil)))
+ )))
+ ,@(when min (list
+ `((and min (> (the sparse-vector-index min) k))
+ (return-from map-sparse-vector-backward nil))))
+ (t
+ ,(cond
+ ((null map)
+ `(funcall function ,(if boolean `k `(cdrc p))))
+ ((eq :with-indexes map)
+ `(funcall function ,(if boolean `k `(cdrc p)) k))
+ (t ;(eq :indexes-only map)
+ `(funcall function k)))))
+ (when (null (setf alist (cdrc alist)))
+ (return nil)))))
+ (t
+ ;; nonleaf node
+ (let (p)
+ (loop
+ (setf p (carc alist))
+ (cond
+ ,@(when max (list
+ `((and max (< (the sparse-vector-index max) (the sparse-vector-index (carc p))))
+ )))
+ (t
+ (map1 (cdrc p))))
+ (when (null (setf alist (cdrc alist)))
+ (return nil))))
+ (cond
+ ,@(when max (list
+ `((and max (< (the sparse-vector-index max) (the sparse-vector-index (b-tree-node-smallest-key* last-value))))
+ )))
+ (t
+ (map1 last-value))))))))
+ (map1 n))))
+
+(defmacro do-map-sparse-vector-forward (min max boolean map)
+ ;; always returns nil
+ (let ((p (and (not boolean) (not (eq :indexes-only map))))
+ (k (or boolean map min max)))
+ `(labels
+ ((map1 (n)
+ (let ((alist (b-tree-node-alist n))
+ (last-value (b-tree-node-nonleaf-last-value n)))
+ (cond
+ ((null last-value)
+ ;; leaf node
+ (macrolet
+ ((domap1 ()
+ (nestn '(progn
+ (let ((alist (cdrc alist)))
+ (when alist
+ ***))
+ ,@(cond
+ (boolean
+ (list
+ `(setf k (carc alist))))
+ ((and p k)
+ (list
+ `(setf k (carc (setf p (carc alist))))))
+ (p
+ (list
+ `(setf p (carc alist))))
+ (k
+ (list
+ `(setf k (carc (carc alist))))))
+ (cond
+ ,@(when min (list
+ `((and min (or (> (the sparse-vector-index min) k) (setf min nil)))
+ )))
+ ,@(when max (list
+ `((and max (< (the sparse-vector-index max) k))
+ (return-from map-sparse-vector-forward nil))))
+ (t
+ ,(cond
+ ((null map)
+ `(funcall function ,(if boolean `k `(cdrc p))))
+ ((eq :with-indexes map)
+ `(funcall function ,(if boolean `k `(cdrc p)) k))
+ (t ;(eq :indexes-only map)
+ `(funcall function k))))))
+ nil
+ b-tree-node-size)))
+ (let (,@(when p (list `p)) ,@(when k (list `(k 0))))
+ ,@(when (and k (or min max)) (list `(declare (type sparse-vector-index k))))
+ (domap1))))
+ (t
+ ;; nonleaf node
+ (cond
+ ,@(when min (list
+ `((and min (> (the sparse-vector-index min) (the sparse-vector-index (b-tree-node-largest-key* last-value))))
+ )))
+ (t
+ (map1 last-value)))
+ (macrolet
+ ((domap1 ()
+ (nestn '(progn
+ (let ((alist (cdrc alist)))
+ (when alist
+ ***))
+ (setf v (cdrc (carc alist)))
+ (cond
+ ,@(when min (list
+ `((and min (> (the sparse-vector-index min) (the sparse-vector-index (b-tree-node-largest-key* v))))
+ )))
+ (t
+ (map1 v))))
+ nil
+ b-tree-node-size)))
+ (let (v)
+ (domap1))))))))
+ (map1 n)
+ nil)))
+
+(defun map-sparse-vector-backward (function n)
+ (do-map-sparse-vector-backward nil nil nil nil))
+
+(defun map-sparse-vector-backward-with-indexes (function n)
+ (do-map-sparse-vector-backward nil nil nil :with-indexes))
+
+(defun map-sparse-vector-backward-indexes-only (function n)
+ (do-map-sparse-vector-backward nil nil nil :indexes-only))
+
+(defun map-sparse-vector-forward (function n)
+ (do-map-sparse-vector-forward nil nil nil nil))
+
+(defun map-sparse-vector-forward-with-indexes (function n)
+ (do-map-sparse-vector-forward nil nil nil :with-indexes))
+
+(defun map-sparse-vector-forward-indexes-only (function n)
+ (do-map-sparse-vector-forward nil nil nil :indexes-only))
+
+(defun map-sparse-vector-backward-bounded (function n min max)
+ (block map-sparse-vector-backward
+ (do-map-sparse-vector-backward t t nil nil)))
+
+(defun map-sparse-vector-backward-bounded-with-indexes (function n min max)
+ (block map-sparse-vector-backward
+ (do-map-sparse-vector-backward t t nil :with-indexes)))
+
+(defun map-sparse-vector-backward-bounded-indexes-only (function n min max)
+ (block map-sparse-vector-backward
+ (do-map-sparse-vector-backward t t nil :indexes-only)))
+
+(defun map-sparse-vector-forward-bounded (function n min max)
+ (block map-sparse-vector-forward
+ (do-map-sparse-vector-forward t t nil nil)))
+
+(defun map-sparse-vector-forward-bounded-with-indexes (function n min max)
+ (block map-sparse-vector-forward
+ (do-map-sparse-vector-forward t t nil :with-indexes)))
+
+(defun map-sparse-vector-forward-bounded-indexes-only (function n min max)
+ (block map-sparse-vector-forward
+ (do-map-sparse-vector-forward t t nil :indexes-only)))
+
+(defun map-boolean-sparse-vector-backward (function n)
+ (do-map-sparse-vector-backward nil nil t nil))
+
+(defun map-boolean-sparse-vector-backward-with-indexes (function n)
+ (do-map-sparse-vector-backward nil nil t :with-indexes))
+
+(defun map-boolean-sparse-vector-forward (function n)
+ (do-map-sparse-vector-forward nil nil t nil))
+
+(defun map-boolean-sparse-vector-forward-with-indexes (function n)
+ (do-map-sparse-vector-forward nil nil t :with-indexes))
+
+(defun map-boolean-sparse-vector-backward-bounded (function n min max)
+ (block map-sparse-vector-backward
+ (do-map-sparse-vector-backward t t t nil)))
+
+(defun map-boolean-sparse-vector-backward-bounded-with-indexes (function n min max)
+ (block map-sparse-vector-backward
+ (do-map-sparse-vector-backward t t t :with-indexes)))
+
+(defun map-boolean-sparse-vector-forward-bounded (function n min max)
+ (block map-sparse-vector-forward
+ (do-map-sparse-vector-forward t t t nil)))
+
+(defun map-boolean-sparse-vector-forward-bounded-with-indexes (function n min max)
+ (block map-sparse-vector-forward
+ (do-map-sparse-vector-forward t t t :with-indexes)))
+
+;;; ****if* snark-sparse-array/map-sparse-vector0
+;;; USAGE
+;;; (map-sparse-vector0 function sparse-vector reverse min max map)
+;;; SOURCE
+
+(defun map-sparse-vector0 (function sparse-vector reverse min max map)
+ (declare (type sparse-vector sparse-vector))
+ ;; always returns nil
+ (let ((n (sparse-vector-b-tree-root-node sparse-vector)))
+ (unless (null n)
+ (let ((boolean (sparse-vector-boolean sparse-vector)))
+ (cond
+ ((and (null min) (null max))
+ (let ((alist (b-tree-node-alist n)))
+ (when (and (null (cdrc alist)) (null (b-tree-node-nonleaf-last-value n)))
+ (let ((p (carc alist))) ;(= 1 (sparse-vector-count sparse-vector)) special case
+ (if boolean
+ (cond
+ ((null map)
+ (funcall function p))
+ ((eq :with-indexes map)
+ (funcall function p p))
+ (t ;(eq :indexes-only map)
+ (funcall function p)))
+ (cond
+ ((null map)
+ (funcall function (cdrc p)))
+ ((eq :with-indexes map)
+ (funcall function (cdrc p) (carc p)))
+ (t ;(eq :indexes-only map)
+ (funcall function (carc p))))))
+ (return-from map-sparse-vector0 nil)))
+ (if reverse
+ (cond
+ ((null map)
+ (if boolean
+ (map-boolean-sparse-vector-backward function n)
+ (map-sparse-vector-backward function n)))
+ ((eq :with-indexes map)
+ (if boolean
+ (map-boolean-sparse-vector-backward-with-indexes function n)
+ (map-sparse-vector-backward-with-indexes function n)))
+ (t ;(eq :indexes-only map)
+ (if boolean
+ (map-boolean-sparse-vector-backward function n)
+ (map-sparse-vector-backward-indexes-only function n))))
+ (cond
+ ((null map)
+ (if boolean
+ (map-boolean-sparse-vector-forward function n)
+ (map-sparse-vector-forward function n)))
+ ((eq :with-indexes map)
+ (if boolean
+ (map-boolean-sparse-vector-forward-with-indexes function n)
+ (map-sparse-vector-forward-with-indexes function n)))
+ (t ;(eq :indexes-only map)
+ (if boolean
+ (map-boolean-sparse-vector-forward function n)
+ (map-sparse-vector-forward-indexes-only function n))))))
+ (t
+ (if reverse
+ (cond
+ ((null map)
+ (if boolean
+ (map-boolean-sparse-vector-backward-bounded function n min max)
+ (map-sparse-vector-backward-bounded function n min max)))
+ ((eq :with-indexes map)
+ (if boolean
+ (map-boolean-sparse-vector-backward-bounded-with-indexes function n min max)
+ (map-sparse-vector-backward-bounded-with-indexes function n min max)))
+ (t ;(eq :indexes-only map)
+ (if boolean
+ (map-boolean-sparse-vector-backward-bounded function n min max)
+ (map-sparse-vector-backward-bounded-indexes-only function n min max))))
+ (cond
+ ((null map)
+ (if boolean
+ (map-boolean-sparse-vector-forward-bounded function n min max)
+ (map-sparse-vector-forward-bounded function n min max)))
+ ((eq :with-indexes map)
+ (if boolean
+ (map-boolean-sparse-vector-forward-bounded-with-indexes function n min max)
+ (map-sparse-vector-forward-bounded-with-indexes function n min max)))
+ (t ;(eq :indexes-only map)
+ (if boolean
+ (map-boolean-sparse-vector-forward-bounded function n min max)
+ (map-sparse-vector-forward-bounded-indexes-only function n min max)))))))))))
+;;; ***
+
+;;; ****f* snark-sparse-array/map-sparse-vector
+;;; USAGE
+;;; (map-sparse-vector function sparse-vector &key reverse min max)
+;;; RETURN VALUE
+;;; nil
+;;; DESCRIPTION
+;;; The map-sparse-vector function applies its unary-function argument to
+;;; each value (or index, if sparse-vector is boolean) in sparse-vector.
+;;; It does nothing if sparse-vector is nil.
+;;;
+;;; The function is applied only to values whose index is >= min
+;;; and <= max if they are specified. If reverse is nil, the
+;;; function is applied to values in ascending order by index;
+;;; otherwise, the order is reversed.
+;;; SEE ALSO
+;;; map-sparse-vector-with-indexes
+;;; map-sparse-vector-indexes-only
+;;; SOURCE
+
+(definline map-sparse-vector (function sparse-vector &key reverse min max)
+ (when sparse-vector
+ (map-sparse-vector0 function sparse-vector reverse min max nil)))
+;;; ***
+
+;;; ****f* snark-sparse-array/map-sparse-vector-with-indexes
+;;; USAGE
+;;; (map-sparse-vector-with-indexes function sparse-vector &key reverse min max)
+;;; RETURN VALUE
+;;; nil
+;;; DESCRIPTION
+;;; The map-sparse-vector-with-indexes function is like map-sparse-vector,
+;;; but applies its binary-function argument to each value and index in sparse-vector.
+;;; SEE ALSO
+;;; map-sparse-vector
+;;; map-sparse-vector-indexes-only
+;;; SOURCE
+
+(definline map-sparse-vector-with-indexes (function sparse-vector &key reverse min max)
+ (when sparse-vector
+ (map-sparse-vector0 function sparse-vector reverse min max :with-indexes)))
+;;; ***
+
+;;; ****f* snark-sparse-array/map-sparse-vector-indexes-only
+;;; USAGE
+;;; (map-sparse-vector-indexes-only function sparse-vector &key reverse min max)
+;;; RETURN VALUE
+;;; nil
+;;; DESCRIPTION
+;;; The map-sparse-vector-indexes-only function is like map-sparse-vector,
+;;; but applies its unary-function argument to each index in sparse-vector.
+;;; map-sparse-vector and map-sparse-vector-indexes-only operate identically
+;;; on boolean sparse-vectors.
+;;; SEE ALSO
+;;; map-sparse-vector
+;;; map-sparse-vector-with-indexes
+;;; SOURCE
+
+(definline map-sparse-vector-indexes-only (function sparse-vector &key reverse min max)
+ (when sparse-vector
+ (map-sparse-vector0 function sparse-vector reverse min max :indexes-only)))
+;;; ***
+
+;;; ****f* snark-sparse-array/first-sparef
+;;; USAGE
+;;; (first-sparef sparse-vector)
+;;; RETURN VALUE
+;;; (values (sparef sparse-vector first-index) first-index) or
+;;; (values default-value nil) if sparse-vector is empty
+;;; SEE ALSO
+;;; pop-first-sparef
+;;; SOURCE
+
+(defun first-sparef (sparse-vector)
+ (declare (type sparse-vector sparse-vector))
+ (let ((n (sparse-vector-b-tree-root-node sparse-vector)))
+ (cond
+ ((null n)
+ (values (sparse-vector-default-value sparse-vector) nil))
+ (t
+ (mvlet (((values index value) (b-tree-node-smallest-key* n)))
+ (values
+ (setf (sparse-vector-cached-value sparse-vector) value)
+ (setf (sparse-vector-cached-key sparse-vector) index)))))))
+;;; ***
+
+;;; ****f* snark-sparse-array/last-sparef
+;;; USAGE
+;;; (last-sparef sparse-vector)
+;;; RETURN VALUE
+;;; (values (sparef sparse-vector last-index) last-index) or
+;;; (values default-value nil) if sparse-vector is empty
+;;; SEE ALSO
+;;; pop-last-sparef
+;;; SOURCE
+
+(defun last-sparef (sparse-vector)
+ (declare (type sparse-vector sparse-vector))
+ (let ((n (sparse-vector-b-tree-root-node sparse-vector)))
+ (cond
+ ((null n)
+ (values (sparse-vector-default-value sparse-vector) nil))
+ (t
+ (mvlet (((values index value) (b-tree-node-largest-key* n)))
+ (values
+ (setf (sparse-vector-cached-value sparse-vector) value)
+ (setf (sparse-vector-cached-key sparse-vector) index)))))))
+;;; ***
+
+;;; ****f* snark-sparse-array/pop-first-sparef
+;;; USAGE
+;;; (pop-first-sparef sparse-vector)
+;;; RETURN VALUE
+;;; (values (sparef sparse-vector first-index) first-index) or
+;;; (values default-value nil) if sparse-vector is empty
+;;; SIDE EFFECTS
+;;; removes it from sparse-vector
+;;; SEE ALSO
+;;; first-sparef
+;;; SOURCE
+
+(defun pop-first-sparef (sparse-vector)
+ (declare (type sparse-vector sparse-vector))
+ (mvlet (((values value index) (first-sparef sparse-vector)))
+ (when index
+ (sparse-vector-setter (sparse-vector-default-value sparse-vector) sparse-vector index))
+ (values value index)))
+;;; ***
+
+;;; ****f* snark-sparse-array/pop-last-sparef
+;;; USAGE
+;;; (pop-last-sparef sparse-vector)
+;;; RETURN VALUE
+;;; (values (sparef sparse-vector last-index) last-index) or
+;;; (values default-value nil) if sparse-vector is empty
+;;; SIDE EFFECTS
+;;; removes it from sparse-vector
+;;; SEE ALSO
+;;; last-sparef
+;;; SOURCE
+
+(defun pop-last-sparef (sparse-vector)
+ (declare (type sparse-vector sparse-vector))
+ (mvlet (((values value index) (last-sparef sparse-vector)))
+ (when index
+ (sparse-vector-setter (sparse-vector-default-value sparse-vector) sparse-vector index))
+ (values value index)))
+;;; ***
+
+;;; sparse-vector5.lisp EOF
diff --git a/snark-20120808r02/src/subst.abcl b/snark-20120808r02/src/subst.abcl
new file mode 100644
index 0000000..df88f6d
Binary files /dev/null and b/snark-20120808r02/src/subst.abcl differ
diff --git a/snark-20120808r02/src/subst.lisp b/snark-20120808r02/src/subst.lisp
new file mode 100644
index 0000000..109404e
--- /dev/null
+++ b/snark-20120808r02/src/subst.lisp
@@ -0,0 +1,611 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: subst.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; a substitution is a list of bindings and an alist of variables and values
+;;; substitutions can be manipulated as SNARK terms if this ever becomes useful
+
+(defmacro make-binding (var value)
+ `(cons ,var ,value))
+
+(defmacro binding-var (binding)
+ `(car ,binding))
+
+(defmacro binding-value (binding)
+ `(cdr ,binding))
+
+(defmacro add-binding-to-substitution (binding subst)
+ `(cons ,binding ,subst))
+
+(defmacro dobindings ((binding subst &optional resultform) &body body)
+ `(dolist (,binding ,subst ,resultform)
+ ,@body))
+
+(definline bind-variable-to-term (var term subst)
+ (add-binding-to-substitution (make-binding var term) subst))
+
+(defun lookup-variable-in-substitution (var subst)
+ (let ((v (assoc var subst :test #'eq)))
+ (if v (binding-value v) none)))
+
+(defun lookup-value-in-substitution (value subst)
+ (let ((v (rassoc value subst)))
+ (if v (binding-var v) none)))
+
+(defun lookup-value-in-substitution2 (value subst subst2)
+ (let ((v (rassoc value subst :test (lambda (x y) (equal-p x y subst2)))))
+ (if v (binding-var v) none)))
+
+(defun substitution-equal-p (subst1 subst2)
+ (and (length= subst1 subst2)
+ (substitution-subset-p1 subst1 subst2)))
+
+(defun substitution-subset-p (subst1 subst2)
+ (and (length<= subst1 subst2)
+ (substitution-subset-p1 subst1 subst2)))
+
+(defun substitution-diff (subst1 subst2)
+ (if subst2 (ldiff subst1 subst2) subst1))
+
+(defun substitution-diff2 (subst1 subst2)
+ (labels
+ ((subst-diff (subst1)
+ (if (null subst1)
+ nil
+ (let* ((b1 (first subst1))
+ (var (binding-var b1))
+ (val1 (binding-value b1))
+ (val2 (lookup-variable-in-substitution var subst2)))
+ (cond
+ ((eq none val2) ;var is unbound in subst2
+ (let* ((l (rest subst1))
+ (l* (subst-diff l)))
+ (cond
+ ((eq none l*)
+ none)
+ ((eq l l*)
+ subst1)
+ (t
+ (cons b1 l*)))))
+ ((equal-p val1 val2) ;var is bound equally in subst1 and subst2
+ (subst-diff (rest subst1)))
+ (t ;var is bound unequally in subst1 and subst2
+ none)))))) ;return none to signal incompatibility
+ (if (null subst2)
+ subst1
+ (subst-diff subst1))))
+
+(defun substitution-subset-p1 (subst1 subst2)
+ (loop
+ (if (null subst1)
+ (return t)
+ (let ((v (lookup-variable-in-substitution (binding-var (first subst1)) subst2)))
+ (if (and (neq none v) (equal-p (binding-value (first subst1)) v))
+ (setf subst1 (rest subst1))
+ (return nil))))))
+
+(defun remove-irrelevant-bindings (subst term)
+ (cond
+ ((null subst)
+ nil)
+ ((not (variable-occurs-p (binding-var (first subst)) term nil))
+ (remove-irrelevant-bindings (rest subst) term))
+ (t
+ (let* ((l (rest subst))
+ (l* (remove-irrelevant-bindings l term)))
+ (if (eq l l*)
+ subst
+ (add-binding-to-substitution (first subst) l*))))))
+
+(defun print-substitution (subst)
+ (format t "{ ")
+ (let ((first t))
+ (dobindings (binding subst)
+ (if first
+ (setf first nil)
+ (princ " , "))
+ (format t "~S -> ~S" (binding-var binding) (binding-value binding))))
+ (format t " }")
+ subst)
+
+(defun make-idempotent-substitution (subst)
+ ;; create an idempotent substitution from subst
+ ;; by instantiating the variable values
+ (cond
+ ((null subst)
+ nil)
+ ((null (rest subst))
+ subst)
+ (t
+ (setf subst (copy-alist subst))
+ (dolist (binding subst)
+ (setf (binding-value binding) (instantiate (binding-value binding) subst)))
+ subst)))
+
+(defun variables (x &optional subst vars)
+ "return a list of all the variables that occur in x"
+ (dereference
+ x subst
+ :if-constant vars
+ :if-compound-cons (variables (cdrc x) subst (variables (carc x) subst vars))
+ :if-compound-appl (dolist (x1 (argsa x) vars)
+ (setf vars (variables x1 subst vars)))
+ :if-variable (adjoin x vars)))
+
+(defun nontheory-variables (x &optional subst theory vars)
+ (dereference
+ x subst
+ :if-constant vars
+ :if-compound-cons (nontheory-variables (cdrc x) subst theory (nontheory-variables (carc x) subst theory vars))
+ :if-compound-appl (let ((head (heada x)))
+ (unless (function-constructor head) ;constructor symbols are transparent wrt theory
+ (setf theory (function-constraint-theory head)))
+ (dolist (x1 (argsa x) vars)
+ (setf vars (nontheory-variables x1 subst theory vars))))
+ :if-variable (if (null theory) (adjoin x vars) vars))) ;only variables under nontheory symbols are returned
+
+(defun variablesl (l &optional subst vars)
+ (dolist (x l vars)
+ (setf vars (variables x subst vars))))
+
+(defun first-nonvariable-term (terms &optional subst)
+ (dolist (term terms none)
+ (dereference
+ term subst
+ :if-constant (return term)
+ :if-compound (return term))))
+
+(defun first-nonvariable-subterm (terms &optional subst)
+ (dolist (term terms none)
+ (dereference
+ term subst
+ :if-compound (let ((v (first-nonvariable-term (args term))))
+ (unless (eq none v)
+ (return v))))))
+
+(defun variable-counts (x &optional subst counts)
+ "return a list of all the variables that occur in x with their frequency, in dotted pairs"
+ (dereference
+ x subst
+ :if-constant counts
+ :if-compound-cons (variable-counts (cdrc x) subst (variable-counts (carc x) subst counts))
+ :if-compound-appl (dolist (x1 (argsa x) counts)
+ (setf counts (variable-counts x1 subst counts)))
+ :if-variable (let ((v (assoc/eq x counts)))
+ (if v (progn (incf (cdrc v)) counts) (cons (cons x 1) counts)))))
+
+(defun variable-disjoint-partition (l &optional subst)
+ (let ((l* nil))
+ (dolist (x l)
+ ;; bind all variables in x to first variable in x
+ (let ((firstvar nil))
+ (labels
+ ((unify-variables (x)
+ (dereference
+ x subst
+ :if-variable (cond
+ ((null firstvar)
+ (setf firstvar x))
+ ((neq firstvar x)
+ (setf subst (bind-variable-to-term x firstvar subst))))
+ :if-compound-cons (progn (unify-variables (carc x)) (unify-variables (cdrc x)))
+ :if-compound-appl (dolist (x (argsa x)) (unify-variables x)))))
+ (unify-variables x))
+ (push (cons firstvar x) l*))) ;record firstvar with expression
+ (let ((partition nil) (ground nil))
+ (dolist (x l*)
+ (let ((p (car x)))
+ (cond
+ ((null p)
+ (push (cdr x) ground))
+ (t
+ (dereference p subst) ;use each dereferenced firstvar as key for partition
+ (let ((v (assoc p partition)))
+ (if v
+ (push (cdr x) (cdr v))
+ (push (list p (cdr x)) partition)))))))
+ (dolist (v partition) ;remove keys, leaving only expressions
+ (setf (car v) (cadr v))
+ (setf (cdr v) (cddr v)))
+ (if ground
+ (values (cons ground partition) t) ;if any expressions are ground, put them first in partition, and return 2nd value t
+ partition))))
+
+(defun new-variables (x &optional subst vars)
+ "return a list of all the variables that occur in x but are not in vars"
+ ;; ldiff could be done destructively
+ (ldiff (variables x subst vars) vars))
+
+(defun instantiate (x n &optional subst)
+ "applies substitution to x, optionally first renumbering block-0 variables to block-n"
+ (cond
+ ((constant-p x)
+ x)
+ (t
+ (when (or (consp n) (numberp subst)) ;accept n and subst arguments in either order
+ (psetq subst n n subst))
+ (if (or (null n) (zerop n))
+ (if (null subst)
+ x ;nop
+ (labels ;just substitute
+ ((instantiate* (x)
+ (dereference
+ x subst
+ :if-variable x
+ :if-constant x
+ :if-compound-cons (lcons (instantiate* (car x)) (instantiate* (cdr x)) x)
+ :if-compound-appl (let* ((args (argsa x)) (args* (instantiatel args)))
+ (if (eq args args*) x (make-compound* (heada x) args*)))))
+ (instantiatel (l)
+ (lcons (instantiate* (first l)) (instantiatel (rest l)) l)))
+ (instantiate* x)))
+ (let ((incr (variable-block n)))
+ (if (null subst)
+ (labels ;just renumber
+ ((instantiate* (x)
+ (dereference
+ x nil
+ :if-variable (let ((n (variable-number x)))
+ (if (variable-block-0-p n)
+ (make-variable (variable-sort x) (+ n incr))
+ x))
+ :if-constant x
+ :if-compound-cons (lcons (instantiate* (car x)) (instantiate* (cdr x)) x)
+ :if-compound-appl (let* ((args (argsa x)) (args* (instantiatel args)))
+ (if (eq args args*) x (make-compound* (heada x) args*)))))
+ (instantiatel (l)
+ (lcons (instantiate* (first l)) (instantiatel (rest l)) l)))
+ (instantiate* x))
+ (labels ;renumber and substitute
+ ((instantiate* (x)
+ (when (variable-p x)
+ (let ((n (variable-number x)))
+ (when (variable-block-0-p n)
+ (setf x (make-variable (variable-sort x) (+ n incr))))))
+ (dereference
+ x subst
+ :if-variable x
+ :if-constant x
+ :if-compound-cons (lcons (instantiate* (car x)) (instantiate* (cdr x)) x)
+ :if-compound-appl (let* ((args (argsa x)) (args* (instantiatel args)))
+ (if (eq args args*) x (make-compound* (heada x) args*)))))
+ (instantiatel (l)
+ (lcons (instantiate* (first l)) (instantiatel (rest l)) l)))
+ (instantiate* x))))))))
+
+(defun renumber (x &optional subst rsubst)
+ "applies substitution to x and renumbers variables (normally to block 0)"
+ (dereference
+ x subst
+ :if-constant (values x rsubst)
+ :if-compound-cons (values (let (u v)
+ (setf (values u rsubst) (renumber (carc x) subst rsubst))
+ (setf (values v rsubst) (renumber (cdrc x) subst rsubst))
+ (lcons u v x))
+ rsubst)
+ :if-compound-appl (values (let* ((args (argsa x))
+ (args* (let (dummy)
+ (declare (ignorable dummy))
+ (setf (values dummy rsubst)
+ (renumberl args subst rsubst)))))
+ (if (eq args args*)
+ x
+ (make-compound* (head x) args*)))
+ rsubst)
+ :if-variable (let ((v (lookup-variable-in-substitution x rsubst)))
+ (cond
+ ((neq none v)
+ (values v rsubst))
+ (t
+ (let ((var (renumberv x rsubst)))
+;; (values var (bind-variable-to-term x var rsubst)) ;maybe x=var
+ (values var (cons (cons x var) rsubst))))))))
+
+(defun renumberl (l subst rsubst)
+ (let (dummy)
+ (declare (ignorable dummy))
+ (values (lcons (setf (values dummy rsubst) (renumber (first l) subst rsubst))
+ (setf (values dummy rsubst) (renumberl (rest l) subst rsubst))
+ l)
+ rsubst)))
+
+(defvar *renumber-first-number* 0)
+(defvar *renumber-by-sort* nil)
+(defvar *renumber-ignore-sort* nil)
+
+(defun renumberv (var rsubst)
+ (let ((sort (if *renumber-ignore-sort* (top-sort) (variable-sort var))))
+ (if (null *renumber-first-number*)
+ (make-variable sort)
+ (loop
+ (cond
+ ((null rsubst)
+ (return (make-variable sort *renumber-first-number*)))
+ (t
+ (let ((binding (first rsubst)))
+ (when (implies *renumber-by-sort* (same-sort? sort (variable-sort (binding-value binding))))
+ (return (make-variable sort (+ (variable-number (binding-value binding)) 1)))))
+ (setf rsubst (rest rsubst))))))))
+
+(defun renumber-new (x &optional subst rsubst)
+ "applies substitution to x and renumbers variables to all new variables"
+ (let ((*renumber-first-number* nil))
+ (renumber x subst rsubst)))
+
+(defun renumberer ()
+ (let ((variable-substitution nil)
+ (compound-substitution nil))
+ #'(lambda (x &optional subst)
+ (labels
+ ((renumber (x)
+ (dereference
+ x subst
+ :if-constant x
+ :if-variable (let ((v (lookup-variable-in-substitution x variable-substitution)))
+ (if (neq none v)
+ v
+ (let ((x* (make-variable (variable-sort x))))
+ (setf variable-substitution (bind-variable-to-term x x* variable-substitution))
+ x*)))
+ :if-compound-appl (let ((v (assoc x compound-substitution :test #'eq)))
+ (if v
+ (cdrc v)
+ (let* ((args (argsa x))
+ (args* (renumberl args))
+ (x* (if (eq args args*) x (make-compound* (heada x) args*))))
+ (setf compound-substitution (acons x x* compound-substitution))
+ x*)))
+ :if-compound-cons (lcons (renumber (carc x)) (renumber (cdrc x)) x)))
+ (renumberl (l)
+ (lcons (renumber (carc l)) (renumberl (cdrc l)) l)))
+ (renumber x)))))
+
+(defun ground-p (x &optional subst)
+ "return t if x is ground, nil otherwise"
+ (dereference
+ x subst
+ :if-constant t
+ :if-compound-cons (and (ground-p (carc x) subst) (ground-p (cdrc x) subst))
+ :if-compound-appl (loop for x1 in (argsa x)
+ always (ground-p x1 subst))
+ :if-variable nil))
+
+(defun frozen-p (x subst)
+ "return t if all variables of x are frozen, nil otherwise"
+ (dereference
+ x subst
+ :if-constant t
+ :if-compound-cons (and (frozen-p (carc x) subst) (frozen-p (cdrc x) subst))
+ :if-compound-appl (loop for x1 in (argsa x)
+ always (frozen-p x1 subst))
+ :if-variable (variable-frozen-p x)))
+
+(defun constructor-term-p (x subst)
+ ;; returns t if x is built entirely from constructors
+ ;; treat nil as second argument of cons as a constructor even if not declared as such
+ (dereference
+ x subst
+ :if-constant (constant-constructor x)
+ :if-compound-cons (and (constructor-term-p (carc x) subst) (constructor-term-p (cdrc x) subst))
+ :if-compound-appl (and (function-constructor (heada x))
+ (loop for x1 in (argsa x)
+ always (constructor-term-p x1 subst)))
+ :if-variable nil))
+
+(defun unsorted-p (x &optional subst)
+ ;; check whether all symbols in x are unsorted
+ ;; except $$cons and nil
+ ;; and numbers and strings?
+ (dereference
+ x subst
+ :if-variable (top-sort? (variable-sort x))
+ :if-constant (or (null x) (top-sort? (constant-sort x)))
+ :if-compound-cons (and (unsorted-p (carc x) subst) (unsorted-p (cdrc x) subst))
+ :if-compound-appl (and (top-sort? (function-sort (heada x)))
+ (loop for x1 in (argsa x)
+ always (unsorted-p x1 subst)))))
+
+(defun all-variables-p (terms &optional subst)
+ (dolist (term terms t)
+ (dereference
+ term subst
+ :if-constant (return nil)
+ :if-compound (return nil))))
+
+(defun occurs-p (x y &optional subst)
+ "return t if x occurs in y, nil otherwise"
+ (dereference
+ x subst
+ :if-constant (if (function-symbol-p x)
+ (function-occurs-p x y subst)
+ (constant-occurs-p x y subst))
+ :if-compound (compound-occurs-p x y subst)
+ :if-variable (variable-occurs-p x y subst)))
+
+(defun function-occurs-p (x y subst)
+ (dereference
+ y subst
+ :if-compound (or (eq x (head y))
+ (loop for y1 in (args y)
+ thereis (function-occurs-p x y1 subst)))))
+
+(defun constant-occurs-p (x y subst)
+ "return t if atom x occurs in y, nil otherwise"
+ (dereference
+ y subst
+ :if-constant (eql x y)
+ :if-compound (loop for y1 in (args y)
+ thereis (constant-occurs-p x y1 subst))))
+
+(defun compound-occurs-p (x y subst)
+ "return t if compound x occurs in y, nil otherwise"
+ (dereference
+ y subst
+ :if-compound (or (equal-p x y subst)
+ (loop for y1 in (args y)
+ thereis (compound-occurs-p x y1 subst)))))
+
+(defun no-new-variable-occurs-p (x subst vars)
+ ;; returns t if every variable in x.subst is a member of vars, nil otherwise
+ (labels ((no-new-variable (x)
+ (dereference
+ x subst
+ :if-variable (member x vars :test #'eq)
+ :if-constant t
+ :if-compound-cons (and (no-new-variable (carc x)) (no-new-variable (cdrc x)))
+ :if-compound-appl (dolist (x1 (argsa x) t)
+ (unless (no-new-variable x1)
+ (return nil))))))
+ (not (null (no-new-variable x)))))
+
+(defun constant-occurs-below-constructor-p (x y subst)
+ (labels
+ ((occ (y)
+ (dereference
+ y subst
+ :if-constant (eql x y)
+ :if-compound-cons (or (occ (carc y)) (occ (cdrc y)))
+ :if-compound-appl (and (function-constructor (heada y))
+ (loop for y1 in (argsa y) thereis (occ y1))))))
+ (dereference
+ y subst
+ :if-compound-cons (or (occ (carc y)) (occ (cdrc y)))
+ :if-compound-appl (and (function-constructor (heada y))
+ (loop for y1 in (argsa y) thereis (occ y1))))))
+
+(defun variable-occurs-below-constructor-p (x y subst)
+ (labels
+ ((occ (y)
+ (dereference
+ y subst
+ :if-variable (eq x y)
+ :if-compound-cons (or (occ (carc y)) (occ (cdrc y)))
+ :if-compound-appl (and (function-constructor (heada y))
+ (loop for y1 in (args y) thereis (occ y1))))))
+ (dereference
+ y subst
+ :if-compound-cons (or (occ (carc y)) (occ (cdrc y)))
+ :if-compound-appl (and (function-constructor (heada y))
+ (loop for y1 in (argsa y) thereis (occ y1))))))
+
+(defun compound-occurs-below-constructor-p (x y subst)
+ (labels
+ ((occ (y)
+ (dereference
+ y subst
+ :if-compound-cons (or (if (consp x) (equal-p x y subst) nil)
+ (or (occ (carc y)) (occ (cdrc y))))
+ :if-compound-appl (or (if (consp x) nil (equal-p x y subst))
+ (and (function-constructor (heada y))
+ (loop for y1 in (argsa y) thereis (occ y1)))))))
+ (dereference
+ y subst
+ :if-compound-cons (or (occ (carc y)) (occ (cdrc y)))
+ :if-compound-appl (and (function-constructor (heada y))
+ (loop for y1 in (argsa y) thereis (occ y1))))))
+
+(defmacro variable-occurs-p1-macro ()
+ `(dereference
+ y nil
+ :if-compound-cons (or (variable-occurs-p1 x (carc y)) (variable-occurs-p1 x (cdrc y)))
+ :if-compound-appl (dolist (y (argsa y) nil)
+ (when (variable-occurs-p1 x y)
+ (return t)))
+ :if-variable (eq x y)))
+
+(defmacro variable-occurs-p2-macro ()
+ `(dereference
+ y subst
+ :if-compound-cons (or (variable-occurs-p2 x (carc y) subst) (variable-occurs-p2 x (cdrc y) subst))
+ :if-compound-appl (dolist (y (argsa y) nil)
+ (when (variable-occurs-p2 x y subst)
+ (return t)))
+ :if-variable (eq x y)))
+
+(defun variable-occurs-p1l (x l)
+ (dolist (y l nil)
+ (when (variable-occurs-p1-macro)
+ (return t))))
+
+(defun variable-occurs-p2l (x l subst)
+ (dolist (y l nil)
+ (when (variable-occurs-p2-macro)
+ (return t))))
+
+(defun variable-occurs-p1 (x y)
+ (variable-occurs-p1-macro))
+
+(defun variable-occurs-p2 (x y subst)
+ (variable-occurs-p2-macro))
+
+(defun variable-occurs-p (x y subst)
+ "return t if variable x occurs in y, nil otherwise"
+ (if (null subst)
+ (variable-occurs-p1-macro)
+ (variable-occurs-p2-macro)))
+
+(defun special-unify-p (x subst)
+ (dereference
+ x subst
+ :if-compound (or (function-unify-code (head x))
+ (loop for x1 in (args x)
+ thereis (special-unify-p x1 subst)))))
+
+(defun skolem-occurs-p (x subst)
+ (dereference
+ x subst
+ :if-constant (constant-skolem-p x)
+ :if-compound (or (function-skolem-p (head x))
+ (loop for x1 in (args x)
+ thereis (skolem-occurs-p x1 subst)))))
+
+(defun disallowed-symbol-occurs-in-answer-p (x subst)
+ (dereference
+ x subst
+ :if-constant (not (constant-allowed-in-answer x))
+ :if-compound (or (not (function-allowed-in-answer (head x)))
+ (loop for x1 in (args x)
+ thereis (disallowed-symbol-occurs-in-answer-p x1 subst)))))
+
+(defun embedding-variable-occurs-p (x subst)
+ (dereference
+ x subst
+ :if-compound (loop for x1 in (args x)
+ thereis (embedding-variable-occurs-p x1 subst))
+ :if-variable (embedding-variable-p x)))
+
+(defun split-if (test list &optional subst)
+ ;; split list into lists of dereferenced items that satisfy and don't satisfy test
+ (if (dereference list subst :if-compound-cons t)
+ (let ((l (rest list)))
+ (multiple-value-bind (l1 l2) (split-if test l subst)
+ (let ((x (first list)))
+ (let ((x* x))
+ (dereference x* subst)
+ (if (funcall test x*)
+ (if (and (eq l l1) (eq x x*))
+ (values list l2)
+ (values (cons x* l1) l2))
+ (if (and (eq l l2) (eq x x*))
+ (values l1 list)
+ (values l1 (cons x* l2))))))))
+ (values nil list)))
+
+;;; subst.lisp EOF
diff --git a/snark-20120808r02/src/substitute.abcl b/snark-20120808r02/src/substitute.abcl
new file mode 100644
index 0000000..7986aac
Binary files /dev/null and b/snark-20120808r02/src/substitute.abcl differ
diff --git a/snark-20120808r02/src/substitute.lisp b/snark-20120808r02/src/substitute.lisp
new file mode 100644
index 0000000..5c17818
--- /dev/null
+++ b/snark-20120808r02/src/substitute.lisp
@@ -0,0 +1,201 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: substitute.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2008.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun substitute (new old x &optional subst)
+ "substitute new for old in x"
+ (dereference
+ old subst
+ :if-constant (if (function-symbol-p old)
+ (unimplemented)
+ (substitute-for-constant new old x subst))
+ :if-compound (substitute-for-compound new old x subst)
+ :if-variable (substitute-for-variable new old x subst)))
+
+(defun substitutel (new old l &optional subst)
+ (dereference
+ old subst
+ :if-constant (if (function-symbol-p old)
+ (unimplemented)
+ (substitute-for-constantl new old l subst))
+ :if-compound (substitute-for-compoundl new old l subst)
+ :if-variable (substitute-for-variablel new old l subst)))
+
+(defun substitute-for-constant (new old x subst)
+ "substitute new for constant old in x"
+ ;; if old = nil, replace it in conses, but not at end of argument lists
+ (dereference
+ x subst
+ :if-constant (if (eql old x) new x)
+ :if-compound-cons (let* ((u (carc x)) (u* (substitute-for-constant new old u subst))
+ (v (cdrc x)) (v* (substitute-for-constant new old v subst)))
+ (if (and (eql u u*) (eql v v*)) x (cons u* v*)))
+ :if-compound-appl (let* ((args (argsa x)) (args* (substitute-for-constantl new old args subst)))
+ (if (eq args args*) x (make-compound* (heada x) args*)))
+ :if-variable x))
+
+(defun substitute-for-compound (new old x subst)
+ "substitute new for compound old in x"
+ (dereference
+ x subst
+ :if-constant x
+ :if-compound-cons (cond
+ ((equal-p old x subst)
+ new)
+ (t
+ (lcons (substitute-for-compound new old (car x) subst)
+ (substitute-for-compound new old (cdr x) subst)
+ x)))
+ :if-compound-appl (cond
+ ((equal-p old x subst)
+ new)
+ (t
+ (let* ((args (argsa x)) (args* (substitute-for-compoundl new old args subst)))
+ (if (eq args args*) x (make-compound* (heada x) args*)))))
+ :if-variable x))
+
+(defun substitute-for-variable (new old x subst)
+ "substitute new for variable old in x"
+ (dereference
+ x subst
+ :if-constant x
+ :if-compound-appl (let* ((args (argsa x)) (args* (substitute-for-variablel new old args subst)))
+ (if (eq args args*) x (make-compound* (heada x) args*)))
+ :if-compound-cons (lcons (substitute-for-variable new old (carc x) subst)
+ (substitute-for-variable new old (cdrc x) subst)
+ x)
+ :if-variable (if (eq old x) new x)))
+
+(defun substitute-once (cc new old x &optional subst)
+ (dereference
+ old subst
+ :if-constant (if (function-symbol-p old)
+ (unimplemented)
+ (substitute-for-constant-once cc new old x subst))
+ :if-compound (substitute-for-compound-once cc new old x subst)
+ :if-variable (substitute-for-variable-once cc new old x subst)))
+
+(defun substitute-for-constant-once (cc new old x subst)
+ ;; if old = nil, replace it in conses, but not at end of argument lists
+ (dereference
+ x subst
+ :if-constant (when (eql old x)
+ (funcall cc new))
+ :if-compound-cons (let ((u (carc x)) (v (cdrc x)))
+ (prog->
+ (substitute-for-constant-once new old u subst ->* u*)
+ (funcall cc (cons u* v)))
+ (prog->
+ (substitute-for-constant-once new old v subst ->* v*)
+ (funcall cc (cons u v*))))
+ :if-compound-appl (prog->
+ (argsa x ->nonnil args)
+ (heada x -> head)
+ (substitute-for-constant-oncel new old args subst ->* args*)
+ (funcall cc (make-compound* head args*)))))
+
+(defun substitute-for-compound-once (cc new old x subst)
+ (dereference
+ x subst
+ :if-compound-cons (cond
+ ((equal-p old x subst)
+ (funcall cc new))
+ (t
+ (let ((u (carc x)) (v (cdrc x)))
+ (prog->
+ (substitute-for-compound-once new old u subst ->* u*)
+ (funcall cc (cons u* v)))
+ (prog->
+ (substitute-for-compound-once new old v subst ->* v*)
+ (funcall cc (cons u v*))))))
+ :if-compound-appl (cond
+ ((equal-p old x subst)
+ (funcall cc new))
+ (t
+ (prog->
+ (argsa x ->nonnil args)
+ (heada x -> head)
+ (substitute-for-compound-oncel new old args subst ->* args*)
+ (funcall cc (make-compound* head args*)))))))
+
+(defun substitute-for-variable-once (cc new old x subst)
+ (dereference
+ x subst
+ :if-compound-cons (let ((u (carc x)) (v (cdrc x)))
+ (prog->
+ (substitute-for-variable-once new old u subst ->* u*)
+ (funcall cc (cons u* v)))
+ (prog->
+ (substitute-for-variable-once new old v subst ->* v*)
+ (funcall cc (cons u v*))))
+ :if-compound-appl (prog->
+ (argsa x ->nonnil args)
+ (heada x -> head)
+ (substitute-for-variable-oncel new old args subst ->* args*)
+ (funcall cc (make-compound* head args*)))
+ :if-variable (when (eq old x)
+ (funcall cc new))))
+
+(defun substitute-for-constantl (new old l subst)
+ (lcons (substitute-for-constant new old (first l) subst)
+ (substitute-for-constantl new old (rest l) subst)
+ l))
+
+(defun substitute-for-compoundl (new old l subst)
+ (lcons (substitute-for-compound new old (first l) subst)
+ (substitute-for-compoundl new old (rest l) subst)
+ l))
+
+(defun substitute-for-variablel (new old l subst)
+ (lcons (substitute-for-variable new old (first l) subst)
+ (substitute-for-variablel new old (rest l) subst)
+ l))
+
+(defun substitute-for-constant-oncel (cc new old l subst)
+ (let ((a (first l)) (d (rest l)))
+ (prog->
+ (substitute-for-constant-once new old a subst ->* a*)
+ (funcall cc (cons a* d)))
+ (when d
+ (prog->
+ (substitute-for-constant-oncel new old d subst ->* d*)
+ (funcall cc (cons a d*))))))
+
+(defun substitute-for-compound-oncel (cc new old l subst)
+ (let ((a (first l)) (d (rest l)))
+ (prog->
+ (substitute-for-compound-once new old a subst ->* a*)
+ (funcall cc (cons a* d)))
+ (when d
+ (prog->
+ (substitute-for-compound-oncel new old d subst ->* d*)
+ (funcall cc (cons a d*))))))
+
+(defun substitute-for-variable-oncel (cc new old l subst)
+ (let ((a (first l)) (d (rest l)))
+ (prog->
+ (substitute-for-variable-once new old a subst ->* a*)
+ (funcall cc (cons a* d)))
+ (when d
+ (prog->
+ (substitute-for-variable-oncel new old d subst ->* d*)
+ (funcall cc (cons a d*))))))
+
+;;; substitute.lisp EOF
diff --git a/snark-20120808r02/src/subsume-bag.abcl b/snark-20120808r02/src/subsume-bag.abcl
new file mode 100644
index 0000000..3b973df
Binary files /dev/null and b/snark-20120808r02/src/subsume-bag.abcl differ
diff --git a/snark-20120808r02/src/subsume-bag.lisp b/snark-20120808r02/src/subsume-bag.lisp
new file mode 100644
index 0000000..db53cff
--- /dev/null
+++ b/snark-20120808r02/src/subsume-bag.lisp
@@ -0,0 +1,192 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: subsume-bag.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; notes:
+;;; should check sort compatibility of variable and (fn ...) earlier
+;;; incomplete identity handling
+;;; variables in terms1 can be bound to identity
+;;; count-arguments, recount-arguments don't eliminate identity
+;;; using recount-arguments is somewhat inefficient
+;;; it recompares terms in terms2
+;;; it could check whether terms in terms1 are frozen
+;;; use solve-sum instead of solve-sum-solutions?
+
+(defun subsume-bag (cc terms1 terms2 subst fn)
+ ;; assume variables of terms2 are already frozen
+ ;; eliminate terms in common, find multiplicities
+ (subsume-bag0 cc (count-arguments fn terms2 subst (count-arguments fn terms1 subst) -1) subst fn))
+
+(defun subsume-bag0 (cc terms-and-counts subst fn)
+ ;; ensure length constraint is satisfiable
+ (let ((len1 0) (len2 0) (vars nil) (varc 0))
+ (dolist (tc terms-and-counts)
+ (let ((c (tc-count tc)))
+ (cond
+ ((plusp c)
+ (if (unfrozen-variable-p (tc-term tc))
+ (progn
+ (push c vars)
+ (incf varc c))
+ (incf len1 c)))
+ ((minusp c)
+ (decf len2 c)))))
+ (cond
+ ((null vars)
+ (when (eql len1 len2)
+ (if (eql 0 len1)
+ (funcall cc subst)
+ (subsume-bag1 cc terms-and-counts subst fn))))
+ ((if (eq none (function-identity2 fn))
+ (and (<= (+ len1 varc) len2) (solve-sum-p (- len2 len1 varc) vars))
+ (and (<= len1 len2) (solve-sum-p (- len2 len1) vars)))
+ (if (eql 0 len1)
+ (subsume-bag2 cc terms-and-counts subst fn)
+ (subsume-bag1 cc terms-and-counts subst fn))))))
+
+(defun subsume-bag1 (cc terms-and-counts subst fn)
+ ;; eliminate highest multiplicity nonvariable term in terms1
+ ;; by matching it with terms in terms2
+ (prog->
+ (maxtc1 terms-and-counts subst -> tc1)
+;; (cl:assert tc1)
+ (unless (eq 'quit tc1) ;unmatched frozen term in terms1
+ (dolist terms-and-counts ->* tc2)
+ (when (<= (tc-count tc1) (- (tc-count tc2)))
+ (unify (tc-term tc1) (tc-term tc2) subst ->* subst)
+ (subsume-bag0 cc (recount-arguments fn terms-and-counts subst) subst fn)))))
+
+(defun subsume-bag2 (cc terms-and-counts subst fn)
+ ;; only variables left in terms1
+ ;; generate equations to apportion terms in terms2 to variables
+ (let ((vars nil) (terms nil) (coefs nil) (boundss nil) (sums nil))
+ (dolist (tc terms-and-counts)
+ (let ((c (tc-count tc)))
+ (when (plusp c)
+ (push (tc-term tc) vars)
+ (push c coefs))))
+ (dolist (tc terms-and-counts)
+ (let ((c (tc-count tc)))
+ (when (minusp c)
+ (setf c (- c))
+ (let* ((term (tc-term tc))
+ (bounds (compute-bounds c coefs vars term subst fn)))
+ (when (and bounds (loop for b in bounds always (eql 0 b)))
+ (return-from subsume-bag2)) ;can't match term
+ (push term terms)
+ (push bounds boundss)
+ (push c sums)))))
+ (subsume-bag3 cc vars terms coefs boundss sums subst fn)))
+
+(defun subsume-bag3 (cc vars terms coefs boundss sums subst fn)
+ ;; solve equations that apportion all occurrences of each term among variables
+ (subsume-bag4
+ cc
+ vars
+ (consn nil nil (length vars))
+ terms
+ (loop for bounds in boundss
+ as sum in sums
+ collect (or (solve-sum-solutions sum coefs bounds)
+ (return-from subsume-bag3)))
+ subst
+ fn))
+
+(defun subsume-bag4 (cc vars vals terms solss subst fn)
+ ;; generate substitutions from equation solutions
+ (cond
+ ((null terms)
+ (let ((identity (function-identity2 fn))
+ (fn-sort (function-sort fn)))
+ (unless (and (eq none identity) (member nil vals))
+ (do ((vars vars (rest vars))
+ (vals vals (rest vals)))
+ ((null vars)
+ (funcall cc subst))
+ (let ((var (first vars))
+ (val (first vals)))
+ (cond
+ ((null val)
+ (if (term-sort-p identity (variable-sort var))
+ (setf subst (bind-variable-to-term var identity subst))
+ (return)))
+ ((null (rest val))
+ ;; already checked sort compatibility in compute-bounds
+ (setf subst (bind-variable-to-term var (first val) subst)))
+ (t
+ ;; it would be more efficient to check sort compatibility earlier
+ (if (subsort? fn-sort (variable-sort var))
+ (setf subst (bind-variable-to-term var (make-compound* fn val) subst))
+ (return)))))))))
+ (t
+ (let ((term (pop terms)))
+ (dolist (sol (pop solss))
+ (subsume-bag4
+ cc
+ vars
+ (mapcar (lambda (val)
+ (let ((k (pop sol)))
+ (if (or (null k) (eql 0 k))
+ val
+ (consn term val k))))
+ vals)
+ terms
+ solss
+ subst
+ fn))))))
+
+(defun maxtc1 (terms-and-counts subst)
+ ;; find term-and-count for nonvariable term with maximum positive count
+ (let ((maxtc1 nil))
+ (dolist (tc terms-and-counts)
+ (let ((c (tc-count tc)))
+ (when (plusp c)
+ (let ((term (tc-term tc)))
+ (cond
+ ((unfrozen-variable-p term)
+ )
+ ((frozen-p term subst)
+ (return-from maxtc1 'quit))
+ ((or (null maxtc1) (> c (tc-count maxtc1)))
+ (setf maxtc1 tc)))))))
+ maxtc1))
+
+(defun compute-bounds (sum coefs vars term subst fn)
+ ;; set bound of zero for variables of too high multiplicity or that occur in term
+ (prog->
+ (mapcar coefs vars ->* coef var)
+ (cond
+ ((or (> coef sum) (variable-occurs-p var term subst))
+ 0)
+ ((function-boolean-valued-p fn)
+ nil)
+ (t
+ (variable-sort var -> sort)
+ (cond
+ ((top-sort? sort)
+ nil)
+ ((not (subsort? (term-sort term subst) sort))
+ 0)
+ ((not (subsort? (function-sort fn) sort))
+ 1)
+ (t
+ nil))))))
+
+;;; subsume-bag.lisp EOF
diff --git a/snark-20120808r02/src/subsume-clause.abcl b/snark-20120808r02/src/subsume-clause.abcl
new file mode 100644
index 0000000..e18c2e5
Binary files /dev/null and b/snark-20120808r02/src/subsume-clause.abcl differ
diff --git a/snark-20120808r02/src/subsume-clause.lisp b/snark-20120808r02/src/subsume-clause.lisp
new file mode 100644
index 0000000..73755cb
--- /dev/null
+++ b/snark-20120808r02/src/subsume-clause.lisp
@@ -0,0 +1,349 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: subsume-clause.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2007.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun clause-subsumes-p (clause1 clause2)
+ ;; does clause1 subsume clause2?
+ (clause-subsumes-p1
+ (atoms-in-clause2 clause1)
+ (atoms-in-clause2 clause2)
+ (variables clause2 nil *frozen-variables*)))
+
+(defun clause-subsumes-p1 (l1 l2 frozen-variables)
+ (prog->
+ (clause-subsumes1 l1 l2 frozen-variables ->* subst)
+ (declare (ignore subst))
+ (return-from prog-> t)))
+
+(defun clause-subsumes1 (cc l1 l2 frozen-variables)
+ ;; returns nil
+ (cond
+ ((null l1) ;clause1 is the empty clause
+ (funcall cc nil)
+ nil)
+ ((null l2) ;clause2 is the empty clause
+ nil)
+ (t
+ (with-clock-on clause-clause-subsumption
+ (clause-subsumes2 cc l1 l2 frozen-variables)))))
+
+(defun clause-subsumes2 (cc l1 l2 frozen-variables)
+ ;; returns nil
+ (cond
+ ((null (rest l1)) ;clause1 is a unit clause
+ (prog->
+ (quote t -> *subsuming*)
+ (identity frozen-variables -> *frozen-variables*)
+ (first l1 -> lit1)
+ (first lit1 -> atom1)
+ (second lit1 -> polarity1)
+ (dolist l2 ->* lit2)
+ (when (eq polarity1 (second lit2))
+ (unify atom1 (first lit2) nil ->* subst)
+ (funcall cc subst))))
+ (t
+ ;; new DPLL-based approach 2004-10
+ (prog->
+ (make-subsumption-test-dp-clause-set l1 l2 frozen-variables -> clause-set subst0)
+ (case clause-set
+ (:unsatisfiable
+ nil)
+ (:empty-set-of-clauses
+ (funcall cc subst0)
+ nil)
+ (otherwise
+ (when (trace-dpll-subsumption?)
+ (format t "~2%Does ~S" (atoms-to-clause2 l1))
+ (format t "~1%subsume ~S" (atoms-to-clause2 l2))
+ (when subst0
+ (format t "~%Matching substitution must include ")
+ (print-substitution subst0))
+ (when (eq :clauses (trace-dpll-subsumption?))
+ (format t "~%Matching substitution must satisfy")
+ (dp-clauses 'print clause-set)))
+ (dp-satisfiable-p
+ clause-set
+ :find-all-models -1
+ :model-test-function (lambda (model)
+ (let ((subst subst0))
+ (dolist (atom model)
+ (when (and (consp atom) (eq 'bind (first atom)))
+ (setf subst (add-binding-to-substitution (second atom) subst))))
+ (when (trace-dpll-subsumption?)
+ (format t "~&Found matching substitution ")
+ (print-substitution subst))
+ (funcall cc subst)
+ t))
+ :more-units-function (and (use-lookahead-in-dpll-for-subsumption?) #'lookahead-true)
+ :pure-literal-check nil
+ :print-warnings (trace-dpll-subsumption?)
+ :print-summary (trace-dpll-subsumption?)
+ :trace nil
+ :trace-choices nil)
+ nil))))))
+
+(defun make-subsumption-test-dp-clause-set (l1 l2 frozen-variables)
+ (prog->
+ (make-subsumption-test-clauses l1 l2 frozen-variables -> clauses subst)
+ (cond
+ ((eq :unsatisfiable clauses)
+ :unsatisfiable)
+ ((null clauses)
+ (values :empty-set-of-clauses subst))
+ (t
+ (values (make-subsumption-test-dp-clause-set1 clauses subst) subst)))))
+
+(defun reorder-atoms2 (l1 l2)
+ ;; reorder l1 to increase likelihood that determinate matches appear first
+ ;; count number of occurrences of polarity-relation pairs in l2
+ ;; (count '=' doubly because it is symmetric and often matches twice)
+ ;; reorder l1 in ascending order of count in l2
+ (let ((counts nil))
+ ;; count polarity-relation pairs in l2
+ (prog->
+ (dolist l2 ->* x)
+ (second x -> polarity)
+ (first x -> atom)
+ (if (compound-p atom) (head atom) atom -> head)
+ (dolist counts (push (list* head polarity (if (eq *=* head) 2 1)) counts) ->* y)
+ (when (and (eq head (first y)) (eq polarity (second y)))
+ (incf (cddr y) (if (eq *=* head) 2 1))
+ (return)))
+ (when (prog-> ;only annotate (and sort) if counts are not uniform
+ (cddr (first counts) -> n)
+ (dolist (rest counts) nil ->* y)
+ (when (not (eql n (cddr y)))
+ (return t)))
+ ;; annotate l1 with counts in l2
+ (let ((l1* (prog->
+ (mapcar l1 ->* x)
+ (second x -> polarity)
+ (first x -> atom)
+ (if (compound-p atom) (head atom) atom -> head)
+ (dolist counts (return-from reorder-atoms2 :unsatisfiable) ->* y)
+ (when (and (eq head (first y)) (eq polarity (second y)))
+ (return (cons (cddr y) x))))))
+ (when (prog-> ;only sort if counts in l1 are not uniform
+ (first (first l1*) -> n)
+ (dolist (rest l1*) nil ->* x)
+ (when (not (eql n (first x)))
+ (return t)))
+ (setf l1* (stable-sort l1* #'< :key #'car))
+ ;; remove annotation
+ (prog->
+ (dotails l1* ->* l)
+ (setf (first l) (cdr (first l))))
+ (setf l1 l1*))))
+ l1))
+
+(defun refine-substs (clauses subst)
+ ;; eliminate matches in clauses that are incompatible with subst
+ ;; return :unsatisfiable if a clause becomes empty after eliminating all its matches
+ ;; trim away bindings that are already in subst
+ (dotails (l clauses)
+ (let* ((shortened nil)
+ (clause (delete-if (lambda (x)
+ (let* ((subst1 (cdr x))
+ (subst1* (substitution-diff2 subst1 subst)))
+ (cond
+ ((eq none subst1*) ;incompatible with subst
+ (setf shortened t)) ;delete it
+ (t
+ (unless (eq subst subst1*)
+ (setf (cdr x) subst1*)) ;subst1 duplicated bindings in subst
+ nil))))
+ (first l))))
+ (when shortened
+ (if (null clause)
+ (return-from refine-substs :unsatisfiable)
+ (setf (first l) clause)))))
+ (values clauses subst))
+
+(defun make-subsumption-test-clauses (l1 l2 *frozen-variables*)
+ ;; reorder l1 to increase likelihood that determinate matches appear first
+ (setf l1 (reorder-atoms2 l1 l2))
+ (when (eq :unsatisfiable l1)
+ (return-from make-subsumption-test-clauses :unsatisfiable))
+ (let ((clauses nil)
+ (subst nil)
+ (*subsuming* t))
+ (prog->
+ (quote nil -> subst1)
+ (quote 0 -> i)
+ (dolist l1 ->* lit1)
+ (incf i)
+ (first lit1 -> atom1)
+ (second lit1 -> polarity1)
+ (quote nil -> clause) ;list of possible matches for atom1 in l2
+ (prog->
+ (quote 0 -> j)
+ (dolist l2 ->* lit2)
+ (incf j)
+ (first lit2 -> atom2)
+ (second lit2 -> polarity2)
+ (when (eq polarity1 polarity2)
+ (quote 0 -> k)
+ (block unify
+ (unify atom1 atom2 subst ->* subst*)
+ (incf k)
+ (cond
+ ((eq subst subst*) ;atom1 matches atom2 with no (further) instantiation
+ (setf clause none) ;no clause or further search for atom1 matches is needed
+ (return-from prog->))
+ (t
+ (setf subst1 subst*) ;save subst* in case this is the only match for atom1
+ (push (cons (list 'match i j k)
+ (substitution-diff subst* subst))
+ clause))) ;clause is list of (match-atom . subst) pairs for later processing
+ (when (and (test-option36?) (<= (test-option36?) k))
+ (return-from unify)))))
+ (cond
+ ((null clause) ;there is no match for atom1, quit
+ (return-from make-subsumption-test-clauses :unsatisfiable))
+ ((neq none clause)
+ (if (null (rest clause)) ;if there is only one match for atom1
+ (setf subst subst1) ;force other matches to extend it
+ (push clause clauses)))))
+ (if (and subst clauses) (refine-substs clauses subst) (values clauses subst))))
+
+(defun make-subsumption-test-dp-clause-set1 (clauses subst)
+ (let ((clause-set (make-dp-clause-set))
+ (empty :empty-set-of-clauses)
+ (dp-binding-atoms nil))
+ (labels
+ ((dp-binding-atom (binding &optional tv)
+ ;; wrapper around dp-atom-named to ensure that there are no two binding atoms
+ ;; for same variable whose values are equal-p
+ ;; dp-binding-atoms is nested alists for mapping var -> val -> binding-atom
+ (let* ((var (binding-var binding))
+ (val (binding-value binding))
+ (v (assoc var dp-binding-atoms :test #'eq))
+ (v1 (if v (rest v) (progn (push (setf v (cons var nil)) dp-binding-atoms) nil))))
+ (let ((v2 (and v1 (assoc-p val v1))))
+ (if (null v2)
+ (let ((atom (or tv (snark-dpll::dp-atom-named (list 'bind binding) clause-set :if-does-not-exist :create))))
+ (setf (rest v) (cons (cons val atom) v1))
+ atom)
+ (cdr v2))))))
+ (dobindings (binding subst)
+ (dp-binding-atom binding true))
+ (prog->
+ (dolist clauses ->* clause)
+ (cl:assert clause) ;no empty clauses
+ (prog->
+ (dotails clause ->* l)
+ (cdr (first l) -> subst)
+ (snark-dpll::dp-atom-named (car (first l)) clause-set :if-does-not-exist :create -> match-atom)
+ (setf (first l) match-atom) ;replace (match-atom . subst) by dp-match-atom in clause
+ (quote nil -> binding-atoms)
+ (dobindings (binding subst)
+ (prog->
+ (dp-binding-atom binding -> atom)
+ (unless (eq true atom)
+ (push atom binding-atoms))))
+ (cond
+ ((null binding-atoms)
+ (setf clause none) ;atom is aleady matched, ignore this clause
+ (return-from prog->))
+ (t
+ ;; add clauses for (iff match (and binding1 ... bindingn))
+ (setf empty nil)
+ (dp-insert (cons match-atom (and binding-atoms (mapcar (lambda (x) (list 'not x)) binding-atoms))) clause-set :print-warnings :safe)
+ (list (list 'not match-atom) -> match-lit-list)
+ (dolist (atom binding-atoms)
+ (dp-insert (cons atom match-lit-list) clause-set :print-warnings :safe)))))
+ ;; add (or (match m) ... (match n)) clause for all the ways one literal can match
+ (unless (eq none clause)
+ (dp-insert clause clause-set :print-warnings :safe)))
+ (when empty
+ (return-from make-subsumption-test-dp-clause-set1 empty))
+ ;; add clauses for unsatisfiability of var=val1, var=val2 bindings
+ (prog->
+ (dolist dp-binding-atoms ->* v) ;v=(var ((val_1 . dp-binding-atom_1)) ... (val_n . dp-binding-atom_n))
+ (dotails (cdr v) ->* v1)
+ (first v1 -> p1) ;p1=(val_i . dp-binding-atom_i)
+ (cdr p1 -> atom_i)
+ (if (eq true atom_i) nil (list (list 'not atom_i)) -> lit_i-list)
+ (dolist (rest v1) ->* p2) ;p2=(val_j . dp-binding-atom_j)
+ (cdr p2 -> atom_j)
+ (cond
+ ((neq true atom_j)
+ (list 'not atom_j -> lit_j)
+ (dp-insert (cons lit_j lit_i-list) clause-set :print-warnings :safe))
+ (lit_i-list
+ (dp-insert lit_i-list clause-set :print-warnings :safe))
+ (t
+ (return-from make-subsumption-test-dp-clause-set1 :unsatisfiable)))) ;never happens (requires subst to be inconsistent)
+ clause-set)))
+
+(defun condenser (clause)
+ ;; new approach 2004-10
+ ;; enumerate matching substitutions of clause (renumbered) to itself
+ ;; there is at least one but we search for one that matches all literals
+ ;; in clause to a subset of its literals
+ ;; remove any literals in the clause that are left over after the match
+ ;;
+ ;; for example, when condensing (or (p ?x) (p a)),
+ ;; (or (p ?x') (p a)) subsumes (or (p ?x) (p a)) with {x' -> a}
+ ;; but (p ?x) does not occur in (or (p ?x') (p a)).{x' -> a}
+ ;; so (p ?x) can be removed to yield (p a) by condensing
+ ;;
+ ;; efficiency issue: how often will there be too many matching substitutions of clause to itself?
+ ;;
+ ;; should be improved by dynamically adding dp-clauses to force models to extend condensing one
+ ;; also could stop early if condensed to unit or ground clause
+ (let ((l2 (atoms-in-clause2 clause))
+ (condensed nil))
+ (cond
+ ((null (rest l2)) ;no condensing of unit clauses
+ clause)
+ (t
+ (let ((vars (variables l2)))
+ (cond
+ ((null vars) ;no condensing of ground clauses
+ clause)
+ (t
+ (prog->
+ (renumber-new l2 -> l1)
+ (clause-subsumes2 l1 l2 vars ->* subst) ;does l2 subsume itself?
+ (identity condensed -> new-condensed)
+ (block mapc
+ (mapc l1 l2 ->* y1 x)
+ (cond
+ ((and ;is x unmatched by l1.subst?
+ (not (equal-p (first x) (first y1) subst)) ;try this likely match first
+ (not (member x l1 :test (lambda (x y) ;then the others
+ (and (and (neq y1 y))
+ (eq (second x) (second y))
+ (equal-p (first x) (first y) subst))))))
+ (unless (and condensed (member x condensed :test #'eq))
+ (push x new-condensed)))
+ ((and condensed (member x condensed :test #'eq))
+ (setf new-condensed nil)
+ (return-from mapc))))
+ (when (and new-condensed (neq condensed new-condensed))
+ (setf condensed new-condensed)
+ (when (trace-dpll-subsumption?)
+ (format t "~%Can remove ~A by condensing" (atoms-to-clause2 condensed)))))
+ (if condensed
+ (atoms-to-clause2 (delete-if (lambda (x) (member x condensed :test #'eq)) l2))
+ clause))))))))
+
+;;; subsume-clause.lisp EOF
diff --git a/snark-20120808r02/src/subsume.abcl b/snark-20120808r02/src/subsume.abcl
new file mode 100644
index 0000000..c7988ff
Binary files /dev/null and b/snark-20120808r02/src/subsume.abcl differ
diff --git a/snark-20120808r02/src/subsume.lisp b/snark-20120808r02/src/subsume.lisp
new file mode 100644
index 0000000..8b44136
--- /dev/null
+++ b/snark-20120808r02/src/subsume.lisp
@@ -0,0 +1,503 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: subsume.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(declaim
+ (special
+ *false-rows*
+ *constraint-rows*))
+
+(defvar *subsuming* nil)
+
+(defun make-and-freeze-variable (&optional sort number)
+ (let ((v (make-variable sort number)))
+ (push v *frozen-variables*)
+ v))
+
+(defun subsume (cc x y &optional subst)
+ (prog->
+ (identity *subsuming* -> sb)
+ (quote t -> *subsuming*)
+ (identity *frozen-variables* -> fv) ;save list of frozen variables
+ (variables y subst fv -> *frozen-variables*) ;add y's variables to frozen variables
+ (unify x y subst ->* subst)
+ (identity sb -> *subsuming*)
+ (identity fv -> *frozen-variables*) ;restore list of frozen variables
+ (funcall cc subst)))
+
+(defun subsumes-p (x y &optional subst)
+ ;; x subsumes y?
+ (subsumes-p1 x y (variables y subst *frozen-variables*) subst))
+
+(defun subsumes-p1 (x y *frozen-variables* &optional subst)
+ (let ((*subsuming* t))
+ (unify-p x y subst)))
+
+(defun subsumed-p (x y &optional subst)
+ ;; x is subsumed by y?
+ (subsumed-p1 x y (variables x subst *frozen-variables*) subst))
+
+(defun subsumed-p1 (x y *frozen-variables* &optional subst)
+ (let ((*subsuming* t))
+ (unify-p y x subst)))
+
+(defun subsumers (x y &optional subst)
+ (subsumers1 x y (variables y subst *frozen-variables*) subst))
+
+(defun subsumers1 (x y *frozen-variables* &optional subst)
+ (let ((*subsuming* t))
+ (unifiers x y subst)))
+
+;;; use-subsumption = nil don't use subsumption
+;;; use-subsumption = :forward use only forward subsumption
+;;; use-subsumption = t use forward and backward subsumption
+;;;
+;;; use-subsumption-by-false further specifies the behavior of use-subsumption in the case of
+;;; "false rows" (those for which row-wff is false, kept in *false-rows* and *constraint-rows*)
+;;;
+;;; use-subsumption-by-false = nil don't use subsumption
+;;; use-subsumption-by-false = :false use only forward subsumption on other false rows
+;;; use-subsumption-by-false = :forward use just forward subsumption generally
+;;; use-subsumption-by-false = t use forward and backward subsumption
+
+(defvar clause-subsumption t)
+
+(defvar subsumption-mark)
+
+(defun forward-subsumed (row)
+ (prog->
+ (forward-subsumption row ->* subsuming-row)
+ (return-from forward-subsumed subsuming-row))
+ nil)
+
+(defun forward-subsumption (cc row)
+ (when (row-hint-p row)
+ (return-from forward-subsumption nil)) ;no forward subsumption of hints
+ (with-clock-on forward-subsumption
+ (prog->
+ (row-context-live? row ->nonnil row-context)
+ (flet ((fsubsume (row2 test)
+ (when (row-hint-p row2)
+ (return-from fsubsume nil)) ;no forward subsumption by hints
+ (prog->
+ (row-context-live? row2 ->nonnil row2-context)
+ (context-subsumes? row2-context row-context ->nonnil new-row-context)
+ (cond
+ ((eq t new-row-context)
+ (when (implies test (wff-subsumption nil row2 row))
+ (funcall cc row2)))
+ (t
+ (when (implies test (wff-subsumption nil row2 row))
+ (setf (row-context row) (setf row-context new-row-context))))))))
+ (prog->
+ (row-wff row -> wff)
+ (when (let ((u (use-subsumption-by-false?))) (if (eq :false u) (eq false wff) u))
+ (prog->
+ (map-rows :rowset *false-rows* :reverse t ->* row2)
+ (fsubsume row2 t))
+ (prog->
+ (map-rows :rowset *constraint-rows* :reverse t ->* row2)
+ (fsubsume row2 t)))
+ (cond
+ ((eq false wff)
+ )
+ ((and clause-subsumption (or (clause-p wff) (setf clause-subsumption nil)))
+ (forward-clause-subsumption row ->* row2)
+ (fsubsume row2 nil))
+ (t
+ (forward-or-backward-wff-subsumption wff :pos :only nil (incf subsumption-mark) nil row ->* row2)
+ (fsubsume row2 nil))))))))
+
+(defun backward-subsumption (cc row)
+ (when (row-hint-p row)
+ (return-from backward-subsumption nil)) ;no backward subsumption by hints
+ (with-clock-on backward-subsumption
+ (prog->
+ (row-context-live? row ->nonnil row-context)
+ (flet ((bsubsume (row2 test)
+ (prog->
+ (row-context-live? row2 ->nonnil row2-context)
+ (context-subsumes? row-context row2-context ->nonnil new-row2-context)
+ (cond
+ ((eq t new-row2-context)
+ (when (implies test (wff-subsumption nil row row2))
+ (cond
+ ((row-hint-p row2)
+ (pushnew row2 *hints-subsumed*)) ;row2 is a hint backward subsumed by row
+ (t
+ (funcall cc row2)))))
+ ((row-hint-p row2)
+ )
+ (t
+ (when (implies test (wff-subsumption nil row row2))
+ (setf (row-context row2) new-row2-context)))))))
+ (prog->
+ (row-wff row -> wff)
+ (cond
+ ((eq false wff)
+ (when (let ((u (use-subsumption-by-false?))) (and u (neq :forward u) (neq :false u)))
+ (map-rows :reverse t ->* row2)
+ (bsubsume row2 t)))
+ ((and clause-subsumption (or (clause-p wff) (setf clause-subsumption nil)))
+ (backward-clause-subsumption row ->* row2)
+ (bsubsume row2 nil))
+ (t
+ (forward-or-backward-wff-subsumption wff :pos :only nil (incf subsumption-mark) t row ->* row2)
+ (bsubsume row2 nil))))))))
+
+(defun forward-clause-subsumption (cc row2)
+ ;; for safey, do funcall cc outside of map-feature-vector-row-index
+ (let ((candidates nil))
+ (prog->
+ (map-feature-vector-row-index-forward-subsumption-candidates row2 ->* row)
+ ;; (format t "~%Feature-vector-row-index possibly forward subsuming row: ~D" (row-number row))
+ (push row candidates))
+ (dolist (row candidates)
+ (when (if (use-dp-subsumption?) (dp-subsume+ row row2) (clause-subsumption row row2))
+ (funcall cc row)))))
+
+(defun backward-clause-subsumption (cc row2)
+ ;; for safey, do funcall cc outside of map-feature-vector-row-index
+ (let ((candidates nil))
+ (prog->
+ (map-feature-vector-row-index-backward-subsumption-candidates row2 ->* row)
+ ;; (format t "~%Feature-vector-row-index possibly backward subsumed row: ~D" (row-number row))
+ (push row candidates))
+ (dolist (row candidates)
+ (when (if (use-dp-subsumption?) (dp-subsume+ row2 row) (clause-subsumption row2 row))
+ (funcall cc row)))))
+
+(defun clause-subsumption (subsuming-row subsumed-row)
+ (when (wff-symbol-counts-not-greaterp (row-wff-symbol-counts subsuming-row) (row-wff-symbol-counts subsumed-row))
+ (catch 'subsumed
+ (prog->
+ (atoms-in-clause2 (row-wff subsuming-row) -> l1)
+ (atoms-in-clause2 (row-wff subsumed-row) -> l2)
+ (row-constraints subsuming-row -> subsuming-constraint-alist)
+ (row-constraints subsumed-row -> subsumed-constraint-alist)
+ (row-answer subsuming-row -> subsuming-answer)
+ (row-answer subsumed-row -> subsumed-answer)
+ (quote t -> *subsuming*)
+ (row-variables subsumed-row *frozen-variables* -> *frozen-variables*)
+ (clause-subsumption1 l1 l2 subsuming-answer subsumed-answer ->* subst)
+ (cond
+ #+ignore
+ ((use-constraint-solver-in-subsumption?)
+ (when (eq false
+ (funcall (constraint-simplification-function?)
+ (conjoin subsuming-constraint (negate subsumed-constraint subst) subst)))
+ (throw 'subsumed t)))
+ (t
+ (dp-subsume-constraint-alists* subsuming-constraint-alist subsumed-constraint-alist subst ->* subst)
+ (declare (ignore subst))
+ (throw 'subsumed t))))
+ nil)))
+
+(defun clause-subsumption1 (cc l1 l2 subsuming-answer subsumed-answer)
+ (prog->
+ (cond
+ ((eq false subsuming-answer)
+ (clause-subsumes1 l1 l2 *frozen-variables* ->* subst)
+ (funcall cc subst))
+ ((eq false subsumed-answer)
+ )
+ ((and #+ignore (test-option37?) #-ignore nil (clause-p subsuming-answer) (clause-p subsumed-answer))
+ (atoms-in-clause2 subsuming-answer -> ans1)
+ (atoms-in-clause2 subsumed-answer -> ans2)
+ (cl:assert (disjoint-answer-relations-p l1 l2 ans1 ans2))
+ (clause-subsumes1 (append ans1 l1) (append ans2 l2) *frozen-variables* ->* subst)
+ (funcall cc subst))
+ (t
+ (clause-subsumes1 l1 l2 *frozen-variables* ->* subst)
+ (subsume-answers subsuming-answer subsumed-answer subst ->* subst)
+ (funcall cc subst)))))
+
+(defun disjoint-answer-relations-p (l1 l2 ans1 ans2)
+ (and (notany (lambda (x)
+ (or (member (head-or-term (car x)) l2 :key (lambda (y) (head-or-term (car y))))
+ (member (head-or-term (car x)) l1 :key (lambda (y) (head-or-term (car y))))))
+ ans1)
+ (notany (lambda (x)
+ (or (member (head-or-term (car x)) l2 :key (lambda (y) (head-or-term (car y))))
+ (member (head-or-term (car x)) l1 :key (lambda (y) (head-or-term (car y))))))
+ ans2)))
+
+(defun forward-or-backward-wff-subsumption (cc subwff polarity phase old-mark new-mark backward-p row)
+ (dereference
+ subwff nil
+ :if-variable (error "Can't use variable wff in subsumption.")
+ :if-constant (cond
+ ((or (eq true subwff) (eq false subwff))
+ (error "Can't use truth values in subsumption."))
+ (t
+ (forward-or-backward-atom-subsumption cc subwff polarity phase old-mark new-mark backward-p row)))
+ :if-compound (let* ((head (head subwff))
+ (kind (function-logical-symbol-p head))
+ (args (args subwff)))
+ (when (and kind (null args))
+ (error "Can't use connectives with no arguments in subsumption."))
+ (ecase kind
+ (not
+ (forward-or-backward-wff-subsumption
+ cc (first args) (opposite-polarity polarity) phase old-mark new-mark backward-p row))
+ ((and or)
+ (cond
+ ((if backward-p (eq 'or kind) (eq 'and kind))
+ (do ((args args (rest args))
+ (first t nil)
+ (m old-mark)
+ n)
+ ((null (rest args))
+ (forward-or-backward-wff-subsumption
+ cc (first args) polarity
+ (ecase phase
+ (:only (if first :only :last))
+ (:first (if first :first :middle))
+ (:middle :middle)
+ (:last :last))
+ m new-mark
+ backward-p row))
+ (setf n (incf subsumption-mark))
+ (forward-or-backward-wff-subsumption
+ cc (first args) polarity
+ (ecase phase
+ (:only (if first :first :middle))
+ (:first (if first :first :middle))
+ (:middle :middle)
+ (:last :middle))
+ m n
+ backward-p row)
+ (setf m n)))
+ (t
+ (do ((args args (rest args)))
+ ((null args))
+ (forward-or-backward-wff-subsumption
+ cc
+ (first args) polarity phase old-mark new-mark
+ backward-p row)))))
+ (implies
+ (forward-or-backward-wff-subsumption
+ cc
+ (make-compound *or*
+ (make-compound *not* (first args))
+ (second args))
+ polarity phase old-mark new-mark
+ backward-p row))
+ (implied-by
+ (forward-or-backward-wff-subsumption
+ cc
+ (make-compound *or*
+ (make-compound *not* (second args))
+ (first args))
+ polarity phase old-mark new-mark
+ backward-p row))
+ ((iff xor) ;should be more efficient
+ (cond
+ ((null (rest args))
+ (forward-or-backward-wff-subsumption
+ cc (first args) polarity phase old-mark new-mark backward-p row))
+ (t
+ (let ((x (first args))
+ (y (if (null (cddr args)) (second args) (make-compound head (rest args)))))
+ (forward-or-backward-wff-subsumption
+ cc
+ (if (eq 'iff kind)
+ (make-compound *or*
+ (make-compound *and*
+ x
+ y)
+ (make-compound *and*
+ (make-compound *not* x)
+ (make-compound *not* y)))
+ (make-compound *or*
+ (make-compound *and*
+ x
+ (make-compound *not* y))
+ (make-compound *and*
+ (make-compound *not* x)
+ y)))
+ polarity phase old-mark new-mark
+ backward-p row)))))
+ (if ;should be more efficient
+ (forward-or-backward-wff-subsumption
+ cc
+ (make-compound *and*
+ (make-compound *or*
+ (make-compound *not* (first args))
+ (second args))
+ (make-compound *and*
+ (first args)
+ (third args)))
+ polarity phase old-mark new-mark
+ backward-p row))
+ ((nil)
+ (forward-or-backward-atom-subsumption
+ cc subwff polarity phase old-mark new-mark backward-p row))))))
+
+(defun forward-or-backward-atom-subsumption (cc atom polarity phase old-mark new-mark backward-p row)
+ (funcall (if backward-p #'retrieve-instance-entries #'retrieve-generalization-entries)
+ (lambda (e row2s)
+ (declare (ignore e))
+ (prog->
+ (map-rows :rowset row2s ->* row2)
+ (ecase phase
+ (:only
+ (when (if backward-p
+ (if (use-dp-subsumption?)
+ (dp-subsume+ row row2)
+ (wff-subsumption nil row row2))
+ (if (use-dp-subsumption?)
+ (dp-subsume+ row2 row)
+ (wff-subsumption nil row2 row)))
+ (funcall cc row2)))
+ (:first
+ (setf (row-subsumption-mark row2) new-mark))
+ (:middle
+ (when (eql (row-subsumption-mark row2) old-mark)
+ (setf (row-subsumption-mark row2) new-mark)))
+ (:last
+ (when (eql (row-subsumption-mark row2) old-mark)
+ (when (if backward-p
+ (if (use-dp-subsumption?)
+ (dp-subsume+ row row2)
+ (wff-subsumption nil row row2))
+ (if (use-dp-subsumption?)
+ (dp-subsume+ row2 row)
+ (wff-subsumption nil row2 row)))
+ (funcall cc row2)))))))
+ atom
+ nil
+ (if (eq polarity :pos)
+ #'tme-rows-containing-atom-positively
+ #'tme-rows-containing-atom-negatively)))
+
+(defun wff-subsumption (matches subsuming-row subsumed-row)
+ (declare (ignore matches))
+ (catch 'subsumed
+ (prog->
+ (row-wff subsuming-row -> subsuming-wff)
+ (row-wff subsumed-row -> subsumed-wff)
+ (row-constraints subsuming-row -> subsuming-constraint-alist)
+ (row-constraints subsumed-row -> subsumed-constraint-alist)
+ (row-answer subsuming-row -> subsuming-answer)
+ (row-answer subsumed-row -> subsumed-answer)
+
+ (quote t -> *subsuming*)
+ (row-variables subsumed-row *frozen-variables* -> *frozen-variables*)
+
+ (quote nil -> subst)
+ (wff-subsumption* subsuming-wff subsumed-wff subst ->* subst)
+ (subsume-answers subsuming-answer subsumed-answer subst ->* subst)
+ (cond
+ #+ignore
+ ((use-constraint-solver-in-subsumption?)
+ (when (eq false
+ (funcall (constraint-simplification-function?)
+ (conjoin subsuming-constraint (negate subsumed-constraint subst) subst)))
+ (throw 'subsumed t)))
+ (t
+ (dp-subsume-constraint-alists* subsuming-constraint-alist subsumed-constraint-alist subst ->* subst)
+;; (wff-subsumption* subsuming-wff subsumed-wff subst ->* subst)
+ (declare (ignore subst))
+ (throw 'subsumed t))))))
+
+(defun wff-subsumption* (cc subsuming-wff subsumed-wff subst)
+ ;; assume variables of subsumed-wff are already frozen so that
+ ;; unification really does subsumption
+ (let (interpretations)
+ ;; find every interpretation in which subsuming-wff is true and subsumed-wff is false
+ #|
+ (salsify t subsuming-wff nil
+ (lambda (interp1)
+ (salsify nil subsumed-wff interp1
+ (lambda (interp2)
+ (push (cons interp1 (ldiff interp2 interp1)) interpretations)))))
+ |#
+ (let (u v)
+ (salsify t subsuming-wff nil (lambda (interp1) (push interp1 u)))
+ (salsify nil subsumed-wff nil (lambda (interp2) (push interp2 v)))
+ (dolist (interp1 u)
+ (dolist (interp2 v)
+ (push (cons interp1 interp2) interpretations))))
+ (let (w)
+ (dolist (interp interpretations)
+ (let ((n (nmatches interp subst)))
+ (when (eql 0 n)
+ (return-from wff-subsumption* nil))
+ (push (cons n interp) w)))
+ (setf w (sort w #'< :key #'car))
+ (setf interpretations nil)
+ (dolist (x w)
+ (push (cdr x) interpretations)))
+ (wff-subsumption*1 cc interpretations subst)))
+
+(defun wff-subsumption*1 (cc interpretations subst)
+ (cond
+ ((null interpretations)
+ (funcall cc subst))
+ (t
+ (dolist (x (car (first interpretations)))
+ (dolist (y (cdr (first interpretations)))
+ (unless (eq (cdr x) (cdr y))
+ (when (equal-p (car x) (car y) subst)
+ (wff-subsumption*1 cc (rest interpretations) subst)
+ (return-from wff-subsumption*1 nil)))))
+ (dolist (x (car (first interpretations)))
+ (dolist (y (cdr (first interpretations)))
+ (unless (eq (cdr x) (cdr y))
+ (prog->
+ (unify (car x) (car y) subst ->* subst)
+ (wff-subsumption*1 cc (rest interpretations) subst))))))))
+
+(defun nmatches (interpretation subst)
+ (let ((n 0))
+ (dolist (x (car interpretation))
+ (dolist (y (cdr interpretation))
+ (unless (eq (cdr x) (cdr y))
+ (when (unify-p (car x) (car y) subst)
+ (incf n)))))
+ n))
+
+(defun subsume-answers (cc subsuming-answer subsumed-answer subst)
+ (cond
+ ((eq false subsuming-answer)
+ (funcall cc subst))
+ ((eq false subsumed-answer)
+ )
+ ((and (literal-p subsuming-answer) (literal-p subsumed-answer))
+ (unify cc subsuming-answer subsumed-answer subst))
+ ((and (clause-p subsuming-answer) (clause-p subsumed-answer))
+ (prog->
+ (instantiate subsuming-answer subst -> subsuming-answer)
+ (atoms-in-clause2 subsuming-answer -> l1)
+ (atoms-in-clause2 subsumed-answer -> l2)
+ (clause-subsumes1 cc l1 l2 *frozen-variables*)))
+ (t
+ (wff-subsumption* cc subsuming-answer subsumed-answer subst))))
+
+;;; wff-subsumption* allows wffs to subsume their own factors
+
+;;; when subsuming one atom in an interpretation by
+;;; another, make sure one is from the subsuming wff
+;;; and the other is from the subsumed wff???
+;;; split these lists to do M*N comparisons
+;;; instead of (M+N)*(M+N)
+
+;;; subsume.lisp EOF
diff --git a/snark-20120808r02/src/symbol-definitions.abcl b/snark-20120808r02/src/symbol-definitions.abcl
new file mode 100644
index 0000000..97cfb7b
Binary files /dev/null and b/snark-20120808r02/src/symbol-definitions.abcl differ
diff --git a/snark-20120808r02/src/symbol-definitions.lisp b/snark-20120808r02/src/symbol-definitions.lisp
new file mode 100644
index 0000000..27ee0e4
--- /dev/null
+++ b/snark-20120808r02/src/symbol-definitions.lisp
@@ -0,0 +1,184 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: symbol-definitions.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(declaim (special *skolem-function-alist*))
+
+(defvar *all-both-polarity*)
+
+(eval-when (:load-toplevel :execute)
+ (setf *all-both-polarity* (cons (constantly :both) nil))
+ (rplacd *all-both-polarity* *all-both-polarity*)
+ nil)
+
+(defun initialize-symbol-table ()
+ (setf *skolem-function-alist* nil)
+ (make-symbol-table))
+
+(defun initialize-symbol-table2 ()
+ (declare-proposition 'true :locked t)
+ (declare-proposition 'false :locked t)
+ ;; SNARK code assumes that propositions and constants with the same name have different
+ ;; internal representations so that different properties can be specified for them
+ ;; this includes the case for true and false, which are treated specially
+ (cl:assert (neq true 'true))
+ (cl:assert (neq false 'false))
+ (setf *not*
+ (declare-logical-symbol
+ 'not
+ :make-compound*-function #'negate*
+ :input-code #'input-negation
+ :polarity-map (list #'opposite-polarity)
+ :rewrite-code '(not-wff-rewriter)))
+ (setf *and*
+ (declare-logical-symbol
+ 'and
+ :make-compound*-function #'conjoin*
+ :input-code #'input-conjunction
+ :associative (use-ac-connectives?)
+ :commutative (use-ac-connectives?)
+ :rewrite-code (if (use-ac-connectives?) '(and-wff-rewriter) nil)))
+ (setf *or*
+ (declare-logical-symbol
+ 'or
+ :make-compound*-function #'disjoin*
+ :input-code #'input-disjunction
+ :associative (use-ac-connectives?)
+ :commutative (use-ac-connectives?)
+ :rewrite-code (if (use-ac-connectives?) '(or-wff-rewriter) nil)))
+ (setf *implies*
+ (declare-logical-symbol
+ 'implies
+ :make-compound*-function #'make-implication*
+ :input-code #'input-implication
+ :polarity-map (list #'opposite-polarity)
+ :rewrite-code '(implies-wff-rewriter)))
+ (setf *implied-by*
+ (declare-logical-symbol
+ 'implied-by
+ :make-compound*-function #'make-reverse-implication*
+ :input-code #'input-reverse-implication
+ :polarity-map (list #'identity #'opposite-polarity)
+ :rewrite-code '(implied-by-wff-rewriter)))
+ (setf *iff*
+ (declare-logical-symbol
+ 'iff
+ :make-compound*-function #'make-equivalence*
+ :input-code #'input-equivalence
+ :polarity-map *all-both-polarity*
+ :associative (use-ac-connectives?)
+ :commutative (use-ac-connectives?)
+ :alias '<=>))
+ (setf *xor*
+ (declare-logical-symbol
+ 'xor
+ :make-compound*-function #'make-exclusive-or*
+ :input-code #'input-exclusive-or
+ :polarity-map *all-both-polarity*
+ :associative (use-ac-connectives?)
+ :commutative (use-ac-connectives?)))
+ (setf *if*
+ (declare-logical-symbol
+ 'if
+ :make-compound*-function #'make-conditional*
+ :input-code #'input-conditional
+ :polarity-map (list (constantly :both))))
+ (setf *answer-if*
+ (declare-logical-symbol
+ 'answer-if
+ :make-compound*-function #'make-conditional-answer*
+ :input-code #'input-conditional-answer
+ :polarity-map (list (constantly :both))))
+ (setf *forall* (declare-logical-symbol 'forall :input-code #'input-quantification :to-lisp-code #'quant-compound-to-lisp))
+ (setf *exists* (declare-logical-symbol 'exists :input-code #'input-quantification :to-lisp-code #'quant-compound-to-lisp))
+ (setf *=* (declare-relation1 '= 2 :input-code #'input-equality :rewrite-code '(equality-rewriter arithmetic-relation-rewriter) :satisfy-code '(reflexivity-satisfier) :commutative t))
+ (declare-logical-symbol '=> :macro t :input-code #'input-kif-forward-implication)
+ (declare-logical-symbol '<= :macro t :input-code #'input-kif-backward-implication)
+ (declare-logical-symbol 'nand :macro t :input-code #'input-nand)
+ (declare-logical-symbol 'nor :macro t :input-code #'input-nor)
+ (declare-relation1 '/= 2 :macro t :input-code #'input-disequality)
+ (setf (function-boolean-valued-p *=*) '=)
+ (setf (function-logical-symbol-dual *and*) *or*)
+ (setf (function-logical-symbol-dual *or*) *and*)
+ (setf (function-logical-symbol-dual *forall*) *exists*)
+ (setf (function-logical-symbol-dual *exists*) *forall*)
+
+ (setf *a-function-with-left-to-right-ordering-status* (declare-function '$$_internal1 :any :ordering-status :left-to-right))
+ (setf *a-function-with-multiset-ordering-status* (declare-function '$$_internal2 :any :ordering-status :multiset))
+
+ (declare-function1 '$$quote :any :macro t :input-code #'input-quoted-constant)
+ #+ignore
+ (declare-relation2 '$$eqe 2 :rewrite-code 'equality-rewriter :satisfy-code 'constructor-reflexivity-satisfier :alias '$$eq_equality :constraint-theory 'equality)
+ (declare-code-for-lists)
+ (declare-code-for-bags)
+ (declare-code-for-strings)
+ (declare-code-for-numbers)
+ (declare-code-for-dates)
+ (declare-constant '$$empty-flat-bag :locked t :constructor t)
+ (declare-function1 '$$flat-bag 2 :associative t :commutative t :identity '$$empty-flat-bag)
+ (declare-constant '$$empty-flat-list :locked t :constructor t)
+ (declare-function1 '$$flat-list 2 :associative t :identity '$$empty-flat-list)
+
+ #+ignore
+ (declare-relation2 'nonvariable 1 :rewrite-code 'nonvariable-rewriter :satisfy-code 'nonvariable-satisfier)
+ #+ignore
+ (declare-function 'the 2 :rewrite-code 'the-term-rewriter)
+ nil)
+
+(defun initialize-sort-theory2 ()
+ (declare-subsort 'top-sort-a t :subsorts-incompatible t :alias :top-sort-a)
+ (declare-subsort 'string 'top-sort-a)
+ (declare-subsort 'list 'top-sort-a)
+ (declare-subsort 'number 'top-sort-a :alias 'complex)
+ (declare-subsort 'time-interval 'top-sort-a)
+ (declare-subsort 'time-point 'top-sort-a)
+
+ (declare-subsort 'real 'complex)
+ (declare-subsort 'rational 'real)
+ (declare-subsort 'integer 'rational)
+
+ (declare-subsort 'nonnegative 'real :alias '(nonnegative-real nonnegative-number))
+ (declare-subsort 'nonpositive 'real)
+ (declare-subsort 'nonzero 'number :alias 'nonzero-number)
+ (declare-sorts-incompatible 'nonnegative 'nonpositive 'nonzero)
+
+ (declare-sort 'positive :iff '(and nonnegative nonzero) :alias '(positive-real positive-number))
+ (declare-sort 'negative :iff '(and nonpositive nonzero) :alias '(negative-real negative-number))
+ (declare-sort 'zero :iff '(and nonnegative nonpositive integer))
+
+ ;; includes sort names used by declare-number
+ (dolist (sign '(positive negative nonnegative nonzero))
+ (dolist (type '(real rational integer))
+ (when (implies (eq 'real type) (eq 'nonzero sign))
+ (declare-sort (intern (to-string sign "-" type) :snark)
+ :iff `(and ,sign ,type)
+ :alias (and (eq 'nonnegative sign) (eq 'integer type) 'natural)))))
+ nil)
+
+(defun number-sort-name (x)
+ (etypecase x
+ (integer
+ (if (< 0 x) 'positive-integer (if (> 0 x) 'negative-integer 'zero)))
+ (ratio
+ (if (< 0 x) 'positive-rational 'negative-rational))
+ (complex
+ 'nonzero)))
+
+;;; symbol-definitions.lisp EOF
diff --git a/snark-20120808r02/src/symbol-ordering.abcl b/snark-20120808r02/src/symbol-ordering.abcl
new file mode 100644
index 0000000..60d6859
Binary files /dev/null and b/snark-20120808r02/src/symbol-ordering.abcl differ
diff --git a/snark-20120808r02/src/symbol-ordering.lisp b/snark-20120808r02/src/symbol-ordering.lisp
new file mode 100644
index 0000000..ea609bc
--- /dev/null
+++ b/snark-20120808r02/src/symbol-ordering.lisp
@@ -0,0 +1,251 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: symbol-ordering.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(declaim
+ (special
+ *symbols-in-symbol-table*
+ ))
+
+;;; use-default-ordering = nil no default ordering
+;;; use-default-ordering = t high arity > low arity, same arity alphabetically later > earlier
+;;; use-default-ordering = :reverse high arity > low arity, same arity alphabetically earlier > later
+;;; use-default-ordering = :arity high arity > low arity
+
+(defvar ordering-is-total nil) ;can be set if all symbols have been totally ordered by ordering declarations
+
+(defvar *symbol-ordering*)
+
+(defun initialize-symbol-ordering ()
+ (setf *symbol-ordering* (make-poset)))
+
+(defun default-symbol-ordering-compare (symbol1 symbol2)
+ (cond
+ ((and (test-option23?)
+ (if (function-symbol-p symbol1) (function-skolem-p symbol1) (constant-skolem-p symbol1))
+ (not (if (function-symbol-p symbol2) (function-skolem-p symbol2) (constant-skolem-p symbol2)))
+ (not (and (ordering-functions>constants?) (not (function-symbol-p symbol1)) (function-symbol-p symbol2))))
+ '>)
+ ((and (test-option23?)
+ (not (if (function-symbol-p symbol1) (function-skolem-p symbol1) (constant-skolem-p symbol1)))
+ (if (function-symbol-p symbol2) (function-skolem-p symbol2) (constant-skolem-p symbol2))
+ (not (and (ordering-functions>constants?) (function-symbol-p symbol1) (not (function-symbol-p symbol2)))))
+ '<)
+ ((function-symbol-p symbol1)
+ (cond
+ ((not (function-symbol-p symbol2))
+ '>)
+ ((and (equality-relation-symbol-p symbol1) (not (equality-relation-symbol-p symbol2)))
+ '<)
+ ((and (equality-relation-symbol-p symbol2) (not (equality-relation-symbol-p symbol1)))
+ '>)
+ ((and (function-skolem-p symbol1) (not (function-skolem-p symbol2)))
+ '>)
+ ((and (function-skolem-p symbol2) (not (function-skolem-p symbol1)))
+ '<)
+ ((and (function-constructor symbol1) (not (function-constructor symbol2)))
+ '<)
+ ((and (function-constructor symbol2) (not (function-constructor symbol1)))
+ '>)
+ ((and (eq 'arithmetic (function-constraint-theory symbol1)) (not (eq 'arithmetic (function-constraint-theory symbol2))))
+ '<)
+ ((and (eq 'arithmetic (function-constraint-theory symbol2)) (not (eq 'arithmetic (function-constraint-theory symbol1))))
+ '>)
+ (t
+ (let ((arity1 (if (function-associative symbol1) 2 (function-arity symbol1)))
+ (arity2 (if (function-associative symbol2) 2 (function-arity symbol2))))
+ (cond
+ ((eql arity1 arity2)
+ (cond
+ ((eq :arity (use-default-ordering?))
+ '?)
+ (t
+ (default-symbol-ordering-compare1 (function-name symbol1) (function-name symbol2)))))
+ ((or (not (numberp arity1))
+ (not (numberp arity2)))
+ '?)
+ ((and (1-ary-functions>2-ary-functions-in-default-ordering?) (= 1 arity1) (= 2 arity2) (not (function-boolean-valued-p symbol1)) (not (function-boolean-valued-p symbol2)))
+ '>)
+ ((and (1-ary-functions>2-ary-functions-in-default-ordering?) (= 2 arity1) (= 1 arity2) (not (function-boolean-valued-p symbol1)) (not (function-boolean-valued-p symbol2)))
+ '<)
+ (t
+ (if (> arity1 arity2) '> '<)))))))
+ ((function-symbol-p symbol2)
+ '<)
+ ((symbolp symbol1) ;symbols > strings > numbers
+ (if (symbolp symbol2)
+ (cond
+ ((and (constant-skolem-p symbol1) (not (constant-skolem-p symbol2)))
+ '>)
+ ((and (constant-skolem-p symbol2) (not (constant-skolem-p symbol1)))
+ '<)
+ ((and (constant-constructor symbol1) (not (constant-constructor symbol2)))
+ '<)
+ ((and (constant-constructor symbol2) (not (constant-constructor symbol1)))
+ '>)
+ ((eq :arity (use-default-ordering?))
+ '?)
+ (t
+ (default-symbol-ordering-compare1 symbol1 symbol2)))
+ '>))
+ ((symbolp symbol2)
+ '<)
+ ((stringp symbol1)
+ (if (stringp symbol2) (if (string> symbol1 symbol2) '> '<) '>))
+ ((stringp symbol2)
+ '<)
+ (t
+ (if (greater? symbol1 symbol2) '> '<))))
+
+(defun default-symbol-ordering-compare1 (symbol1 symbol2)
+ (if (if (eq :reverse (use-default-ordering?))
+ (string< (symbol-name symbol1) (symbol-name symbol2))
+ (string> (symbol-name symbol1) (symbol-name symbol2)))
+ '>
+ '<))
+
+(defun declare-ordering-greaterp2 (x y)
+ (cond
+ ((or (not (iff (symbol-boolean-valued-p x) (symbol-boolean-valued-p y)))
+ (and (ordering-functions>constants?) (not (function-symbol-p x)) (function-symbol-p y)))
+ (warn "Ignoring ordering declaration ~A > ~A." x y))
+ ((not (and (ordering-functions>constants?) (function-symbol-p x) (not (function-symbol-p y))))
+ (declare-poset-greaterp *symbol-ordering* (symbol-number x) (symbol-number y)))))
+
+(definline symbol-ordering-compare (symbol1 symbol2)
+ (cond
+ ((eql symbol1 symbol2)
+ '=)
+ (t
+ (symbol-ordering-compare1 symbol1 symbol2))))
+
+(defun symbol-ordering-compare1 (symbol1 symbol2)
+ (let ((n1 (symbol-number symbol1))
+ (n2 (symbol-number symbol2)))
+ (cond
+ ((poset-greaterp *symbol-ordering* n1 n2)
+ '>)
+ ((poset-greaterp *symbol-ordering* n2 n1)
+ '<)
+ (t
+ (let ((ordering-fun (use-default-ordering?)))
+ (cond
+ (ordering-fun
+ (cl:assert (iff (symbol-boolean-valued-p symbol1) (symbol-boolean-valued-p symbol2)))
+ (let ((com (funcall (if (or (eq t ordering-fun)
+ (eq :arity ordering-fun)
+ (eq :reverse ordering-fun))
+ #'default-symbol-ordering-compare
+ ordering-fun)
+ symbol1
+ symbol2)))
+ (ecase com
+ (>
+ (declare-ordering-greaterp2 symbol1 symbol2))
+ (<
+ (declare-ordering-greaterp2 symbol2 symbol1))
+ (?
+ ))
+ com))
+ (t
+ '?)))))))
+
+(defun opposite-order (x)
+ (case x
+ (>
+ '<)
+ (<
+ '>)
+ (otherwise
+ x)))
+
+(defun print-symbol-ordering (&optional (symbol-or-symbols none))
+ (let ((symbols (cond
+ ((eq none symbol-or-symbols)
+ none)
+ ((consp symbol-or-symbols)
+ symbol-or-symbols)
+ (t
+ (list symbol-or-symbols))))
+ (l nil))
+ (prog->
+ (map-sparse-vector-with-indexes (sparse-matrix-rows *symbol-ordering*) ->* row x#)
+ (symbol-numbered x# -> x)
+ (map-sparse-vector row ->* y#)
+ (symbol-numbered y# -> y)
+ (when (implies (neq none symbols)
+ (member (symbol-to-name x) symbols))
+ (or (assoc x l) (first (push (list x nil nil) l)) -> v)
+ (push y (third v)))
+ (when (implies (neq none symbols)
+ (member (symbol-to-name y) symbols))
+ (or (assoc y l) (first (push (list y nil nil) l)) -> v)
+ (push x (second v))))
+ (mapc (lambda (v)
+ (setf (first v) (symbol-to-name (first v)))
+ (when (second v)
+ (setf (second v) (sort (mapcar 'symbol-to-name (second v)) 'constant-name-lessp)))
+ (when (third v)
+ (setf (third v) (sort (mapcar 'symbol-to-name (third v)) 'constant-name-lessp))))
+ l)
+ (setf l (sort l 'constant-name-lessp :key #'first))
+ (terpri-comment)
+ (prin1 `(ordering-functions>constants? ,(ordering-functions>constants?)))
+ (dolist (v l)
+ (terpri-comment)
+ (prin1 (cons 'declare-ordering-greaterp
+ (append (and (second v) (list (kwote (second v))))
+ (list (kwote (first v)))
+ (and (third v) (list (kwote (third v))))))))))
+
+(defun declare-ordering-greaterp (x y &rest others)
+ ;; user function for declaring that x > y in ordering precedence relation
+ ;; x and y can be a symbol or lists of symbols
+ ;; if x and y are lists of symbols, then every symbol in x is declared greater than every symbol in y
+ (dotails (l (mapcar (lambda (x)
+ (if (consp x) (mapcar #'input-symbol x) (list (input-symbol x))))
+ (list* x y others)))
+ (unless (null (rest l))
+ (dolist (x (first l))
+ (dolist (y (second l))
+ (declare-ordering-greaterp2 x y))))))
+
+(defun rpo-add-created-function-symbol (fn)
+ (prog->
+ (map-symbol-table ->* name kind symbol)
+ (declare (ignore name))
+ (cond
+ ((or (eq :variable kind) (eq :sort kind))
+ )
+ ((eq symbol fn)
+ )
+ ((symbol-boolean-valued-p symbol)
+ )
+ ((if (function-symbol-p fn)
+ (and (function-symbol-p symbol)
+ (function-created-p symbol)
+ (> (function-arity fn) (function-arity symbol)))
+ (and (not (function-symbol-p symbol))
+ (constant-created-p symbol)))
+ (declare-ordering-greaterp2 fn symbol))
+ (t
+ (declare-ordering-greaterp2 symbol fn)))))
+
+;;; symbol-ordering.lisp EOF
diff --git a/snark-20120808r02/src/symbol-table2.abcl b/snark-20120808r02/src/symbol-table2.abcl
new file mode 100644
index 0000000..6a31f20
Binary files /dev/null and b/snark-20120808r02/src/symbol-table2.abcl differ
diff --git a/snark-20120808r02/src/symbol-table2.lisp b/snark-20120808r02/src/symbol-table2.lisp
new file mode 100644
index 0000000..0b7b7bb
--- /dev/null
+++ b/snark-20120808r02/src/symbol-table2.lisp
@@ -0,0 +1,397 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: symbol-table2.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defvar *symbol-table*)
+
+(declaim (special *input-wff*))
+
+;;; identical names in different packages yield different symbols
+;;; logical symbols, equality relation, etc., are in SNARK package
+;;;
+;;; builtin constants (numbers and strings) are not stored in the symbol table
+
+(defun make-symbol-table ()
+ (setf *symbol-table* (make-hash-table))
+ nil)
+
+(defmacro symbol-table-entries (name)
+ `(gethash ,name *symbol-table*))
+
+(defun create-symbol-table-entry (name symbol)
+ (pushnew symbol (symbol-table-entries name))
+ symbol)
+
+(defun find-symbol-table-entry (name kind &optional arity)
+;;(cl:assert (implies (eq :logical-symbol kind) (eq :any arity)))
+ (dolist (symbol (symbol-table-entries name) none)
+ (when (symbol-table-kind-match symbol kind arity)
+ (return symbol))))
+
+(defun find-or-create-symbol-table-entry (name kind &optional arity (sym none))
+;;(cl:assert (implies (eq :logical-symbol kind) (eq :any arity)))
+ (let ((symbol (find-symbol-table-entry name kind arity)))
+ (cond
+ ((neq none symbol)
+ (when (and (neq none sym) (neql sym symbol))
+ (with-standard-io-syntax2
+ (error "~S cannot be used as ~A name or alias of ~S; it is a ~A name or alias of ~S." name kind sym kind symbol)))
+ symbol)
+ (t
+ (cond
+ ((neq none sym)
+ (setf symbol sym))
+ (t
+ (ecase kind
+ (:variable
+ (setf symbol (make-variable none))) ;declare-variable replaces none by proper sort
+ (:constant
+ (setf symbol name)
+ (constant-info symbol nil))
+ (:proposition
+ (setf symbol
+ (cond
+ ((eq 'true name) ;use value of lisp defconstants true and false to represent truth values
+ true)
+ ((eq 'false name)
+ false)
+ (t
+ (make-symbol (symbol-name name)))))
+ (constant-info symbol nil)
+ (setf (constant-boolean-valued-p0 symbol) name))
+ (:function
+ (setf symbol (make-function-symbol name arity)))
+ (:relation
+ (setf symbol (make-function-symbol name arity))
+ (setf (function-boolean-valued-p symbol) t))
+ (:logical-symbol
+ (setf symbol (make-function-symbol name :any))
+ (setf (function-boolean-valued-p symbol) t)
+ (setf (function-logical-symbol-p symbol) name)))))
+ (prog->
+ (dolist (symbol-table-entries name) ->* symbol2)
+ (symbol-kind symbol2 -> kind2 arity2)
+ (cond
+ ((or (and (eq kind kind2)
+ (naturalp arity2) ;function or relation already declared with fixed arity
+ (not (naturalp arity)) ;now with special (e.g., :any) arity
+ (ecase arity (:any t)))
+ (and (eq :relation kind) (eq :logical-symbol kind2))
+ (and (eq :logical-symbol kind) (eq :relation kind2)))
+ (with-standard-io-syntax2
+ (error "~S cannot be used as a ~@[~A-ary ~]~A; it is a ~@[~A-ary ~]~A."
+ name (if (eq :logical-symbol kind) nil arity) kind (if (eq :logical-symbol kind2) nil arity2) kind2)))
+ ((and (print-symbol-table-warnings?)
+ (or (eq :all (print-symbol-table-warnings?))
+ (and (or (eq :function kind) (eq :relation kind) (eq :logical-symbol kind))
+ (or (eq :function kind2) (eq :relation kind2) (eq :logical-symbol kind2)))
+ (and (eq :constant kind) (eq :variable kind2))
+ (and (eq :variable kind) (eq :constant kind2))))
+ (with-standard-io-syntax2
+ (warn "~S is being used as a ~@[~A-ary ~]~A~@[ in ~S~]; it is also a ~@[~A-ary ~]~A."
+ name (if (eq :logical-symbol kind) nil arity) kind *input-wff* (if (eq :logical-symbol kind2) nil arity2) kind2)))))
+ (create-symbol-table-entry name symbol)
+ (values symbol t)))))
+
+(defun create-aliases-for-symbol (symbol aliases)
+ (mvlet (((values kind arity) (symbol-kind symbol)))
+ (dolist (alias (mklist aliases))
+ (ecase kind
+ (:function (can-be-function-name alias 'error))
+ (:relation (can-be-relation-name alias 'error))
+ (:constant (can-be-constant-alias alias 'error))
+ (:proposition (can-be-proposition-name alias 'error))
+ (:logical-symbol (can-be-logical-symbol-name alias 'error))
+ (:sort (can-be-sort-name alias 'error)))
+ (find-or-create-symbol-table-entry alias kind arity symbol))))
+
+(defun rename-function-symbol (symbol new-name)
+ (create-aliases-for-symbol symbol new-name)
+ (setf (function-name symbol) new-name)
+ (setf (function-code-name0 symbol) nil))
+
+(defun symbol-kind (x)
+ (cond
+ ((function-symbol-p x)
+ (values (function-kind x) (function-arity x)))
+ ((variable-p x)
+ :variable)
+ ((sort? x)
+ :sort)
+ ((constant-boolean-valued-p x)
+ :proposition)
+ (t
+ :constant)))
+
+(defun symbol-table-kind-match (symbol2 kind arity)
+ ;; can existing symbol2 be used as a kind/arity symbol
+ (mvlet (((values kind2 arity2) (symbol-kind symbol2)))
+ (and (eq kind kind2)
+ (or (eql arity arity2)
+ (case arity2
+ (:any
+ (or (eq :any arity) (naturalp arity)))
+ (2
+ (and (function-associative symbol2) (or (eq :any arity) (naturalp arity))))
+ (otherwise
+ nil))))))
+
+(defun symbol-table-constant? (name)
+ (remove-if-not #'(lambda (x) (eq :constant (symbol-kind x))) (symbol-table-entries name)))
+
+(defun symbol-table-function? (name)
+ (remove-if-not #'(lambda (x) (eq :function (symbol-kind x))) (symbol-table-entries name)))
+
+(defun symbol-table-relation? (name)
+ (remove-if-not #'(lambda (x) (eq :relation (symbol-kind x))) (symbol-table-entries name)))
+
+(defun map-symbol-table (cc &key logical-symbols variables)
+ (prog->
+ (maphash *symbol-table* ->* name entries)
+ (dolist entries ->* symbol)
+ (symbol-kind symbol -> kind)
+ (when (case kind
+ (:variable variables)
+ (:logical-symbol logical-symbols)
+ (:proposition (implies (not logical-symbols) (not (or (eq true symbol) (eq false symbol)))))
+ (otherwise t))
+ (funcall cc name kind symbol))))
+
+(defun symbol-aliases (symbol)
+ ;; slow
+ (let ((aliases nil))
+ (prog->
+ (symbol-to-name symbol -> name)
+ (map-symbol-table :logical-symbols t :variables nil ->* name2 kind2 symbol2)
+ (declare (ignore kind2))
+ (when (eql symbol symbol2)
+ (unless (eql name name2)
+ (push name2 aliases))))
+ (sort aliases #'string< :key #'symbol-name)))
+
+(defun print-symbol-table (&key logical-symbols variables)
+ (with-standard-io-syntax2
+ (labels
+ ((print-aliases (symbol)
+ (let ((aliases (symbol-aliases symbol)))
+ (when aliases
+ (format t "~35T (alias ~S~{, ~S~})" (first aliases) (rest aliases)))))
+ (print-symbols1 (list kind)
+ (when list
+ (let ((len (length list)))
+ (format t "~%~D ~(~A~)~P:" len kind len))
+ (dolist (symbol (sort list #'function-name-arity-lessp))
+ (format t "~% ~S~26T" symbol)
+ (let ((arity (function-arity symbol)))
+ (unless (member arity '(:any))
+ (format t " ~A-ary" arity)))
+ (when (function-macro symbol)
+ (format t " macro"))
+ (print-aliases symbol))))
+ (print-symbols2 (list kind orderfn)
+ (when list
+ (let ((len (length list)))
+ (format t "~%~D ~(~A~)~P:" len kind len))
+ (dolist (symbol (sort list orderfn))
+ (cond
+ ((or (eq :constant kind) (eq :proposition kind))
+ (format t "~% ~S" (constant-name symbol))
+ (print-aliases symbol))
+ ((eq :sort kind)
+ (format t "~% ~S" (sort-name symbol))
+ (print-aliases symbol))
+ (t
+ (format t "~% ~S" symbol)))))))
+ (let ((list-of-variables nil)
+ (list-of-sorts nil)
+ (list-of-constants nil)
+ (list-of-propositions nil)
+ (list-of-functions nil)
+ (list-of-relations nil)
+ (list-of-logical-symbols nil)
+ (ambiguous nil))
+ (prog->
+ (identity none -> previous-name)
+ (map-symbol-table :logical-symbols logical-symbols :variables variables ->* name kind symbol)
+ (cond
+ ((neql previous-name name)
+ (setf previous-name name))
+ ((or (null ambiguous) (neql name (first ambiguous)))
+ (push name ambiguous)))
+ (ecase kind
+ (:variable
+ (push name list-of-variables))
+ (:sort
+ (when (eq name (sort-name symbol))
+ (push symbol list-of-sorts)))
+ (:constant
+ (when (eql name (constant-name symbol))
+ (push symbol list-of-constants)))
+ (:proposition
+ (when (eq name (constant-name symbol))
+ (push symbol list-of-propositions)))
+ (:function
+ (when (eq name (function-name symbol))
+ (push symbol list-of-functions)))
+ (:relation
+ (when (eq name (function-name symbol))
+ (push symbol list-of-relations)))
+ (:logical-symbol
+ (when (eq name (function-name symbol))
+ (push symbol list-of-logical-symbols)))))
+ (print-symbols1 list-of-logical-symbols :logical-symbol)
+ (print-symbols2 list-of-variables :variable #'string<)
+ (print-symbols2 list-of-sorts :sort #'(lambda (x y) (string< (sort-name x) (sort-name y))))
+ (print-symbols2 list-of-propositions :proposition #'constant-name-lessp)
+ (print-symbols2 list-of-constants :constant #'constant-name-lessp)
+ (print-symbols1 list-of-functions :function)
+ (print-symbols1 list-of-relations :relation)
+ (when ambiguous
+ (format t "~%~D symbol~:P with multiple meanings:" (length ambiguous))
+ (dolist (symbol (sort ambiguous #'string<))
+ (format t "~% ~S" symbol)))
+ nil))))
+
+(defun symbol-to-name (x)
+ (cond
+ ((function-symbol-p x)
+ (function-name x))
+ ((sort? x)
+ (sort-name x))
+ (t
+ (constant-name x))))
+
+(defun symbol-boolean-valued-p (x)
+ (if (function-symbol-p x)
+ (function-boolean-valued-p x)
+ (constant-boolean-valued-p x)))
+
+(defun symbol-number (x)
+ (if (function-symbol-p x)
+ (function-number x)
+ (constant-number x)))
+
+(definline symbol-numbered (n)
+ (funcall *standard-eql-numbering* :inverse n))
+
+(defun the-function-symbol (name arity &optional kind)
+ (let ((symbol (find-symbol-table-entry name (or kind :function) arity)))
+ (cl:assert (neq none symbol))
+ symbol))
+
+(defun current-function-name (name arity &optional kind)
+ (function-name (the-function-symbol name arity (or kind :function))))
+
+(defun input-symbol (name &key macro)
+ ;; return SNARK symbol whose name is name
+ ;; primary usage is for term ordering declarations
+ ;; special handling for true and false
+ ;; accept as input the internal symbols for true and false
+ ;; if name is 'true or 'false, return the constant true or false if there is one; otherwise return the proposition
+ (cond
+ ((numberp name)
+ (declare-number name))
+ ((stringp name)
+ (declare-string name))
+ ((or (eq true name) (eq false name) (function-symbol-p name))
+ name) ;already in internal format
+ (t
+ (can-be-constant-or-function-name name 'error)
+ (let ((found nil))
+ (prog->
+ (dolist (symbol-table-entries name) ->* symbol)
+ (symbol-kind symbol -> kind)
+ (cond
+ ((or (eq :sort kind) (eq :variable kind))
+ )
+ ((and (not macro) (function-symbol-p symbol) (function-macro symbol))
+ )
+ (found
+ (cond
+ ((and (or (eq 'true name) (eq 'false name)) (eq :proposition kind) (eq :constant (first found)))
+ )
+ ((and (or (eq 'true name) (eq 'false name)) (eq :constant kind) (eq :proposition (first found)))
+ (setf found (cons kind symbol)))
+ (t
+ (error "There is more than one entry for ~S in symbol table." name))))
+ (t
+ (setf found (cons kind symbol)))))
+ (cond
+ ((null found)
+ (error "Couldn't find ~S in symbol table." name))
+ (t
+ (cdr found)))))))
+
+(defun input-constant-symbol (name)
+ (let ((quoted (and (consp name) (eq '$$quote (first name)) (rest name) (null (rrest name)))))
+ (when quoted
+ (setf name (second name)))
+ (cond
+ ((numberp name)
+ (declare-number name))
+ ((stringp name)
+ (declare-string name))
+ (t
+ (unless (and quoted (atom name))
+ (can-be-constant-name name 'error))
+ (find-or-create-symbol-table-entry name :constant)))))
+
+(defun input-proposition-symbol (name)
+ (cond
+ ((or (eq true name) (eq false name)) ;allow internal true and false values in input
+ name) ;they are already in internal format
+ (t
+ (can-be-proposition-name name 'error)
+ (find-or-create-symbol-table-entry name :proposition))))
+
+(defun input-function-symbol (name arity &optional rel)
+ ;; find or create a function (or relation) symbol with the given name and arity
+ (cond
+ ((function-symbol-p name)
+ ;; generalize by allowing name to be a function (or relation) symbol of correct arity
+ (cl:assert (and (function-has-arity-p name arity) (iff (function-boolean-valued-p name) rel)))
+ name)
+ (t
+ (can-be-function-name name 'error)
+ (find-or-create-symbol-table-entry name (if rel :relation :function) arity))))
+
+(defun input-relation-symbol (name arity)
+ ;; find or create a relation symbol with the given name and arity
+ (input-function-symbol name arity t))
+
+(defun input-logical-symbol (name &optional create-if-does-not-exist)
+ (cond
+ (create-if-does-not-exist
+ (can-be-logical-symbol-name name 'error)
+ (find-or-create-symbol-table-entry name :logical-symbol :any))
+ (t
+ (find-symbol-table-entry name :logical-symbol :any))))
+
+(defun expr-arity (x)
+ ;; used by input-wff etc. to count arguments of nonatomic expression
+ (list-p (rest x)))
+
+(defun input-head-function-symbol (term)
+ (input-function-symbol (first term) (expr-arity term)))
+
+(defun input-head-relation-symbol (wff)
+ (input-relation-symbol (first wff) (expr-arity wff)))
+
+;;; symbol-table2.lisp EOF
diff --git a/snark-20120808r02/src/term-hash.abcl b/snark-20120808r02/src/term-hash.abcl
new file mode 100644
index 0000000..5ab6dbd
Binary files /dev/null and b/snark-20120808r02/src/term-hash.abcl differ
diff --git a/snark-20120808r02/src/term-hash.lisp b/snark-20120808r02/src/term-hash.lisp
new file mode 100644
index 0000000..d494a57
--- /dev/null
+++ b/snark-20120808r02/src/term-hash.lisp
@@ -0,0 +1,250 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: term-hash.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defvar *atom-hash-code*)
+(defvar *term-by-hash-array*)
+(defvar *hash-term-uses-variable-numbers* t)
+(defvar *hash-term-only-computes-code* nil)
+(defvar *hash-term-not-found-action* :add)
+
+(defun initialize-term-hash ()
+ (setf *atom-hash-code* 0)
+ (setf *term-by-hash-array* (make-sparse-vector))
+ nil)
+
+(defun make-atom-hash-code ()
+ ;; return a hash-code in [2,1023]
+ (if (<= (setf *atom-hash-code* (mod (+ (* 129 *atom-hash-code*) 1) 1024)) 1)
+ (make-atom-hash-code)
+ *atom-hash-code*))
+
+(defun find-term-by-hash (x hash)
+ (let* ((term-by-hash-array *term-by-hash-array*)
+ (terms (sparef term-by-hash-array hash)))
+ (when terms
+ (dolist (term terms)
+ (when (eq term x)
+ (return-from find-term-by-hash term)))
+ (dolist (term terms)
+ (when (equal-p term x)
+ (return-from find-term-by-hash term))))
+ (ecase *hash-term-not-found-action*
+ (:add
+ (setf (sparef term-by-hash-array hash) (cons x terms))
+ x)
+ (:throw
+ (throw 'hash-term-not-found none))
+ (:error
+ (error "No hash-term for ~S." x)))))
+
+(defun term-by-hash-array-terms (&optional delete-variants)
+ (let ((terms nil) terms-last)
+ (prog->
+ (map-sparse-vector *term-by-hash-array* ->* l)
+ (copy-list l -> l)
+ (ncollect (if (and delete-variants (not *hash-term-uses-variable-numbers*))
+ (delete-duplicates l :test #'variant-p)
+ l)
+ terms))
+ (if (and delete-variants *hash-term-uses-variable-numbers*)
+ (delete-duplicates terms :test #'variant-p)
+ terms)))
+
+(defmacro thvalues (hash x)
+ `(if *hash-term-only-computes-code* ,hash (values ,hash ,x)))
+
+(defun hash-term* (x subst)
+ (dereference
+ x subst
+ :if-variable (thvalues (if *hash-term-uses-variable-numbers* (+ 1024 (variable-number x)) 0) x)
+ :if-constant (thvalues (constant-hash-code x) x)
+ :if-compound (mvlet (((:values hash x) (hash-compound x subst)))
+ (thvalues hash (if (eq *cons* (head x)) x (find-term-by-hash x hash))))))
+
+(defun hash-term-code (x &optional subst)
+ ;; just return the hash code without finding or creating canonical forms
+ (let ((*hash-term-only-computes-code* t))
+ (hash-term* x subst)))
+
+(defun hash-term (x &optional subst)
+ ;; find or create canonical form of x.subst
+ ;; but doesn't store a canonical form for conses
+ ;; (equal-p x (hash-term x))
+ ;; (equal-p x y) => (eql (hash-term x) (hash-term y))
+ (when (test-option38?)
+ (return-from hash-term (instantiate x subst)))
+ (mvlet (((:values hash x) (hash-term* x subst)))
+ (values x hash)))
+
+(defun some-hash-term (x &optional subst)
+ ;; hash-term or none
+ (let ((*hash-term-not-found-action* :throw))
+ (catch 'hash-term-not-found
+ (hash-term x subst))))
+
+(defun the-hash-term (x &optional subst)
+ ;; hash-term or error
+ (let ((*hash-term-not-found-action* :error))
+ (hash-term x subst)))
+
+(defun hash-list (l subst multiplier)
+ ;; (a b c ...) -> 2*hash(a) + 3*hash(b) + 4*hash(c) ...
+ (cond
+ ((null l)
+ 0)
+ (t
+ (mvlet* ((x (first l))
+ ((:values xhash x*) (hash-term* x subst))
+ (y (rest l)))
+ (when multiplier
+ (setf xhash (* multiplier xhash)))
+ (if (null y)
+ (thvalues xhash (if (eql x x*) l (cons x* nil)))
+ (mvlet (((:values yhash y*) (hash-list y subst (and multiplier (+ multiplier 1)))))
+ (thvalues (+ xhash yhash) (if (and (eq y y*) (eql x x*)) l (cons x* y*)))))))))
+
+(defun hash-compound (compd &optional subst)
+ ;; this uses a simpler term hashing function than before
+ ;; it should be is easier to verify and maintain
+ ;;
+ ;; for (f t1 ... tn) it computes (+ (# f) (* 2 (# t1)) ... (* (+ n 1) (# tn)))
+ ;; but uses 0 for (# f) if f is associative (since these symbols may disappear)
+ ;; and uses 1 for multipliers if f is associative, commutative, etc.
+ ;;
+ ;; when *hash-term-uses-variable-numbers* is nil
+ ;; it should be the case that (implies (subsumes-p t1 t2) (<= (# t1) (# t2)))
+ (let ((head (head compd))
+ (args (args compd)))
+ (cond
+ ((null args)
+ (thvalues (function-hash-code head) compd))
+ (t
+ (ecase (function-index-type head)
+ ((nil :hash-but-dont-index)
+ (mvlet (((:values hash args*)
+ (hash-list args subst (and (not (function-associative head))
+ (not (function-commutative head))
+ 2))))
+ (incf hash (if (function-associative head)
+ (* (function-hash-code head) (+ 1 (length (rest (rest args)))))
+ (function-hash-code head)))
+ (thvalues hash (if (eq args args*) compd (make-compound* head args*)))))
+ (:commute
+ (prog->
+ (first args -> arg1)
+ (hash-term* arg1 subst -> hash1 arg1*)
+ (second args -> arg2)
+ (hash-term* arg2 subst -> hash2 arg2*)
+ (rest (rest args) -> args3)
+ (hash-list args3 subst 4 -> hash3 args3*)
+ (thvalues (+ (function-hash-code head) (* 2 hash1) (* 2 hash2) hash3)
+ (if (eq args3 args3*)
+ (if (eql arg2 arg2*)
+ (if (eql arg1 arg1*)
+ compd
+ (make-compound* head arg1* (rest args)))
+ (make-compound* head arg1* arg2* args3))
+ (make-compound* head arg1* arg2* args3*)))))
+ (:jepd
+ (prog->
+ (first args -> arg1)
+ (hash-term* arg1 subst -> hash1 arg1*)
+ (second args -> arg2)
+ (hash-term* arg2 subst -> hash2 arg2*)
+ (third args -> arg3)
+ (instantiate arg3 subst -> arg3*)
+ (thvalues (+ (function-hash-code head) (* 2 hash1) (* 2 hash2))
+ (if (eq arg3 arg3*)
+ (if (eql arg2 arg2*)
+ (if (eql arg1 arg1*)
+ compd
+ (make-compound* head arg1* (rest args)))
+ (make-compound* head arg1* arg2* (rest (rest args))))
+ (make-compound head arg1* arg2* arg3*))))))))))
+
+(defun print-term-hash (&key (details t) terms)
+ (let ((a (and details (make-sparse-vector :default-value 0)))
+ (nterms 0))
+ (prog->
+ (map-sparse-vector *term-by-hash-array* ->* l)
+ (length l -> len)
+ (incf nterms len)
+ (when details
+ (incf (sparef a len))))
+ (cond
+ (details
+ (format t "~%; Term-hash-array has ~:D position~:P filled with ~:D term~:P in all."
+ (sparse-vector-count *term-by-hash-array*) nterms)
+ (prog->
+ (map-sparse-vector-with-indexes a ->* n len)
+ (format t "~%; Term-hash-array has ~:D position~:P filled with ~:D term~:P each." n len)))
+ (t
+ (format t "~%; Term-hash-array has ~:D term~:P in all." nterms))))
+ (when terms
+ (prog->
+ (map-sparse-vector-with-indexes *term-by-hash-array* ->* l position)
+ (when (implies (and (numberp terms) (< 1 terms)) (>= (length l) terms))
+ (format t "~%; ~6D: ~S~{~%; ~S~}" position (first l) (rest l))))))
+
+(defvar *default-hash-term-set-count-down-to-hashing* 10) ;can insert this many before hashing
+
+(defstruct (hash-term-set
+ (:constructor make-hash-term-set (&optional substitution))
+ (:conc-name :hts-))
+ (terms nil) ;list or hash-table of terms
+ (substitution nil :read-only t)
+ (count-down-to-hashing *default-hash-term-set-count-down-to-hashing*))
+
+(defun hts-member-p (term hts)
+ (let* ((terms (hts-terms hts))
+ (l (if (eql 0 (hts-count-down-to-hashing hts))
+ (gethash (hash-term-code term) terms)
+ terms)))
+ (if (and l (member-p term l (hts-substitution hts))) t nil)))
+
+(defun hts-adjoin-p (term hts)
+ ;; if term is a already a member of hts, return NIL
+ ;; otherwise add it and return true
+ (let* ((terms (hts-terms hts))
+ (c (hts-count-down-to-hashing hts))
+ h
+ (l (if (eql 0 c)
+ (gethash (setf h (hash-term-code term)) terms)
+ terms)))
+ (cond
+ ((and l (member-p term l (hts-substitution hts)))
+ nil)
+ ((eql 0 c)
+ (setf (gethash h terms) (cons term l))
+ t)
+ ((eql 1 c)
+ (setf (hts-terms hts) (setf terms (make-hash-table)))
+ (setf (gethash (hash-term-code term) terms) (cons term nil))
+ (dolist (term l)
+ (push term (gethash (hash-term-code term) terms)))
+ (setf (hts-count-down-to-hashing hts) 0)
+ t)
+ (t
+ (setf (hts-terms hts) (cons term l))
+ (setf (hts-count-down-to-hashing hts) (- c 1))
+ t))))
+
+;;; term-hash.lisp EOF
diff --git a/snark-20120808r02/src/term-memory.abcl b/snark-20120808r02/src/term-memory.abcl
new file mode 100644
index 0000000..07405f8
Binary files /dev/null and b/snark-20120808r02/src/term-memory.abcl differ
diff --git a/snark-20120808r02/src/term-memory.lisp b/snark-20120808r02/src/term-memory.lisp
new file mode 100644
index 0000000..686425c
--- /dev/null
+++ b/snark-20120808r02/src/term-memory.lisp
@@ -0,0 +1,286 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: term-memory.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defvar *term-memory*)
+
+(defstruct (term-memory-entry
+ (:include path-index-entry)
+ (:conc-name :tme-)
+ (:copier nil))
+ (number (nonce) :read-only t)
+ (rows-containing-atom-positively nil)
+ (rows-containing-atom-negatively nil)
+ (rows-containing-paramodulatable-equality nil)
+ (rows-containing-term nil)
+ (rewrites nil)
+ size
+ depth
+ mindepth)
+
+(defstruct (term-memory
+ (:conc-name :tm-)
+ (:constructor make-term-memory0)
+ (:copier nil))
+ (retrieve-generalization-calls 0) ;number of generalization retrieval calls
+ (retrieve-generalization-count 0)
+ (retrieve-instance-calls 0) ; " instance "
+ (retrieve-instance-count 0)
+ (retrieve-unifiable-calls 0) ; " unifiable "
+ (retrieve-unifiable-count 0)
+ (retrieve-variant-calls 0) ; " variant "
+ (retrieve-variant-count 0)
+ (retrieve-all-calls 0) ; " all "
+ (retrieve-all-count 0)
+ )
+
+(defun make-term-memory-entry1 (term)
+ (make-term-memory-entry
+ :term term
+ :size (size term)
+ :depth (depth term)
+ :mindepth (mindepth term)))
+
+(defun make-term-memory (&key indexing-method depth-limit make-printable-nodes-p)
+ (declare (ignore indexing-method depth-limit make-printable-nodes-p))
+ (make-path-index :entry-constructor #'make-term-memory-entry1)
+ (make-trie-index :entry-constructor #'make-term-memory-entry1)
+ (setf *term-memory* (make-term-memory0))
+ *term-memory*)
+
+(defun term-memory-entry (term)
+;;(path-index-entry term)
+ (nth-value 1 (tm-store term))
+ )
+
+(defun some-term-memory-entry (term)
+ (some-path-index-entry term))
+
+(defun the-term-memory-entry (term)
+ (the-path-index-entry term))
+
+(defun tm-store (term)
+;;(cl:assert (eql term (hash-term term)))
+ (when (variable-p term)
+ (error "STORING VARIABLE IN TERM MEMORY"))
+ (let (entry)
+ (cond
+ ((setf entry (some-path-index-entry term))
+ (cl:assert (eql term (tme-term entry)))
+ (values term entry t))
+ (t
+ (setf entry (path-index-insert term))
+ (cl:assert (eql term (tme-term entry)))
+ (trie-index-insert term entry)
+ (when (or (test-option51?) (test-option52?))
+ (feature-vector-index-insert entry *feature-vector-term-index*))
+ (values term entry)))))
+
+(defun tm-remove-entry (entry)
+ (let ((rowset (tme-rows-containing-term entry)))
+ (when rowset
+ (rowsets-delete-column rowset)
+ (setf (tme-rows-containing-term entry) nil)))
+ (let ((rowset (tme-rows-containing-atom-positively entry)))
+ (when rowset
+ (rowsets-delete-column rowset)
+ (setf (tme-rows-containing-atom-positively entry) nil)))
+ (let ((rowset (tme-rows-containing-atom-negatively entry)))
+ (when rowset
+ (rowsets-delete-column rowset)
+ (setf (tme-rows-containing-atom-negatively entry) nil)))
+ (path-index-delete (tme-term entry))
+ (trie-index-delete (tme-term entry) entry)
+ (when (or (test-option51?) (test-option52?))
+ (feature-vector-index-delete entry *feature-vector-term-index*)))
+
+(defun retrieve-generalization-entries (cc term &optional subst test)
+ (when (test-option51?)
+ (if (null test)
+ (prog->
+ (map-feature-vector-term-index-generalizations term subst ->* entry)
+ (funcall cc entry))
+ (prog->
+ (map-feature-vector-term-index-generalizations term subst ->* entry)
+ (funcall test entry ->nonnil test-value)
+ (funcall cc entry test-value)))
+ (return-from retrieve-generalization-entries))
+ #-ignore (incf (tm-retrieve-generalization-calls *term-memory*))
+ (if (null test)
+ (prog->
+ (map-trie-index :generalization term subst ->* entry)
+ #-ignore (incf (tm-retrieve-generalization-count *term-memory*))
+ (funcall cc entry))
+ (prog->
+ (map-trie-index :generalization term subst ->* entry)
+ (funcall test entry ->nonnil test-value)
+ #-ignore (incf (tm-retrieve-generalization-count *term-memory*))
+ (funcall cc entry test-value))))
+
+(defun retrieve-instance-entries (cc term &optional subst test)
+ (when (test-option52?)
+ (if (null test)
+ (prog->
+ (map-feature-vector-term-index-instances term subst ->* entry)
+ (funcall cc entry))
+ (prog->
+ (map-feature-vector-term-index-instances term subst ->* entry)
+ (funcall test entry ->nonnil test-value)
+ (funcall cc entry test-value)))
+ (return-from retrieve-instance-entries))
+ #-ignore (incf (tm-retrieve-instance-calls *term-memory*))
+ (cond
+ ((and (ground-p term subst) (simply-indexed-p term subst))
+ (if (null test)
+ (prog->
+ (map-trie-index :instance term subst ->* entry)
+ #-ignore (incf (tm-retrieve-instance-count *term-memory*))
+ (funcall cc entry))
+ (prog->
+ (map-trie-index :instance term subst ->* entry)
+ (funcall test entry ->nonnil test-value)
+ #-ignore (incf (tm-retrieve-instance-count *term-memory*))
+ (funcall cc entry test-value))))
+ (t
+ (if (null test)
+ (prog->
+ (map-path-index-entries :instance term subst test ->* entry)
+ #-ignore (incf (tm-retrieve-instance-count *term-memory*))
+ (funcall cc entry))
+ (prog->
+ (map-path-index-entries :instance term subst test ->* entry test-value)
+ #-ignore (incf (tm-retrieve-instance-count *term-memory*))
+ (funcall cc entry test-value))))))
+
+(defun retrieve-unifiable-entries (cc term &optional subst test)
+ #-ignore (incf (tm-retrieve-unifiable-calls *term-memory*))
+ (if (null test)
+ (prog->
+ (map-path-index-entries :unifiable term subst test ->* entry)
+ #-ignore (incf (tm-retrieve-unifiable-count *term-memory*))
+ (funcall cc entry))
+ (prog->
+ (map-path-index-entries :unifiable term subst test ->* entry test-value)
+ #-ignore (incf (tm-retrieve-unifiable-count *term-memory*))
+ (funcall cc entry test-value))))
+
+(defun retrieve-resolvable-entries (cc atom &optional subst test)
+ (unless (do-not-resolve atom)
+ (retrieve-unifiable-entries cc atom subst test)))
+
+(defun retrieve-paramodulatable-entries (cc term &optional subst test)
+ (unless (do-not-paramodulate term)
+ (retrieve-unifiable-entries cc term subst test)))
+
+(defun retrieve-variant-entries (cc term &optional subst test)
+ #-ignore (incf (tm-retrieve-variant-calls *term-memory*))
+ (if (null test)
+ (prog->
+ (map-path-index-entries :variant term subst test ->* entry)
+ #-ignore (incf (tm-retrieve-variant-count *term-memory*))
+ (funcall cc entry))
+ (prog->
+ (map-path-index-entries :variant term subst test ->* entry test-value)
+ #-ignore (incf (tm-retrieve-variant-count *term-memory*))
+ (funcall cc entry test-value))))
+
+(defun retrieve-all-entries (cc &optional test)
+ #-ignore (incf (tm-retrieve-all-calls *term-memory*))
+ (if (null test)
+ (prog->
+ (map-path-index-by-query t test ->* entry)
+ #-ignore (incf (tm-retrieve-all-count *term-memory*))
+ (funcall cc entry))
+ (prog->
+ (map-path-index-by-query t test ->* entry test-value)
+ #-ignore (incf (tm-retrieve-all-count *term-memory*))
+ (funcall cc entry test-value))))
+
+(defun print-term-memory (&key terms nodes)
+ (print-term-hash :terms nil :details nil)
+ (print-feature-vector-row-index)
+ (when (or (test-option51?) (test-option52?))
+ (print-feature-vector-term-index))
+ (print-path-index :terms terms :nodes nodes)
+ (print-trie-index :terms terms :nodes nodes)
+ (unless (eql 0 (tm-retrieve-variant-calls *term-memory*))
+ (format t "~%; Retrieved ~:D variant term~:P in ~:D call~:P."
+ (tm-retrieve-variant-count *term-memory*)
+ (tm-retrieve-variant-calls *term-memory*)))
+ (unless (eql 0 (tm-retrieve-generalization-calls *term-memory*))
+ (format t "~%; Retrieved ~:D generalization term~:P in ~:D call~:P."
+ (tm-retrieve-generalization-count *term-memory*)
+ (tm-retrieve-generalization-calls *term-memory*)))
+ (unless (eql 0 (tm-retrieve-instance-calls *term-memory*))
+ (format t "~%; Retrieved ~:D instance term~:P in ~:D call~:P."
+ (tm-retrieve-instance-count *term-memory*)
+ (tm-retrieve-instance-calls *term-memory*)))
+ (unless (eql 0 (tm-retrieve-unifiable-calls *term-memory*))
+ (format t "~%; Retrieved ~:D unifiable term~:P in ~:D call~:P."
+ (tm-retrieve-unifiable-count *term-memory*)
+ (tm-retrieve-unifiable-calls *term-memory*)))
+ (unless (eql 0 (tm-retrieve-all-calls *term-memory*))
+ (format t "~%; Retrieved ~:D unrestricted term~:P in ~:D call~:P."
+ (tm-retrieve-all-count *term-memory*)
+ (tm-retrieve-all-calls *term-memory*))))
+
+(defun tme-useless-p (entry)
+ (and (eql 0 (sparse-vector-count (tme-rows-containing-term entry)))
+ (eql 0 (sparse-vector-count (tme-rows-containing-atom-positively entry)))
+ (eql 0 (sparse-vector-count (tme-rows-containing-atom-negatively entry)))
+ (null (tme-rows-containing-paramodulatable-equality entry))
+ (null (tme-rewrites entry))))
+
+(defmacro rows-containing-atom-positively (atom)
+ `(tme-rows-containing-atom-positively
+ (term-memory-entry ,atom)))
+
+(defmacro rows-containing-atom-negatively (atom)
+ `(tme-rows-containing-atom-negatively
+ (term-memory-entry ,atom)))
+
+(defmacro rows-containing-paramodulatable-equality (equality)
+ `(tme-rows-containing-paramodulatable-equality
+ (term-memory-entry ,equality)))
+
+(defmacro rows-containing-term (term)
+ `(tme-rows-containing-term
+ (term-memory-entry ,term)))
+
+(defmacro rewrites (term)
+ `(tme-rewrites
+ (term-memory-entry ,term)))
+
+(defun insert-into-rows-containing-term (row term)
+ (let ((e (term-memory-entry term)))
+ (rowset-insert row (or (tme-rows-containing-term e)
+ (setf (tme-rows-containing-term e) (make-rowset))))))
+
+(defun insert-into-rows-containing-atom-positively (row atom)
+ (let ((e (term-memory-entry atom)))
+ (rowset-insert row (or (tme-rows-containing-atom-positively e)
+ (setf (tme-rows-containing-atom-positively e) (make-rowset))))))
+
+(defun insert-into-rows-containing-atom-negatively (row atom)
+ (let ((e (term-memory-entry atom)))
+ (rowset-insert row (or (tme-rows-containing-atom-negatively e)
+ (setf (tme-rows-containing-atom-negatively e) (make-rowset))))))
+
+;;; term-memory.lisp EOF
diff --git a/snark-20120808r02/src/terms2.abcl b/snark-20120808r02/src/terms2.abcl
new file mode 100644
index 0000000..848885d
Binary files /dev/null and b/snark-20120808r02/src/terms2.abcl differ
diff --git a/snark-20120808r02/src/terms2.lisp b/snark-20120808r02/src/terms2.lisp
new file mode 100644
index 0000000..10f9fcf
--- /dev/null
+++ b/snark-20120808r02/src/terms2.lisp
@@ -0,0 +1,231 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: terms2.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defvar *cons*)
+(defvar *=*)
+(defvar *not*)
+(defvar *and*)
+(defvar *or*)
+(defvar *implies*)
+(defvar *implied-by*)
+(defvar *iff*)
+(defvar *xor*)
+(defvar *if*)
+(defvar *forall*)
+(defvar *exists*)
+(defvar *answer-if*)
+
+(defvar *a-function-with-left-to-right-ordering-status*)
+(defvar *a-function-with-multiset-ordering-status*)
+
+(definline compound-appl-p (x)
+ (and (consp x) (function-symbol-p (carc x))))
+
+(definline heada (appl)
+ ;; only if appl is compound-appl, not compound-cons
+ (carc appl))
+
+(definline argsa (appl)
+ ;; only if appl is compound-appl, not compound-cons
+ (cdrc appl))
+
+(definline constant-p (x)
+ (and (atom x) (not (variable-p x))))
+
+(definline compound-p (x)
+ (consp x))
+
+(defun make-compound%2 (head arg1 arg2)
+ (if (eq *cons* head)
+ (cons arg1 arg2)
+ (list head arg1 arg2)))
+
+(defun make-compound%* (head args)
+ (if (eq *cons* head)
+ (cons (first args) (second args))
+ (cons head args)))
+
+(defmacro make-compound (head &rest args)
+ ;; e.g., (make-compound 'f 'a 'b 'c) = (f a b c)
+ (case (length args)
+ (2
+ `(make-compound%2 ,head ,@args))
+ (otherwise
+ `(list ,head ,@args))))
+
+(defmacro make-compound* (head &rest args)
+ ;; e.g., (make-compound* 'f '(a b c)) = (make-compound* 'f 'a '(b c)) = (f a b c)
+ (cl:assert (not (null args)))
+ `(make-compound%* ,head (list* ,@args)))
+
+(definline arg1a (appl)
+ ;; only if appl is compound-appl, not compound-cons
+ (first (argsa appl)))
+
+(definline arg2a (appl)
+ ;; only if appl is compound-appl, not compound-cons
+ (second (argsa appl)))
+
+(definline arg1 (compound)
+ (let ((v (car compound)))
+ (if (function-symbol-p v) (arg1a compound) v)))
+
+(definline arg2 (compound)
+ (let ((v (car compound)))
+ (if (function-symbol-p v) (arg2a compound) (cdrc compound))))
+
+(definline args (compound)
+ ;; note: (iff (neq (args compound) (args compound)) (eq *cons* (head compound)))
+ (let ((v (car compound)))
+ (if (function-symbol-p v) (argsa compound) (list v (cdrc compound)))))
+
+(definline head (compound)
+ (let ((v (car compound)))
+ (if (function-symbol-p v) v *cons*)))
+
+(definline head-or-term (x)
+ (cond
+ ((consp x)
+ (let ((v (carc x)))
+ (if (function-symbol-p v) v *cons*)))
+ (t
+ x)))
+
+(defmacro fancy-make-compound* (head &rest args)
+ (let ((hd (gensym))
+ (fn (gensym)))
+ `(let* ((,hd ,head)
+ (,fn (function-make-compound*-function ,hd)))
+ (if ,fn
+ ,(if (null (rest args))
+ `(funcall ,fn ,(first args))
+ `(funcall ,fn (list* ,@args)))
+ (make-compound* ,hd ,@args)))))
+
+(defun make-compound2 (head args)
+ ;; e.g., (make-compound2 'and '(a b c)) = (and a (and b c))
+ ;; (cl:assert (<= 2 (length args)))
+ (cond
+ ((null (rrest args))
+ (make-compound* head args))
+ (t
+ (make-compound head (first args) (make-compound2 head (rest args))))))
+
+(defmacro make-a1-compound* (head identity &rest args)
+ (case (length args)
+ (1
+ (let ((x (gensym)))
+ `(let ((,x ,(first args)))
+ (cond
+ ((null ,x)
+ ,identity)
+ ((null (rest ,x))
+ (first ,x))
+ (t
+ (make-compound* ,head ,x))))))
+ (2
+ (let ((x (gensym)) (y (gensym)))
+ `(let ((,x ,(first args)) (,y ,(second args)))
+ (cond
+ ((null ,y)
+ ,x)
+ (t
+ (make-compound* ,head ,x ,y))))))
+ (otherwise
+ `(make-compound* ,head ,@args))))
+
+(defmacro dereference (x subst &key
+ (if-variable nil)
+ (if-constant nil)
+ (if-compound nil if-compound-supplied)
+ (if-compound-cons nil if-compound-cons-supplied)
+ (if-compound-appl nil if-compound-appl-supplied))
+ ;; dereferences x leaving result in x
+ (cl:assert (symbolp x))
+ (cl:assert (symbolp subst))
+ (cl:assert (implies if-compound-supplied
+ (and (not if-compound-cons-supplied)
+ (not if-compound-appl-supplied))))
+ `(cond
+ ,@(unless (null subst)
+ (list (let ((bindings (gensym)))
+ `((and (variable-p ,x)
+ (or (null ,subst)
+ (let ((,bindings ,subst))
+ (loop ;cf. lookup-variable-in-substitution
+ (cond
+ ((eq ,x (caarcc ,bindings))
+ (if (variable-p (setf ,x (cdarcc ,bindings)))
+ (setf ,bindings ,subst)
+ (return nil)))
+ ((null (setf ,bindings (cdrc ,bindings)))
+ (return t)))))))
+ ,if-variable))))
+ ,@(when if-compound
+ (list `((consp ,x) ,if-compound)))
+ ,@(when (or if-compound-cons if-compound-appl)
+ (list `((consp ,x) (if (function-symbol-p (carc ,x)) ,if-compound-appl ,if-compound-cons))))
+ ,@(when (and if-constant (not (or if-compound if-compound-cons if-compound-appl)))
+ (list `((consp ,x) nil)))
+ ,@(when (and (null subst) (or if-variable if-constant))
+ (list `((variable-p ,x) ,if-variable)))
+ ,@(when if-constant
+ (list `(t ,if-constant)))))
+
+(defmacro dereference2 (x y subst &key
+ if-constant*constant if-constant*compound if-constant*variable
+ if-compound*constant if-compound*compound if-compound*variable
+ if-variable*constant if-variable*compound if-variable*variable)
+ `(dereference
+ ,x ,subst
+ :if-constant (dereference ,y ,subst :if-constant ,if-constant*constant :if-compound ,if-constant*compound :if-variable ,if-constant*variable)
+ :if-compound (dereference ,y ,subst :if-constant ,if-compound*constant :if-compound ,if-compound*compound :if-variable ,if-compound*variable)
+ :if-variable (dereference ,y ,subst :if-constant ,if-variable*constant :if-compound ,if-variable*compound :if-variable ,if-variable*variable)))
+
+(defmacro prefer-to-bind-p (var2 var1)
+ (declare (ignore var2 var1))
+ nil)
+
+(defvar *frozen-variables* nil) ;list of variables not allowed to be instantiated
+
+(definline variable-frozen-p (var)
+ (let ((l *frozen-variables*))
+ (and l (member var l :test #'eq))))
+
+(definline unfrozen-variable-p (x)
+ (and (variable-p x)
+ (not (variable-frozen-p x))))
+
+(definline make-tc (term count)
+ ;; make term and count pair for count-arguments
+ (cons term count))
+
+(definline tc-term (x)
+ ;; term part of term and count pair created by count-arguments
+ ;; term and count pair is represented as (term . count)
+ (carc x))
+
+(defmacro tc-count (x)
+ ;; count part of term and count pair created by count-arguments
+ ;; term and count pair is represented as (term . count)
+ `(the fixnum (cdrc ,x)))
+
+;;; terms2.lisp EOF
diff --git a/snark-20120808r02/src/topological-sort.abcl b/snark-20120808r02/src/topological-sort.abcl
new file mode 100644
index 0000000..997afcb
Binary files /dev/null and b/snark-20120808r02/src/topological-sort.abcl differ
diff --git a/snark-20120808r02/src/topological-sort.lisp b/snark-20120808r02/src/topological-sort.lisp
new file mode 100644
index 0000000..4292a4f
--- /dev/null
+++ b/snark-20120808r02/src/topological-sort.lisp
@@ -0,0 +1,81 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
+;;; File: topological-sort.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2006.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-lisp)
+
+(defun topological-sort* (items map-predecessors)
+ ;; see Cormen, Leiserson, Rivest text
+ ;; (funcall map-predecessors cc u items) iterates over u in items
+ ;; that must occur before v and executes (funcall cc u)
+ ;; note: also eliminates EQL duplicates
+ (let ((color (make-hash-table))
+ (result nil) result-last)
+ (labels
+ ((dfs-visit (v)
+ (when (eq :white (gethash v color :white))
+ (setf (gethash v color) :gray)
+ (funcall map-predecessors #'dfs-visit v items)
+ (collect v result))))
+ (loop
+ (if (null items)
+ (return result)
+ (dfs-visit (pop items)))))))
+
+(defun topological-sort (items must-precede-predicate)
+ (topological-sort*
+ items
+ (lambda (cc v items)
+ (mapc (lambda (u)
+ (when (and (neql u v) (funcall must-precede-predicate u v))
+ (funcall cc u)))
+ items))))
+
+#+ignore
+(defun test-topological-sort* ()
+ (topological-sort*
+ '(belt jacket pants shirt shoes socks tie undershorts watch)
+ (lambda (cc v items)
+ (declare (ignore items))
+ (dolist (x '((undershorts . pants)
+ (undershorts . shoes)
+ (pants . belt)
+ (pants . shoes)
+ (belt . jacket)
+ (shirt . belt)
+ (shirt . tie)
+ (tie . jacket)
+ (socks . shoes)))
+ (when (eql v (cdr x))
+ (funcall cc (car x)))))))
+
+#+ignore
+(defun test-topological-sort ()
+ (topological-sort
+ '(belt jacket pants shirt shoes socks tie undershorts watch)
+ (lambda (u v)
+ (member v
+ (cdr (assoc u
+ '((undershorts pants shoes)
+ (pants belt shoes)
+ (belt jacket)
+ (shirt belt tie)
+ (tie jacket)
+ (socks shoes))))))))
+
+;;; topological-sort.lisp EOF
diff --git a/snark-20120808r02/src/tptp-symbols.abcl b/snark-20120808r02/src/tptp-symbols.abcl
new file mode 100644
index 0000000..539d079
Binary files /dev/null and b/snark-20120808r02/src/tptp-symbols.abcl differ
diff --git a/snark-20120808r02/src/tptp-symbols.lisp b/snark-20120808r02/src/tptp-symbols.lisp
new file mode 100644
index 0000000..e363bfc
--- /dev/null
+++ b/snark-20120808r02/src/tptp-symbols.lisp
@@ -0,0 +1,98 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
+;;; File: tptp-symbols.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark-user)
+
+;;; defines TPTP arithmetic relations and functions in terms of SNARK ones
+;;;
+;;; TPTP assumes polymorphic relations and functions over disjoint integer, rational, and real domains
+;;;
+;;; SNARK integers are a subtype of rationals and rationals are a subtype of reals
+;;;
+;;; reals are represented as rationals (e.g., 0.5 -> 1/2)
+
+(defun declare-tptp-sort (sort-name)
+ (declare-subsort sort-name 'tptp-nonnumber :subsorts-incompatible t))
+
+(defun declare-tptp-symbols1 (&key new-name)
+ (declare-sort '|$int| :iff 'integer)
+ (declare-sort '|$rat| :iff 'rational)
+ (declare-sort '|$real| :iff 'real)
+ ;; instead of
+ ;; (declare-subsort '|$i| :top-sort-a :subsorts-incompatible t),
+ ;; declare TPTP sorts so that TPTP distinct_objects can be sorted not just as strings
+ (declare-subsort 'tptp-nonnumber 'top-sort :subsorts-incompatible t)
+ (declare-sorts-incompatible 'tptp-nonnumber 'number)
+ (declare-tptp-sort '|$i|)
+
+ (labels
+ ((declare-tptp-symbol (fn x)
+ (mvlet (((list tptp-name name arity) x))
+ (funcall fn name arity (if new-name :new-name :alias) tptp-name))))
+
+ (mapc #'(lambda (x) (declare-tptp-symbol 'declare-relation x))
+ '((|$less| $$less 2)
+ (|$lesseq| $$lesseq 2)
+ (|$greater| $$greater 2)
+ (|$greatereq| $$greatereq 2)
+
+ #+ignore
+ (|$evaleq| $$eq 2)
+
+ (|$is_int| $$integerp 1)
+ (|$is_rat| $$rationalp 1)
+ (|$is_real| $$realp 1)
+ ))
+
+ (mapc #'(lambda (x) (declare-tptp-symbol 'declare-function x))
+ '((|$uminus| $$uminus 1)
+ (|$sum| $$sum 2)
+ (|$difference| $$difference 2)
+ (|$product| $$product 2)
+ (|$quotient| $$quotient 2)
+ (|$quotient_e| $$quotient_e 2)
+ (|$quotient_f| $$quotient_f 2)
+ (|$quotient_t| $$quotient_t 2)
+ (|$remainder_e| $$remainder_e 2)
+ (|$remainder_f| $$remainder_f 2)
+ (|$remainder_t| $$remainder_t 2)
+ (|$floor| $$floor 1)
+ (|$truncate| $$truncate 1)
+ (|$to_int| $$floor 1)
+ ))
+
+ (snark::declare-arithmetic-function '|$to_rat| 1 :sort 'rational :rewrite-code 'to_rat-term-rewriter)
+ (snark::declare-arithmetic-function '|$to_real| 1 :sort 'real :rewrite-code 'to_real-term-rewriter)
+ nil))
+
+(defun declare-tptp-symbols2 (&optional type)
+ (declare (ignore type))
+ nil)
+
+(defun to_rat-term-rewriter (term subst)
+ (let ((x (first (args term))))
+ (dereference x subst)
+ (if (rationalp x) x (if (subsort? (term-sort x subst) (the-sort 'rational)) x none))))
+
+(defun to_real-term-rewriter (term subst)
+ (let ((x (first (args term))))
+ (dereference x subst)
+ (if (realp x) x (if (subsort? (term-sort x subst) (the-sort 'real)) x none))))
+
+;;; tptp-symbols.lisp EOF
diff --git a/snark-20120808r02/src/tptp.abcl b/snark-20120808r02/src/tptp.abcl
new file mode 100644
index 0000000..0409087
Binary files /dev/null and b/snark-20120808r02/src/tptp.abcl differ
diff --git a/snark-20120808r02/src/tptp.lisp b/snark-20120808r02/src/tptp.lisp
new file mode 100644
index 0000000..9a202d3
--- /dev/null
+++ b/snark-20120808r02/src/tptp.lisp
@@ -0,0 +1,645 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: tptp.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; TSTP justifications are incomplete:
+;;; cnf and other transformations aren't named
+;;; use of AC, other theories aren't named
+;;; constraints aren't shown
+
+(defun print-row-in-tptp-format (row)
+ (let ((wff (row-wff row)))
+ (dolist (x (row-constraints row))
+ (when (member (car x) '(arithmetic equality))
+ (unless (eq true (cdr x))
+ (setf wff (make-reverse-implication wff (cdr x))))))
+ (print-wff-in-tptp-format1 wff (row-name-or-number row) (row-reason row) (row-source row))
+ row))
+
+(defun print-wff-in-tptp-format1 (wff name-or-number reason source)
+ (let ((vars (variables wff)))
+ (cond
+ ((some #'(lambda (var) (not (top-sort? (variable-sort var)))) vars)
+ (let ((*renumber-ignore-sort* t))
+ (setf wff (renumber (make-compound *forall* (mapcar #'(lambda (var) (list var (tptp-sort-name (variable-sort var)))) (reverse vars)) wff))))
+ (princ "tff("))
+ ((not (unsorted-p wff))
+ (princ "tff("))
+ ((clause-p wff nil t)
+ (princ "cnf("))
+ (t
+ (princ "fof("))))
+ (print-row-name-or-number-in-tptp-format name-or-number)
+ (princ ", ")
+ (print-row-reason-in-tptp-format reason)
+ (princ ",")
+ (terpri)
+ (princ " ")
+ (print-wff-in-tptp-format wff)
+ (let ((v (print-row-reason-in-tptp-format2 reason)))
+ (print-row-source-in-tptp-format source v))
+ (princ ").")
+ wff)
+
+(defun print-row-reason-in-tptp-format (reason)
+ (princ (case reason
+ (assertion "axiom")
+ (assumption "hypothesis")
+ (conjecture "conjecture")
+ (negated_conjecture "negated_conjecture")
+ (hint "hint")
+ (otherwise "plain"))))
+
+(defun print-row-name-or-number-in-tptp-format (name-or-number)
+ (print-symbol-in-tptp-format name-or-number))
+
+(defun print-row-reason-in-tptp-format2 (reason)
+ (case reason
+ ((assertion assumption conjecture negated_conjecture hint nil)
+ nil)
+ (otherwise
+ (princ ",")
+ (terpri)
+ (princ " ")
+ (print-row-reason-in-tptp-format3 reason)
+ t)))
+
+(defun print-row-reason-in-tptp-format3 (x)
+ (cond
+ ((consp x)
+ (princ "inference(")
+ (cond
+ ((eq 'paramodulate (first x))
+ (setf x (append x '(|theory(equality)|))))
+ ((eq 'rewrite (first x))
+ (cond
+ ((member :code-for-= (rrest x))
+ (setf x (append (remove :code-for-= x) '(|theory(equality)|))))
+ ((some (lambda (row) (and (row-p row) (compound-p (row-wff row)) (eq *=* (head (row-wff row))))) (rrest x))
+ (setf x (append x '(|theory(equality)|)))))))
+ (print-symbol-in-tptp-format (first x))
+ (princ ",")
+ (princ "[status(thm)]")
+ (princ ",")
+ (princ "[")
+ (let ((first t))
+ (dolist (arg (rest x))
+ (if first (setf first nil) (princ ","))
+ (print-row-reason-in-tptp-format3 arg)))
+ (princ "]")
+ (princ ")"))
+ ((row-p x)
+ (print-row-name-or-number-in-tptp-format (row-name-or-number x)))
+ ((or (eq '|theory(equality)| x) (eq :code-for-= x))
+ (princ '|theory(equality)|))
+ (t
+ (print-symbol-in-tptp-format x))))
+
+(defun print-row-source-in-tptp-format (source &optional list)
+ ;; "file('foo.tptp',ax1)" or (|file| |foo.tptp| |ax1|)
+ (when source
+ (cond
+ ((and (stringp source) (< 6 (length source)) (string= "file(" source :end2 4))
+ (princ ",")
+ (terpri)
+ (princ (if list " [" " "))
+ (princ source)
+ (when list (princ "]")))
+ ((and (consp source) (eq '|file| (first source)) (<= 2 (length source) 3))
+ (princ ",")
+ (terpri)
+ (princ (if list " [" " "))
+ (princ "file(")
+ (print-symbol-in-tptp-format (second source))
+ (when (rrest source)
+ (princ ",")
+ (print-symbol-in-tptp-format (third source)))
+ (princ ")")
+ (when list (princ "]")))))
+ source)
+
+(defun print-wff-in-tptp-format (wff &optional subst)
+ (dereference
+ wff subst
+ :if-variable (print-term-in-tptp-format wff)
+ :if-constant (cond
+ ((eq true wff)
+ (princ "$true"))
+ ((eq false wff)
+ (princ "$false"))
+ (t
+ (print-term-in-tptp-format wff)))
+ :if-compound (cond
+ ((equality-p wff)
+ (print-term-in-tptp-format (arg1 wff) subst) (princ " = ") (print-term-in-tptp-format (arg2 wff) subst))
+ ((negation-p wff)
+ (let ((wff (arg1 wff)))
+ (dereference wff subst)
+ (cond
+ ((equality-p wff)
+ (print-term-in-tptp-format (arg1 wff) subst) (princ " != ") (print-term-in-tptp-format (arg2 wff) subst))
+ (t
+ (princ "~ ") (print-wff-in-tptp-format wff subst)))))
+ ((disjunction-p wff)
+ (princ "(") (print-wffs-in-tptp-format (args wff) subst " | ") (princ ")"))
+ ((conjunction-p wff)
+ (princ "(") (print-wffs-in-tptp-format (args wff) subst " & ") (princ ")"))
+ ((equivalence-p wff)
+ (princ "(") (print-wffs-in-tptp-format (args wff) subst " <=> ") (princ ")"))
+ ((exclusive-or-p wff)
+ (princ "(") (print-wffs-in-tptp-format (args wff) subst " <~> ") (princ ")"))
+ ((implication-p wff)
+ (princ "(") (print-wffs-in-tptp-format (args wff) subst " => ") (princ ")"))
+ ((reverse-implication-p wff)
+ (princ "(") (print-wffs-in-tptp-format (args wff) subst " <= ") (princ ")"))
+ ((universal-quantification-p wff)
+ (princ "(! ") (print-varspecs (arg1 wff)) (princ " : ") (print-wff-in-tptp-format (arg2 wff) subst) (princ ")"))
+ ((existential-quantification-p wff)
+ (princ "(? ") (print-varspecs (arg1 wff)) (princ " : ") (print-wff-in-tptp-format (arg2 wff) subst) (princ ")"))
+ (t
+ (print-term-in-tptp-format wff subst))))
+ wff)
+
+(defun print-wffs-in-tptp-format (wffs subst sep)
+ (let ((first t))
+ (dolist (wff wffs)
+ (if first (setf first nil) (princ sep))
+ (print-wff-in-tptp-format wff subst))))
+
+(defun tptp-function-name (fn)
+ ;; if symbol begins with $$, return an alias if it is lower case and begins with $
+ (let* ((name (function-name fn))
+ (s (symbol-name name)))
+ (or (and (< 2 (length s))
+ (eql #\$ (char s 1))
+ (eql #\$ (char s 0))
+ (some #'(lambda (alias)
+ (let ((s (symbol-name alias)))
+ (and (< 1 (length s))
+ (eql #\$ (char s 0))
+ (neql #\$ (char s 1))
+ (notany #'upper-case-p s)
+ alias)))
+ (symbol-aliases fn)))
+ name)))
+
+(defun print-term-in-tptp-format (term &optional subst)
+ (dereference
+ term subst
+ :if-variable (progn
+ (cl:assert (top-sort? (variable-sort term)))
+ (mvlet (((values i j) (floor (variable-number term) 6)))
+ (princ (char "XYZUVW" j))
+ (unless (= 0 i)
+ (write i :radix nil :base 10))))
+ :if-constant (print-symbol-in-tptp-format (constant-name term))
+ :if-compound (let ((head (head term)))
+ (cond
+ ((eq *cons* head)
+ (princ "[")
+ (print-list-in-tptp-format term subst)
+ (princ "]"))
+ (t
+ (print-symbol-in-tptp-format (tptp-function-name head))
+ (princ "(")
+ (print-list-in-tptp-format (args (unflatten-term1 term subst)) subst)
+ (princ ")")))))
+ term)
+
+(defun print-varspecs (l)
+ (princ "[")
+ (let ((first t))
+ (dolist (x l)
+ (if first (setf first nil) (princ ", "))
+ (cond
+ ((variable-p x)
+ (print-term-in-tptp-format x))
+ (t
+ (print-term-in-tptp-format (first x))
+ (princ ": ")
+ (print-term-in-tptp-format (second x))))))
+ (princ "]"))
+
+(defun print-list-in-tptp-format (l subst)
+ (let ((first t))
+ (loop
+ (cond
+ ((dereference l subst :if-compound-cons t)
+ (if first (setf first nil) (princ ","))
+ (print-term-in-tptp-format (car l) subst)
+ (setf l (cdr l)))
+ ((null l)
+ (return))
+ (t
+ (princ "|")
+ (print-term-in-tptp-format l subst)
+ (return))))))
+
+(defun quote-tptp-symbol? (x &optional invert)
+ ;; returns t (or :escape) if symbol must be quoted as in 'a=b'
+ ;; returns :escape if some characters must be escaped as in 'a\'b'
+ ;; returns nil for , ,
+ (and (symbolp x)
+ (let* ((string (symbol-name x))
+ (len (length string)))
+ (or (= 0 len)
+ (let ((quote nil)
+ (dollar nil))
+ (dotimes (i len (or quote dollar))
+ (let ((ch (char string i)))
+ (cond
+ ((or (eql #\' ch) (eql #\\ ch))
+ (return :escape))
+ ((= 0 i)
+ (if (eql #\$ ch)
+ (setf dollar t)
+ (setf quote (if invert (not (upper-case-p ch)) (not (lower-case-p ch))))))
+ (dollar
+ (unless (and (= 1 i) (eql #\$ ch))
+ (setf dollar nil)
+ (setf quote (if invert (not (upper-case-p ch)) (not (lower-case-p ch))))))
+ ((not quote)
+ (setf quote (not (or (alphanumericp ch) (eql #\_ ch)))))))))))))
+
+(defun print-symbol-in-tptp-format (x)
+ (etypecase x
+ (symbol
+ (let* ((string (symbol-name x))
+ (invert (and nil (eq :invert (readtable-case *readtable*)) (not (iff (some #'upper-case-p string) (some #'lower-case-p string)))))
+ (quote (quote-tptp-symbol? x invert)))
+ (when quote
+ (princ #\'))
+ (cond
+ ((eq :escape quote)
+ (map nil
+ #'(lambda (ch)
+ (cond
+ ((or (eq #\' ch) (eq #\\ ch))
+ (princ #\\)
+ (princ ch))
+ (t
+ (princ (if invert (char-invert-case ch) ch)))))
+ string))
+ (invert
+ (princ x))
+ (t
+ (princ string)))
+ (when quote
+ (princ #\')))
+ x)
+ (number
+ (write x :radix nil :base 10))
+ (string
+ (prin1 x))))
+
+(defun tptp-sort-name (sort)
+ (let ((name (sort-name sort)))
+ (case name
+ (integer '|$int|)
+ (rational '|$rat|)
+ (real '|$real|)
+ (otherwise name))))
+
+(defvar *tptp-environment-variable*
+ #-mcl "/Users/mark/tptp"
+ #+mcl "Ame:Users:mark:tptp")
+
+(defun tptp-include-file-name (filename filespec)
+ ;; filename is file name argument of an include directive
+ ;; filespec specifies the file that contains the include directive
+ (or (let (pathname)
+ (cond
+ ((and (setf pathname (merge-pathnames (string filename) filespec))
+ (probe-file pathname))
+ pathname)
+ ((and *tptp-environment-variable*
+ (setf pathname (merge-pathnames (to-string *tptp-environment-variable* #-mcl "/" #+mcl ":" filename) filespec))
+ (probe-file pathname))
+ pathname)))
+ ;; as backup, use this older ad hoc code for TPTP/Problems & TPTP/Axioms directory structure
+ (let ((revdir (reverse (pathname-directory filespec))) v)
+ (cond
+ ((setf v (member "Problems" revdir :test #'string-equal))
+ (setf revdir (rest v)))
+ ((setf v (member-if #'(lambda (x) (and (stringp x) (<= 4 (length x)) (string-equal "TPTP" x :end2 4))) revdir))
+ (setf revdir v)))
+ (setf filename (string filename))
+ (loop
+ (let ((pos (position-if #'(lambda (ch) (or (eq '#\/ ch) (eq '#\: ch))) filename)))
+ (cond
+ ((null pos)
+ (return))
+ (t
+ (setf revdir (cons (subseq filename 0 pos) revdir))
+ (setf filename (subseq filename (+ pos 1)))))))
+ (make-pathname
+ :directory (nreverse revdir)
+ :name (pathname-name filename)
+ :type (pathname-type filename)))))
+
+(defun tptp-file-source-string (filename &optional (name none))
+ (if (eq none name)
+ (list '|file| filename)
+ (list '|file| filename name)))
+
+(defun mapnconc-tptp-file-forms (function filespec &key (if-does-not-exist :error) (package *package*))
+ (let ((*package* (find-or-make-package package))
+ (snark-infix-reader::*infix-operators* snark-infix-reader::*infix-operators*)
+ (snark-infix-reader::*prefix-operators* snark-infix-reader::*prefix-operators*)
+ (snark-infix-reader::*postfix-operators* snark-infix-reader::*postfix-operators*))
+ (declare-tptp-operators)
+ (labels
+ ((mapnconc-tptp-file-forms1 (filespec if-does-not-exist formula-selection)
+ (let ((filename (intern (namestring filespec)))
+ (tokens (with-open-file (stream filespec :direction :input :if-does-not-exist if-does-not-exist)
+ (tokenize stream :rationalize t)))
+ (result nil) result-last form)
+ (loop
+ (when (null tokens)
+ (return result))
+ (setf (values form tokens) (read-tptp-term1 tokens))
+ (ecase (if (consp form) (first form) form)
+ ((|cnf| |fof| |tff|)
+ (when (implies formula-selection (member (second form) formula-selection))
+ (ncollect (funcall function
+ (cond
+ ((eq '|type| (third form))
+ (input-tptp-type-declaration (fourth form)))
+ (t
+ (let ((ask-for-answer (and (consp (fourth form)) (eq 'tptp-double-question-mark (first (fourth form)))))
+ (ask-for-answer2 (member (third form) '(|question| |negated_question|))))
+ (let ((args nil))
+ (when (or ask-for-answer ask-for-answer2)
+ (setf args (list* :answer 'from-wff args)))
+ (let ((reason (tptp-to-snark-reason (third form))))
+ (unless (eq 'assertion reason)
+ (setf args (list* :reason reason args))))
+ (when (and (eq '|cnf| (first form)) (can-be-row-name (second form)))
+ (setf args (list* :name (second form) args)))
+ (setf args (list* :source (tptp-file-source-string filename (second form)) args))
+ (list* 'assertion (if ask-for-answer (cons 'exists (rest (fourth form))) (fourth form)) args))))))
+ result)))
+ (|include|
+ (cl:assert (implies (rrest form) (and (consp (third form)) (eq '$$list (first (third form))))))
+ (ncollect (mapnconc-tptp-file-forms1 (tptp-include-file-name (second form) filespec) :error (rest (third form))) result)))))))
+ (mapnconc-tptp-file-forms1 filespec if-does-not-exist nil))))
+
+(defun tptp-to-snark-reason (reason)
+ (case reason
+ (|axiom| 'assertion)
+ ((|assumption| |hypothesis|) 'assumption)
+ ((|negated_conjecture| |negated_question|) 'negated_conjecture)
+ ((|conjecture| |question|) 'conjecture)
+ (otherwise 'assertion)))
+
+(defun input-tptp-type-declaration (x)
+ (cond
+ ((and (consp x) (eq 'tptp-colon (first x)))
+ (cond
+ ((eq '|$tType| (third x))
+ ;; default declaration that can be overridden by subtype declaration
+ `(declare-tptp-sort ',(second x)))
+ ((symbolp (third x))
+ (if (eq '|$o| (third x))
+ `(declare-proposition ',(second x))
+ `(declare-constant ',(second x) :sort ',(third x))))
+ (t
+ (cl:assert (and (consp (third x))
+ (eq 'tptp-type-arrow (first (third x)))
+ (tptp-type-product-p (second (third x)))))
+ (let* ((argsorts (number-list (tptp-type-product-list (second (third x)))))
+ (arity (length argsorts)))
+ (if (eq '|$o| (third (third x)))
+ `(declare-relation ',(second x) ,arity :sort ',argsorts)
+ `(declare-function ',(second x) ,arity :sort ',(cons (third (third x)) argsorts)))))))
+ ((and (consp x) (eq 'tptp-subtype (first x)) (symbolp (second x)) (symbolp (third x)))
+ `(declare-subsort ',(second x) ',(third x) :subsorts-incompatible t))
+ (t
+ (error "Could not interpret type declaration ~S." x))))
+
+(defun tptp-type-product-p (x)
+ (or (symbolp x)
+ (and (consp x)
+ (eq 'tptp-type-product (pop x))
+ (consp x)
+ (tptp-type-product-p (pop x))
+ (consp x)
+ (tptp-type-product-p (pop x))
+ (null x))))
+
+(defun tptp-type-product-list (x)
+ (if (symbolp x)
+ (list x)
+ (append (tptp-type-product-list (second x))
+ (tptp-type-product-list (third x)))))
+
+(defun number-list (l &optional (n 1))
+ (if (endp l)
+ nil
+ (cons (list n (first l))
+ (number-list (rest l) (+ 1 n)))))
+
+(defvar *tptp-format* :tptp)
+
+;(defvar *tptp-input-directory* '(:absolute #+(and mcl (not openmcl)) "Macintosh HD" "Users" "mark" "tptp" "snark" "in"))
+;(defvar *tptp-input-directory-domains?* nil)
+;(defvar *tptp-input-file-type* "tptp")
+
+(defvar *tptp-input-directory* '(:absolute #+(and mcl (not openmcl)) "Macintosh HD" "Users" "mark" "tptp" "Problems"))
+(defvar *tptp-input-directory-has-domain-subdirectories* t)
+(defvar *tptp-input-file-type* "p")
+
+(defvar *tptp-output-directory* '(:absolute #+(and mcl (not openmcl)) "Macintosh HD" "Users" "mark" "tptp" "snark" "out"))
+(defvar *tptp-output-directory-has-domain-subdirectories* nil)
+(defvar *tptp-output-file-type* "out")
+
+(defun tptp-problem-pathname0 (name type directory has-domain-subdirectories)
+ (let ((pn (merge-pathnames (parse-namestring (to-string name "." type)) (make-pathname :directory directory))))
+ (if has-domain-subdirectories
+ (merge-pathnames (make-pathname :directory (append (pathname-directory pn) (list (subseq (pathname-name pn) 0 3)))) pn)
+ pn)))
+
+(defun tptp-problem-input-pathname (problem)
+ (tptp-problem-pathname0
+ problem
+ *tptp-input-file-type*
+ *tptp-input-directory*
+ *tptp-input-directory-has-domain-subdirectories*))
+
+(defun tptp-problem-output-pathname (problem)
+ (tptp-problem-pathname0
+ problem
+ *tptp-output-file-type*
+ *tptp-output-directory*
+ *tptp-output-directory-has-domain-subdirectories*))
+
+(defun do-tptp-problem (problem &key (format *tptp-format*) (use-coder nil) options)
+ (refute-file
+ (tptp-problem-input-pathname problem)
+ :use-coder use-coder
+ :format format
+ :options options
+ :ignore-errors t
+ :verbose t
+ :output-file (tptp-problem-output-pathname problem)
+ :if-exists nil))
+
+(defun do-tptp-problem0 (problem &key (format *tptp-format*) (use-coder nil) options)
+ (refute-file
+ (tptp-problem-input-pathname problem)
+ :use-coder use-coder
+ :format format
+ :options options))
+
+(defun do-tptp-problem1 (problem &key (format *tptp-format*) options)
+ (do-tptp-problem0
+ problem
+ :format format
+ :options (append '((agenda-length-limit nil)
+ (agenda-length-before-simplification-limit nil)
+ (use-hyperresolution t)
+ (use-ur-resolution t)
+ (use-paramodulation t)
+ (use-factoring :pos)
+ (use-literal-ordering-with-hyperresolution 'literal-ordering-p)
+ (use-literal-ordering-with-paramodulation 'literal-ordering-p)
+ (ordering-functions>constants t)
+ (assert-context :current)
+ (use-closure-when-satisfiable t)
+ (print-options-when-starting nil)
+ (use-variable-name-sorts nil)
+ (use-purity-test t)
+ (use-relevance-test t)
+ (snark-user::declare-tptp-symbols1))
+ options)))
+
+(defun translate-assertion-file-to-tptp-format (inputfilespec &optional outputfilespec &rest read-assertion-file-options)
+ (let ((snark-state (suspend-snark)))
+ (unwind-protect
+ (progn
+ (initialize)
+ (use-subsumption nil)
+ (use-simplification-by-units nil)
+ (use-simplification-by-equalities nil)
+ (print-options-when-starting nil)
+ (print-summary-when-finished nil)
+ (print-rows-when-derived nil)
+ (mapc #'eval (apply #'read-assertion-file inputfilespec read-assertion-file-options))
+ (closure)
+ (cond
+ (outputfilespec
+ (with-open-file (*standard-output* outputfilespec :direction :output)
+ (print-rows :format :tptp)))
+ (t
+ (print-rows :format :tptp))))
+ (resume-snark snark-state))
+ nil))
+
+(defun declare-tptp-operators ()
+ (declare-operator-syntax "<=>" :xfy 505 'iff)
+ (declare-operator-syntax "<~>" :xfy 505 'xor)
+ (declare-operator-syntax "=>" :xfy 504 'implies)
+ (declare-operator-syntax "<=" :xfy 504 'implied-by)
+ (declare-operator-syntax "&" :xfy 503 'and)
+ (declare-operator-syntax "~&" :xfy 503 'nand)
+ (declare-operator-syntax "|" :xfy 502 'or)
+ (declare-operator-syntax "~|" :xfy 502 'nor)
+;;(declare-operator-syntax "@" :yfx 501)
+ (declare-operator-syntax "*" :yfx 480 'tptp-type-product)
+;;(declare-operator-syntax "+" :yfx 480 'tptp-type-union)
+ (declare-operator-syntax ":" :xfy 450 'tptp-colon)
+ (declare-operator-syntax "~" :fy 450 'not)
+ (declare-operator-syntax "<<" :xfx 450 'tptp-subtype)
+ (declare-operator-syntax ">" :xfy 440 'tptp-type-arrow)
+ (declare-operator-syntax "=" :xfx 405 '=)
+ (declare-operator-syntax "!=" :xfx 405 '/=)
+;;(declare-operator-syntax "~=" :xfx 405)
+ (declare-operator-syntax "!" :fx 400 'forall)
+ (declare-operator-syntax "?" :fx 400 'exists)
+ (declare-operator-syntax "??" :fx 400 'tptp-double-question-mark)
+;;(declare-operator-syntax "^" :fx 400)
+;;(declare-operator-syntax ".." :xfx 400)
+;;(declare-operator-syntax "!" :xf 100)
+ nil)
+
+(defun tptp-to-snark-input (x)
+ (cond
+ ((atom x)
+ (cond
+ ((eq '|$true| x)
+ true)
+ ((eq '|$false| x)
+ false)
+ (t
+ (fix-tptp-symbol x))))
+ ((and (eq 'tptp-colon (first x))
+ (consp (second x))
+ (member (first (second x)) '(forall exists tptp-double-question-mark))
+ (consp (second (second x)))
+ (eq '$$list (first (second (second x)))))
+ ;; (: (quantifier (list . variables)) form) -> (quantifer variables form)
+ (list (first (second x)) (strip-colons (rest (second (second x)))) (tptp-to-snark-input (third x))))
+ (t
+ (lcons (fix-tptp-symbol (first x)) (tptp-to-snark-input-args (rest x)) x))))
+
+(defun fix-tptp-symbol (x)
+ ;; this is to allow users to input '?x' to create a constant ?x instead of a variable
+ ;; '?...' is tokenized as |^A?...| and '^A...' is tokenized as |^A^A...| by the infix reader
+ ;; this code removes the front ^A and wraps the symbol in a $$quote form if second character is ?
+ (let (name)
+ (cond
+ ((and (symbolp x) (< 0 (length (setf name (symbol-name x)))) (eql (code-char 1) (char name 0)))
+ (if (and (< 0 (length (setf name (subseq name 1)))) (eql (code-char 1) (char name 0)))
+ (intern name)
+ (list '$$quote (intern name))))
+ (t
+ x))))
+
+(defun tptp-to-snark-input-args (l)
+ (lcons (tptp-to-snark-input (first l))
+ (tptp-to-snark-input-args (rest l))
+ l))
+
+(defun strip-colons (l)
+ ;; (: var type) -> (var type) in quantifier variables
+ ;; no transformation yet for (: integer var) or (: integer (: var type))
+ (lcons (if (and (consp (first l))
+ (eq 'tptp-colon (first (first l)))
+ (symbolp (second (first l)))
+ (symbolp (third (first l))))
+ (rest (first l))
+ (first l))
+ (strip-colons (rest l))
+ l))
+
+(defun read-tptp-term1 (x &rest options)
+ (declare (dynamic-extent options))
+ (multiple-value-bind (term rest) (apply 'read-infix-term x (append options (list :rationalize t)))
+ (values (tptp-to-snark-input term) rest)))
+
+(defun read-tptp-term (x &rest options)
+ (declare (dynamic-extent options))
+ (let ((snark-infix-reader::*infix-operators* snark-infix-reader::*infix-operators*)
+ (snark-infix-reader::*prefix-operators* snark-infix-reader::*prefix-operators*)
+ (snark-infix-reader::*postfix-operators* snark-infix-reader::*postfix-operators*))
+ (declare-tptp-operators)
+ (apply 'read-tptp-term1 x options)))
+
+;;; tptp.lisp EOF
diff --git a/snark-20120808r02/src/trie-index.abcl b/snark-20120808r02/src/trie-index.abcl
new file mode 100644
index 0000000..5580c33
Binary files /dev/null and b/snark-20120808r02/src/trie-index.abcl differ
diff --git a/snark-20120808r02/src/trie-index.lisp b/snark-20120808r02/src/trie-index.lisp
new file mode 100644
index 0000000..a893a61
--- /dev/null
+++ b/snark-20120808r02/src/trie-index.lisp
@@ -0,0 +1,574 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: trie-index.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defvar *trie-index*)
+
+(defstruct (trie-index
+ (:constructor make-trie-index0 (entry-constructor))
+ (:copier nil))
+ (entry-constructor nil :read-only t) ;term->entry function for new entry insertion
+ (node-counter (make-counter 1) :read-only t)
+ (entry-counter (make-counter) :read-only t)
+ (top-node (make-trie-index-internal-node) :read-only t)
+ (retrieve-generalization-calls 0 :type integer) ;number of generalization retrieval calls
+ (retrieve-generalization-count 0 :type integer)
+ (retrieve-instance-calls 0 :type integer) ; " instance "
+ (retrieve-instance-count 0 :type integer)
+ (retrieve-unifiable-calls 0 :type integer) ; " unifiable "
+ (retrieve-unifiable-count 0 :type integer)
+ (retrieve-variant-calls 0 :type integer) ; " variant "
+ (retrieve-variant-count 0 :type integer)
+ (retrieve-all-calls 0 :type integer) ; " all "
+ (retrieve-all-count 0 :type integer))
+
+(defstruct (trie-index-internal-node
+ (:copier nil))
+ (variable-child-node nil) ;nil or node
+ (constant-indexed-child-nodes nil) ;constant# -> node sparse-vector
+ (function-indexed-child-nodes nil)) ;function# -> node sparse-vector
+
+(defstruct (trie-index-leaf-node
+ (:include sparse-vector (snark-sparse-array::default-value0 none :read-only t))
+ (:copier nil))
+ )
+
+(defmacro trie-index-leaf-node-entries (n)
+ n)
+
+(defstruct (index-entry
+ (:constructor make-index-entry (term))
+ (:copier nil))
+ (term nil :read-only t))
+
+(defun make-trie-index (&key (entry-constructor #'make-index-entry))
+ (setf *trie-index* (make-trie-index0 entry-constructor)))
+
+(definline trie-index-internal-node-variable-indexed-child-node (node &optional create internal)
+ (or (trie-index-internal-node-variable-child-node node)
+ (and create
+ (progn
+ (increment-counter (trie-index-node-counter *trie-index*))
+ (setf (trie-index-internal-node-variable-child-node node)
+ (if internal
+ (make-trie-index-internal-node)
+ (make-trie-index-leaf-node)))))))
+
+(definline trie-index-internal-node-constant-indexed-child-node (const node &optional create internal)
+ (let ((children (trie-index-internal-node-constant-indexed-child-nodes node)))
+ (unless children
+ (when create
+ (setf children (setf (trie-index-internal-node-constant-indexed-child-nodes node) (make-sparse-vector)))))
+ (and children
+ (let ((const# (constant-number const)))
+ (or (sparef children const#)
+ (and create
+ (progn
+ (increment-counter (trie-index-node-counter *trie-index*))
+ (setf (sparef children const#)
+ (if internal
+ (make-trie-index-internal-node)
+ (make-trie-index-leaf-node))))))))))
+
+(definline trie-index-internal-node-function-indexed-child-node (fn node &optional create internal)
+ (let ((children (trie-index-internal-node-function-indexed-child-nodes node)))
+ (unless children
+ (when create
+ (setf children (setf (trie-index-internal-node-function-indexed-child-nodes node) (make-sparse-vector)))))
+ (and children
+ (let ((fn# (function-number fn)))
+ (or (sparef children fn#)
+ (and create
+ (progn
+ (increment-counter (trie-index-node-counter *trie-index*))
+ (setf (sparef children fn#)
+ (if internal
+ (make-trie-index-internal-node)
+ (make-trie-index-leaf-node))))))))))
+
+(definline function-trie-index-lookup-args (fn term)
+ ;; fn = (head term) unless term is nil (not specified)
+ (ecase (function-index-type fn)
+ ((nil)
+ (cond
+ ((function-unify-code fn)
+ nil)
+ (t
+ (let ((arity (function-arity fn)))
+ (if (eq :any arity) (list (args term)) (args term))))))
+ (:commute
+ ;; index all arguments, lookup with first two in order and commuted
+ ;; (a b c d) -> 4, (c d a b), (c d (%index-or (a b) (b a))) for arity 4
+ ;; (a b c d) -> 3, ((c d) a b), ((c d) (%index-or (a b) (b a))) for arity :any
+ (let ((arity (function-arity fn)))
+ (let* ((args (args term))
+ (l (rest (rest args)))
+ (a (first args))
+ (b (second args))
+ (v (list (list '%index-or (if l (list a b) args) (list b a)))))
+ (cond
+ ((eq :any arity)
+ (cons l v))
+ (l
+ (append l v))
+ (t
+ v)))))
+ (:jepd
+ ;; index only first two arguments, lookup with first two in order and commuted
+ ;; (a b c) -> 2, (a b), ((%index-or (a b) (b a)))
+ (let* ((args (args term))
+ (a (first args))
+ (b (second args)))
+ (list (list '%index-or (list a b) (list b a)))))
+ (:hash-but-dont-index
+ nil)))
+
+(definline function-trie-index-args (fn term)
+ (ecase (function-index-type fn)
+ ((nil)
+ (cond
+ ((function-unify-code fn)
+ nil)
+ (t
+ (let ((arity (function-arity fn)))
+ (if (eq :any arity) (list (args term)) (args term))))))
+ (:commute
+ (let ((arity (function-arity fn)))
+ (let* ((args (args term))
+ (l (rest (rest args)))
+ (v (if l (list (first args) (second args)) args)))
+ (cond
+ ((eq :any arity)
+ (cons l v))
+ (l
+ (append l v))
+ (t
+ v)))))
+ (:jepd
+ (let ((args (args term)))
+ (list (first args) (second args))))
+ (:hash-but-dont-index
+ nil)))
+
+(definline function-trie-index-arity (fn)
+ (ecase (function-index-type fn)
+ ((nil)
+ (cond
+ ((function-unify-code fn)
+ 0)
+ (t
+ (let ((arity (function-arity fn)))
+ (if (eq :any arity) 1 arity)))))
+ (:commute
+ (let ((arity (function-arity fn)))
+ (if (eq :any arity) 3 arity)))
+ (:jepd
+ 2)
+ (:hash-but-dont-index
+ 0)))
+
+(defun simply-indexed-p (term &optional subst)
+ (dereference
+ term subst
+ :if-variable t
+ :if-constant t
+ :if-compound-cons (and (simply-indexed-p (carc term))
+ (simply-indexed-p (cdrc term)))
+ :if-compound-appl (and (let ((fn (heada term)))
+ (ecase (function-index-type fn)
+ ((nil)
+ (null (function-unify-code fn)))
+ (:commute
+ nil)
+ (:hash-but-dont-index
+ t)
+ (:jepd
+ nil)))
+ (dolist (arg (argsa term) t)
+ (unless (simply-indexed-p arg subst)
+ (return nil))))))
+
+(definline trie-index-build-path-for-terms (terms node internal)
+ (if internal
+ (dolist (x terms node)
+ (setf node (trie-index-build-path-for-term x node t)))
+ (dotails (l terms node)
+ (setf node (trie-index-build-path-for-term (first l) node (rest l))))))
+
+(defun trie-index-build-path-for-term (term node &optional internal)
+ (dereference
+ term nil
+ :if-variable (trie-index-internal-node-variable-indexed-child-node node t internal)
+ :if-constant (trie-index-internal-node-constant-indexed-child-node term node t internal)
+ :if-compound (let* ((head (head term))
+ (args (function-trie-index-args head term)))
+ (if (null args)
+ (trie-index-internal-node-function-indexed-child-node head node t internal)
+ (trie-index-build-path-for-terms args (trie-index-internal-node-function-indexed-child-node head node t t) internal)))))
+
+(definline trie-index-path-for-terms (terms path)
+ (dolist (x terms path)
+ (when (null (setf path (trie-index-path-for-term x path)))
+ (return nil))))
+
+(defun trie-index-path-for-term (term path)
+ (let ((node (first path)))
+ (dereference
+ term nil
+ :if-variable (let ((n (trie-index-internal-node-variable-indexed-child-node node)))
+ (and n (list* n 'variable path)))
+ :if-constant (let ((n (trie-index-internal-node-constant-indexed-child-node term node)))
+ (and n (list* n 'constant term path)))
+ :if-compound (let* ((head (head term))
+ (n (trie-index-internal-node-function-indexed-child-node head node)))
+ (and n (let ((args (function-trie-index-args head term)))
+ (if (null args)
+ (list* n 'function head path)
+ (trie-index-path-for-terms args (list* n 'function head path)))))))))
+
+(defun trie-index-insert (term &optional entry)
+ (let* ((trie-index *trie-index*)
+ (entries (trie-index-leaf-node-entries (trie-index-build-path-for-term term (trie-index-top-node trie-index)))))
+ (cond
+ ((null entry)
+ (prog->
+ (map-sparse-vector entries :reverse t ->* e)
+ (when (or (eql term (index-entry-term e)) (and (test-option38?) (equal-p term (index-entry-term e))))
+ (return-from trie-index-insert e)))
+ (setf entry (funcall (trie-index-entry-constructor trie-index) term)))
+ (t
+ (cl:assert (eql term (index-entry-term entry)))
+ (prog->
+ (map-sparse-vector entries :reverse t ->* e)
+ (when (eq entry e)
+ (return-from trie-index-insert e))
+ (when (or (eql term (index-entry-term e)) (and (test-option38?) (equal-p term (index-entry-term e))))
+ (error "There is already a trie-index entry for term ~A." term)))))
+ (increment-counter (trie-index-entry-counter trie-index))
+ (setf (sparef entries (nonce)) entry)))
+
+(defun trie-index-delete (term &optional entry)
+ (let* ((trie-index *trie-index*)
+ (path (trie-index-path-for-term term (list (trie-index-top-node trie-index)))))
+ (when path
+ (let* ((entries (trie-index-leaf-node-entries (pop path)))
+ (k (cond
+ ((null entry)
+ (prog->
+ (map-sparse-vector-with-indexes entries :reverse t ->* e k)
+ (when (eql term (index-entry-term e))
+ (return-from prog-> k))))
+ (t
+ (cl:assert (eql term (index-entry-term entry)))
+ (prog->
+ (map-sparse-vector-with-indexes entries :reverse t ->* e k)
+ (when (eq entry e)
+ (return-from prog-> k)))))))
+ (when k
+ (decrement-counter (trie-index-entry-counter trie-index))
+ (setf (sparef entries k) none)
+ (when (eql 0 (sparse-vector-count entries))
+ (let ((node-counter (trie-index-node-counter trie-index))
+ parent)
+ (loop
+ (ecase (pop path)
+ (function
+ (let ((k (function-number (pop path))))
+ (setf (sparef (trie-index-internal-node-function-indexed-child-nodes (setf parent (pop path))) k) nil)))
+ (constant
+ (let ((k (constant-number (pop path))))
+ (setf (sparef (trie-index-internal-node-constant-indexed-child-nodes (setf parent (pop path))) k) nil)))
+ (variable
+ (setf (trie-index-internal-node-variable-child-node (setf parent (pop path))) nil)))
+ (decrement-counter node-counter)
+ (unless (and (rest path) ;not top node
+ (null (trie-index-internal-node-variable-child-node parent))
+ (eql 0 (sparse-vector-count (trie-index-internal-node-function-indexed-child-nodes parent)))
+ (eql 0 (sparse-vector-count (trie-index-internal-node-constant-indexed-child-nodes parent))))
+ (return)))))
+ t)))))
+
+(defmacro map-trie-index-entries (&key if-variable if-constant if-compound count-call count-entry)
+ (declare (ignorable count-call count-entry))
+ `(labels
+ ((map-for-term (cc term node)
+ (dereference
+ term subst
+ :if-variable ,if-variable
+ :if-constant ,if-constant
+ :if-compound ,if-compound))
+ (map-for-terms (cc terms node)
+ (cond
+ ((null terms)
+ (funcall cc node))
+ (t
+ (let ((term (pop terms)))
+ (cond
+ ((and (consp term) (eq '%index-or (first term)))
+ (cond
+ ((null terms)
+ (prog->
+ (dolist (rest term) ->* terms1)
+ (map-for-terms terms1 node ->* node)
+ (funcall cc node)))
+ (t
+ (prog->
+ (dolist (rest term) ->* terms1)
+ (map-for-terms terms1 node ->* node)
+ (map-for-terms terms node ->* node)
+ (funcall cc node)))))
+ (t
+ (cond
+ ((null terms)
+ (prog->
+ (map-for-term term node ->* node)
+ (funcall cc node)))
+ (t
+ (prog->
+ (map-for-term term node ->* node)
+ (map-for-terms terms node ->* node)
+ (funcall cc node))))))))))
+ (skip-terms (cc n node)
+ (declare (type fixnum n))
+ (cond
+ ((= 1 n)
+ (progn
+ (prog->
+ (trie-index-internal-node-variable-indexed-child-node node ->nonnil node)
+ (funcall cc node))
+ (prog->
+ (trie-index-internal-node-constant-indexed-child-nodes node ->nonnil constant-indexed-children)
+ (map-sparse-vector constant-indexed-children ->* node)
+ (funcall cc node))
+ (prog->
+ (trie-index-internal-node-function-indexed-child-nodes node ->nonnil function-indexed-children)
+ (map-sparse-vector-with-indexes function-indexed-children ->* node fn#)
+ (skip-terms (function-trie-index-arity (symbol-numbered fn#)) node ->* node)
+ (funcall cc node))))
+ ((= 0 n)
+ (funcall cc node))
+ (t
+ (progn
+ (decf n)
+ (prog->
+ (trie-index-internal-node-variable-indexed-child-node node ->nonnil node)
+ (skip-terms n node ->* node)
+ (funcall cc node))
+ (prog->
+ (trie-index-internal-node-constant-indexed-child-nodes node ->nonnil constant-indexed-children)
+ (map-sparse-vector constant-indexed-children ->* node)
+ (skip-terms n node ->* node)
+ (funcall cc node))
+ (prog->
+ (trie-index-internal-node-function-indexed-child-nodes node ->nonnil function-indexed-children)
+ (map-sparse-vector-with-indexes function-indexed-children ->* node fn#)
+ (skip-terms (+ n (function-trie-index-arity (symbol-numbered fn#))) node ->* node)
+ (funcall cc node)))))))
+ (let ((trie-index *trie-index*))
+;; ,count-call
+ (cond
+ ((simply-indexed-p term subst)
+ (prog->
+ (map-for-term term (trie-index-top-node trie-index) ->* leaf-node)
+ (map-sparse-vector (trie-index-leaf-node-entries leaf-node) :reverse t ->* e)
+;; ,count-entry
+ (funcall cc e)))
+ (t
+ (prog->
+ (quote nil -> seen)
+ (map-for-term term (trie-index-top-node trie-index) ->* leaf-node)
+ (when (do ((s seen (cdrc s))) ;(not (member leaf-node seen))
+ ((null s)
+ t)
+ (when (eq leaf-node (carc s))
+ (return nil)))
+ (prog->
+ (map-sparse-vector (trie-index-leaf-node-entries leaf-node) :reverse t ->* e)
+;; ,count-entry
+ (funcall cc e))
+ (setf seen (cons leaf-node seen)))))))
+ nil))
+
+(defun map-trie-index-instance-entries (cc term subst)
+ (map-trie-index-entries
+ :count-call (incf (trie-index-retrieve-instance-calls trie-index))
+ :count-entry (incf (trie-index-retrieve-instance-count trie-index))
+ :if-variable (prog->
+ (skip-terms 1 node ->* node)
+ (funcall cc node))
+ :if-constant (prog->
+ (trie-index-internal-node-constant-indexed-child-node term node ->nonnil node)
+ (funcall cc node))
+ :if-compound (prog->
+ (head term -> head)
+ (trie-index-internal-node-function-indexed-child-node head node ->nonnil node)
+ (map-for-terms (function-trie-index-lookup-args head term) node ->* node)
+ (funcall cc node))))
+
+(defun map-trie-index-generalization-entries (cc term subst)
+ ;; in snark-20060805 vs. snark-20060806 test over TPTP,
+ ;; constant and compound lookup before variable lookup outperforms
+ ;; variable lookup before constant and compound lookup
+ (map-trie-index-entries
+ :count-call (incf (trie-index-retrieve-generalization-calls trie-index))
+ :count-entry (incf (trie-index-retrieve-generalization-count trie-index))
+ :if-variable (prog->
+ (trie-index-internal-node-variable-indexed-child-node node ->nonnil node)
+ (funcall cc node))
+ :if-constant (progn
+ (prog->
+ (trie-index-internal-node-constant-indexed-child-node term node ->nonnil node)
+ (funcall cc node))
+ (prog->
+ (trie-index-internal-node-variable-indexed-child-node node ->nonnil node)
+ (funcall cc node)))
+ :if-compound (progn
+ (prog->
+ (head term -> head)
+ (trie-index-internal-node-function-indexed-child-node head node ->nonnil node)
+ (map-for-terms (function-trie-index-lookup-args head term) node ->* node)
+ (funcall cc node))
+ (prog->
+ (trie-index-internal-node-variable-indexed-child-node node ->nonnil node)
+ (funcall cc node)))))
+
+(defun map-trie-index-unifiable-entries (cc term subst)
+ (map-trie-index-entries
+ :count-call (incf (trie-index-retrieve-unifiable-calls trie-index))
+ :count-entry (incf (trie-index-retrieve-unifiable-count trie-index))
+ :if-variable (prog->
+ (skip-terms 1 node ->* node)
+ (funcall cc node))
+ :if-constant (progn
+ (prog->
+ (trie-index-internal-node-variable-indexed-child-node node ->nonnil node)
+ (funcall cc node))
+ (prog->
+ (trie-index-internal-node-constant-indexed-child-node term node ->nonnil node)
+ (funcall cc node)))
+ :if-compound (progn
+ (prog->
+ (trie-index-internal-node-variable-indexed-child-node node ->nonnil node)
+ (funcall cc node))
+ (prog->
+ (head term -> head)
+ (trie-index-internal-node-function-indexed-child-node head node ->nonnil node)
+ (map-for-terms (function-trie-index-lookup-args head term) node ->* node)
+ (funcall cc node)))))
+
+(defun map-trie-index-variant-entries (cc term subst)
+ (map-trie-index-entries
+ :count-call (incf (trie-index-retrieve-variant-calls trie-index))
+ :count-entry (incf (trie-index-retrieve-variant-count trie-index))
+ :if-variable (prog->
+ (trie-index-internal-node-variable-indexed-child-node node ->nonnil node)
+ (funcall cc node))
+ :if-constant (prog->
+ (trie-index-internal-node-constant-indexed-child-node term node ->nonnil node)
+ (funcall cc node))
+ :if-compound (prog->
+ (head term -> head)
+ (trie-index-internal-node-function-indexed-child-node head node ->nonnil node)
+ (map-for-terms (function-trie-index-lookup-args head term) node ->* node)
+ (funcall cc node))))
+
+(defun map-trie-index-all-entries (cc)
+ (let ((term (make-variable nil 0))
+ (subst nil))
+ (map-trie-index-entries
+ :count-call (incf (trie-index-retrieve-all-calls trie-index))
+ :count-entry (incf (trie-index-retrieve-all-count trie-index))
+ :if-variable (prog->
+ (skip-terms 1 node ->* node)
+ (funcall cc node)))))
+
+(definline map-trie-index (cc type term &optional subst)
+ (ecase type
+ (:generalization
+ (map-trie-index-generalization-entries cc term subst))
+ (:instance
+ (map-trie-index-instance-entries cc term subst))
+ (:unifiable
+ (map-trie-index-unifiable-entries cc term subst))
+ (:variant
+ (map-trie-index-variant-entries cc term subst))))
+
+(defun print-trie-index (&key terms nodes)
+ (let ((index *trie-index*))
+ (mvlet (((:values current peak added deleted) (counter-values (trie-index-entry-counter index))))
+ (format t "~%; Trie-index has ~:D entr~:@P (~:D at peak, ~:D added, ~:D deleted)." current peak added deleted))
+ (mvlet (((:values current peak added deleted) (counter-values (trie-index-node-counter index))))
+ (format t "~%; Trie-index has ~:D node~:P (~:D at peak, ~:D added, ~:D deleted)." current peak added deleted))
+ (unless (eql 0 (trie-index-retrieve-variant-calls index))
+ (format t "~%; Trie-index retrieved ~:D variant term~:P in ~:D call~:P."
+ (trie-index-retrieve-variant-count index)
+ (trie-index-retrieve-variant-calls index)))
+ (unless (eql 0 (trie-index-retrieve-generalization-calls index))
+ (format t "~%; Trie-index retrieved ~:D generalization term~:P in ~:D call~:P."
+ (trie-index-retrieve-generalization-count index)
+ (trie-index-retrieve-generalization-calls index)))
+ (unless (eql 0 (trie-index-retrieve-instance-calls index))
+ (format t "~%; Trie-index retrieved ~:D instance term~:P in ~:D call~:P."
+ (trie-index-retrieve-instance-count index)
+ (trie-index-retrieve-instance-calls index)))
+ (unless (eql 0 (trie-index-retrieve-unifiable-calls index))
+ (format t "~%; Trie-index retrieved ~:D unifiable term~:P in ~:D call~:P."
+ (trie-index-retrieve-unifiable-count index)
+ (trie-index-retrieve-unifiable-calls index)))
+ (unless (eql 0 (trie-index-retrieve-all-calls index))
+ (format t "~%; Trie-index retrieved ~:D unrestricted term~:P in ~:D call~:P."
+ (trie-index-retrieve-all-count index)
+ (trie-index-retrieve-all-calls index)))
+ (when (or nodes terms)
+ (print-index* (trie-index-top-node index) nil terms))))
+
+(defun print-index* (node revpath print-terms)
+ (prog->
+ (map-index-leaf-nodes node revpath ->* node revpath)
+ (print-index-leaf-node node revpath print-terms)))
+
+(defmethod map-index-leaf-nodes (cc (node trie-index-internal-node) revpath)
+ (prog->
+ (trie-index-internal-node-variable-indexed-child-node node ->nonnil node)
+ (map-index-leaf-nodes node (cons '? revpath) ->* node revpath)
+ (funcall cc node revpath))
+ (prog->
+ (map-sparse-vector-with-indexes (trie-index-internal-node-constant-indexed-child-nodes node) ->* node const#)
+ (map-index-leaf-nodes node (cons (symbol-numbered const#) revpath) ->* node revpath)
+ (funcall cc node revpath))
+ (prog->
+ (map-sparse-vector-with-indexes (trie-index-internal-node-function-indexed-child-nodes node) ->* node fn#)
+ (map-index-leaf-nodes node (cons (symbol-numbered fn#) revpath) ->* node revpath)
+ (funcall cc node revpath)))
+
+(defmethod map-index-leaf-nodes (cc (node trie-index-leaf-node) revpath)
+ (funcall cc node revpath))
+
+(defmethod print-index-leaf-node ((node trie-index-leaf-node) revpath print-terms)
+ (with-standard-io-syntax2
+ (prog->
+ (trie-index-leaf-node-entries node -> entries)
+ (format t "~%; Path ~A has ~:D entr~:@P." (reverse revpath) (sparse-vector-count entries))
+ (when print-terms
+ (map-sparse-vector entries :reverse t ->* entry)
+ (format t "~%; ")
+ (print-term (index-entry-term entry))))))
+
+;;; trie-index.lisp EOF
diff --git a/snark-20120808r02/src/trie.abcl b/snark-20120808r02/src/trie.abcl
new file mode 100644
index 0000000..ac06a72
Binary files /dev/null and b/snark-20120808r02/src/trie.abcl differ
diff --git a/snark-20120808r02/src/trie.lisp b/snark-20120808r02/src/trie.lisp
new file mode 100644
index 0000000..92f80ce
--- /dev/null
+++ b/snark-20120808r02/src/trie.lisp
@@ -0,0 +1,101 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: trie.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; trie indexed by list of integers
+
+(defmacro make-trie-node ()
+ `(cons nil nil))
+
+(defmacro trie-node-data (node)
+ `(car ,node))
+
+(defmacro trie-node-branches (node)
+ `(cdr ,node))
+
+(defstruct (trie
+ (:copier nil))
+ (top-node (make-trie-node) :read-only t)
+ (node-counter (make-counter 1) :read-only t))
+
+(defun trieref (trie keys)
+ (do ((keys keys (rest keys))
+ (node (trie-top-node trie) (let ((b (trie-node-branches node)))
+ (if b (sparef b (first keys)) nil))))
+ ((or (null node) (null keys))
+ (if node (trie-node-data node) nil))))
+
+(defun (setf trieref) (data trie keys)
+ (if data
+ (do ((keys keys (rest keys))
+ (node (trie-top-node trie) (let ((b (trie-node-branches node))
+ (key (first keys)))
+ (if b
+ (or (sparef b key)
+ (setf (sparef b key)
+ (progn (increment-counter (trie-node-counter trie)) (make-trie-node))))
+ (setf (sparef (setf (trie-node-branches node) (make-sparse-vector)) key)
+ (progn (increment-counter (trie-node-counter trie)) (make-trie-node)))))))
+ ((null keys)
+ (setf (trie-node-data node) data)))
+ (labels
+ ((trie-delete (node keys)
+ ;; return t to delete this node from parent when data and branches are both empty
+ (cond
+ ((null keys)
+ (setf (trie-node-data node) nil)
+ (null (trie-node-branches node)))
+ (t
+ (let ((b (trie-node-branches node)))
+ (when b
+ (let* ((key (first keys))
+ (node1 (sparef b key)))
+ (when (and node1 (trie-delete node1 (rest keys)))
+ (decrement-counter (trie-node-counter trie))
+ (if (= 1 (sparse-vector-count b))
+ (progn (setf (trie-node-branches node) nil) (null (trie-node-data node)))
+ (setf (sparef b key) nil))))))))))
+ (trie-delete (trie-top-node trie) keys)
+ nil)))
+
+(defun trie-size (trie &optional count-only-data-nodes?)
+ (labels
+ ((ts (node)
+ (let ((size (if (and count-only-data-nodes? (null (trie-node-data node))) 0 1)))
+ (prog->
+ (trie-node-branches node ->nonnil b)
+ (map-sparse-vector b ->* node)
+ (setf size (+ size (trie-size node count-only-data-nodes?))))
+ size)))
+ (ts (trie-top-node trie))))
+
+(defun map-trie (function trie-or-node)
+ (labels
+ ((mt (node)
+ (let ((d (trie-node-data node)))
+ (when d
+ (funcall function d)))
+ (let ((b (trie-node-branches node)))
+ (when b
+ (map-sparse-vector #'mt b)))))
+ (declare (dynamic-extent #'mt))
+ (mt (if (trie-p trie-or-node) (trie-top-node trie-or-node) trie-or-node))))
+
+;;; trie.lisp EOF
diff --git a/snark-20120808r02/src/unify-bag.abcl b/snark-20120808r02/src/unify-bag.abcl
new file mode 100644
index 0000000..6df0a2b
Binary files /dev/null and b/snark-20120808r02/src/unify-bag.abcl differ
diff --git a/snark-20120808r02/src/unify-bag.lisp b/snark-20120808r02/src/unify-bag.lisp
new file mode 100644
index 0000000..871f701
--- /dev/null
+++ b/snark-20120808r02/src/unify-bag.lisp
@@ -0,0 +1,859 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: unify-bag.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun submultisetp (x y &key test key)
+ (cond
+ ((null x)
+ t)
+ ((null y)
+ nil)
+ (t
+ (setf y (copy-list y))
+ (dolist (x1 x t)
+ (cond
+ ((if test
+ (funcall test x1 (car y))
+ (eql x1 (car y)))
+ (setf y (cdr y)))
+ (t
+ (do ((l1 y l2)
+ (l2 (cdr y) (cdr l2)))
+ ((null l2) (return-from submultisetp nil))
+ (when (if key
+ (if test
+ (funcall test (funcall key x1) (funcall key (car l2)))
+ (eql (funcall key x1) (funcall key (car l2))))
+ (if test
+ (funcall test x1 (car l2))
+ (eql x1 (car l2))))
+ (rplacd l1 (cdr l2))
+ (return nil)))))))))
+
+(defun multiset-equal (x y &key test key)
+ (and (length= x y)
+ (submultisetp x y :test test :key key)))
+
+;;; special variables used by bag unification algorithm
+;;; and linear Diophantine equation basis algorithm
+
+(defvar maxx)
+(defvar maxy)
+
+(defmacro check-unify-bag-basis-size ()
+ `(when (< (unify-bag-basis-size-limit?) (incf unify-bag-basis-size))
+ (warn "Unify-bag basis size limit exceeded. No unifiers returned.")
+ (throw 'unify-bag-basis-quit
+ nil)))
+
+(defmacro a-coef (i)
+ `(svref a-coef-array ,i))
+
+(defmacro b-coef (j)
+ `(svref b-coef-array ,j))
+
+(defmacro x-term (i)
+ `(svref x-term-array ,i))
+
+(defmacro y-term (j)
+ `(svref y-term-array ,j))
+
+(defmacro x-bind (i)
+ `(svref x-bind-array ,i))
+
+(defmacro y-bind (j)
+ `(svref y-bind-array ,j))
+
+(defmacro xx-unify-p (i k)
+ ;; x-term.i,x-term.k unifiability (i 2 variables.
+ ;;
+ ;; Performance should be best when:
+ ;; maxb <= maxa.
+ ;; a1 >= a2 >= ... >= am.
+ ;; b1 <= b2 <= ... <= bn.
+ (let ((simple-solution (make-array (list nxcoefs nycoefs))) ;x-term.i,y-term.j unifiability
+ (x-term-ground-array (and (not all-x-term-ground) (make-array nxcoefs))) (new-all-x-term-ground t)
+ (y-term-ground-array (and (not all-y-term-ground) (make-array nycoefs))) (new-all-y-term-ground t)
+ (maxa 0) (maxb 0) (suma 0) (sumb 0)
+ (complex-solutions nil))
+ ;; recompute all-x-term-ground and all-y-term-ground in case formerly nonground terms are now ground
+ (loop for i below nxcoefs
+ as coef = (a-coef i)
+ do (incf suma coef)
+ (when (> coef maxa)
+ (setf maxa coef))
+ (unless all-x-term-ground
+ (let ((ground (frozen-p (x-term i) subst)))
+ (setf (x-term-ground-p i) ground)
+ (unless ground
+ (setf new-all-x-term-ground nil)))))
+ (loop for j below nycoefs
+ as coef = (b-coef j)
+ do (incf sumb coef)
+ (when (> coef maxb)
+ (setf maxb coef))
+ (unless all-y-term-ground
+ (let ((ground (frozen-p (y-term j) subst)))
+ (setf (y-term-ground-p j) ground)
+ (unless ground
+ (setf new-all-y-term-ground nil)))))
+ (setf all-x-term-ground new-all-x-term-ground)
+ (setf all-y-term-ground new-all-y-term-ground)
+ (when (cond
+ (all-x-term-ground
+ (or all-y-term-ground (and (eq none identity) (or (< suma sumb) (< maxa maxb)))))
+ (all-y-term-ground
+ (and (eq none identity) (or (> suma sumb) (> maxa maxb))))
+ (t
+ nil))
+ (throw 'unify-bag-basis-quit nil))
+ (dotimes (i nxcoefs) ;initialize xy-unify-p
+ (let* ((x-term.i (x-term i))
+ (x-term.i-ground (or all-x-term-ground (x-term-ground-p i))))
+ (dotimes (j nycoefs)
+ (let ((y-term.j (y-term j)))
+ (setf (xy-unify-p i j) (cond
+ ((and x-term.i-ground (or all-y-term-ground (y-term-ground-p j)))
+ nil)
+ ((and (embedding-variable-p x-term.i)
+ (embedding-variable-p y-term.j))
+ nil)
+ (t
+ (unify-p x-term.i y-term.j subst))))))))
+ (dotimes (i nxcoefs)
+ (unless (and (neq none identity) (not (or all-x-term-ground (x-term-ground-p i))) (unify-p (x-term i) identity subst))
+ (dotimes (j nycoefs (throw 'unify-bag-basis-quit nil))
+ (when (xy-unify-p i j)
+ (return nil)))))
+ (dotimes (j nycoefs)
+ (unless (and (neq none identity) (not (or all-y-term-ground (y-term-ground-p j))) (unify-p (y-term j) identity subst))
+ (dotimes (i nxcoefs (throw 'unify-bag-basis-quit nil))
+ (when (xy-unify-p i j)
+ (return nil)))))
+ (let ((xx-and-yy-unify-array (let ((ncoefs (if (>= nxcoefs nycoefs) nxcoefs nycoefs)))
+ (make-array (list ncoefs ncoefs))))
+ (unify-bag-basis-size 0))
+ (unless all-x-term-ground
+ (dotimes (i (- nxcoefs 1)) ;initialize xx-unify-p
+ (do* ((x-term.i (x-term i))
+ (x-term.i-ground (x-term-ground-p i))
+ (k (+ i 1) (+ k 1)))
+ ((eql k nxcoefs))
+ (let ((x-term.k (x-term k)))
+ (setf (xx-unify-p i k) (cond
+ ((and x-term.i-ground (x-term-ground-p k))
+ nil)
+ (t
+ (unify-p x-term.i x-term.k subst))))))))
+ (unless all-y-term-ground
+ (dotimes (j (- nycoefs 1)) ;initialize yy-unify-p
+ (do* ((y-term.j (y-term j))
+ (y-term.j-ground (y-term-ground-p j))
+ (k (+ j 1) (+ k 1)))
+ ((eql k nycoefs))
+ (let ((y-term.k (y-term k)))
+ (setf (yy-unify-p j k) (cond
+ ((and y-term.j-ground (y-term-ground-p k))
+ nil)
+ (t
+ (unify-p y-term.j y-term.k subst))))))))
+ (setf x-term-ground-array nil) ;done with x-term-ground-array
+ (setf y-term-ground-array nil) ;and y-term-ground-array now
+ (dotimes (i nxcoefs) ;store 2 variable solutions in simple-solution
+ (cond
+ ((unfrozen-variable-p (x-term i))
+ (dotimes (j nycoefs)
+ (when (xy-unify-p i j)
+ (cond
+ ((unfrozen-variable-p (y-term j))
+ (check-unify-bag-basis-size)
+ (let ((k (lcm (a-coef i) (b-coef j))))
+ (setf (aref simple-solution i j) (cons (truncate k (a-coef i))
+ (truncate k (b-coef j))))))
+ ((eql 0 (mod (b-coef j) (a-coef i)))
+ (check-unify-bag-basis-size)
+ (setf (aref simple-solution i j) (cons (truncate (b-coef j) (a-coef i)) 1)))))))
+ (t
+ (dotimes (j nycoefs)
+ (when (xy-unify-p i j)
+ (cond
+ ((unfrozen-variable-p (y-term j))
+ (cond
+ ((eql 0 (mod (a-coef i) (b-coef j)))
+ (check-unify-bag-basis-size)
+ (setf (aref simple-solution i j) (cons 1 (truncate (a-coef i) (b-coef j)))))))
+ ((eql (a-coef i) (b-coef j))
+ (check-unify-bag-basis-size)
+ #+openmcl ;workaround for openmcl-1.1-pre-070722
+ (setf (aref simple-solution i j) (cons 1 1))
+ #-openmcl
+ (setf (aref simple-solution i j) '(1 . 1)))))))))
+ (cond
+ ((and (<= maxa 1) (<= maxb 1)) ;no complex solutions if all coefficients <= 1
+ )
+ (t
+ (let (initial-maxsum
+ (maxx (make-array nxcoefs))
+ (maxy (make-array nycoefs))
+ (xsol (make-array nxcoefs))
+ (ysol (make-array nycoefs))
+ complex-solutions-tail)
+ (cond
+ (all-x-term-ground
+ (setf initial-maxsum suma)
+ (dotimes (i nxcoefs)
+ (setf (svref maxx i) 1))
+ (dotimes (j nycoefs)
+ (setf (svref maxy j) (if (unfrozen-variable-p (y-term j)) maxa 1))))
+ (all-y-term-ground
+ (setf initial-maxsum sumb)
+ (dotimes (j nycoefs)
+ (setf (svref maxy j) 1))
+ (dotimes (i nxcoefs)
+ (setf (svref maxx i) (if (unfrozen-variable-p (x-term i)) maxb 1))))
+ (t
+ (setf initial-maxsum 0)
+ (dotimes (i nxcoefs)
+ (setf (svref maxx i) (if (unfrozen-variable-p (x-term i)) maxb 1)))
+ (dotimes (j nycoefs)
+ (incf initial-maxsum
+ (* (setf (svref maxy j) (if (unfrozen-variable-p (y-term j)) maxa 1))
+ (b-coef j))))))
+ (labels
+ ((xloop (i sum maxsum)
+ (let ((i+1 (+ i 1)))
+ (setf (svref xsol i) 0)
+ (cond
+ ((< i+1 nxcoefs)
+ (xloop i+1 sum maxsum))
+ ((plusp sum)
+ (yloop 0 sum)))
+ (let ((maxval (svref maxx i)))
+ (when (plusp maxval)
+ (let ((a-coef.i (a-coef i)))
+ (incf sum a-coef.i)
+ (when (<= sum maxsum)
+ (do ((val 1 (+ val 1))
+ (maxx maxx)
+ (maxy maxy)
+ (newmaxx nil)
+ (newmaxy nil))
+ ((> val maxval))
+ (setf (svref xsol i) val)
+ (when (eql 1 val)
+ (do ((k (+ i 1) (+ k 1)))
+ ((eql k nxcoefs))
+ (when (or all-x-term-ground (not (xx-unify-p i k)))
+ (unless newmaxx
+ (setf maxx (copy-seq maxx))
+ (setf newmaxx t))
+ (setf (svref maxx k) 0)))
+ (dotimes (j nycoefs)
+ (let ((maxy.j (svref maxy j)))
+ (when (and (plusp maxy.j)
+ (not (xy-unify-p i j)))
+ (decf maxsum (* (b-coef j) maxy.j))
+ (unless newmaxy
+ (setf maxy (copy-seq maxy))
+ (setf newmaxy t))
+ (setf (svref maxy j) 0)))))
+ (dotimes (j nycoefs)
+ (let ((simple-solution.i.j (aref simple-solution i j)))
+ (when (consp simple-solution.i.j)
+ (when (eql val (car simple-solution.i.j))
+ (let ((maxy.j (svref maxy j))
+ (n (cdr simple-solution.i.j)))
+ (when (>= maxy.j n)
+ (let ((n-1 (- n 1)))
+ (decf maxsum (* (b-coef j) (- maxy.j n-1)))
+ (unless newmaxy
+ (setf maxy (copy-seq maxy))
+ (setf newmaxy t))
+ (setf (svref maxy j) n-1))))))))
+ (cond
+ ((< i+1 nxcoefs)
+ (xloop i+1 sum maxsum))
+ (t
+ (yloop 0 sum)))
+ (incf sum a-coef.i)
+ (when (> sum maxsum)
+ (return nil)))))))))
+
+ (yloop (j sum)
+ (let ((b-coef.j (b-coef j))
+ (maxval (svref maxy j))
+ (j+1 (+ j 1)))
+ (cond
+ ((eql j+1 nycoefs)
+ (let ((val (truncate sum b-coef.j)))
+ (when (and (<= val maxval)
+ (eql (* b-coef.j val) sum))
+ (setf (svref ysol j) val)
+ (filter))))
+ (t
+ (do ((val 0 (+ val 1))
+ (maxy maxy)
+ (newmaxy nil))
+ ((> val maxval))
+ (setf (svref ysol j) val)
+ (when (eql val 1)
+ (do ((k (+ j 1) (+ k 1)))
+ ((eql k nycoefs))
+ (when (or all-y-term-ground (not (yy-unify-p j k)))
+ (unless newmaxy
+ (setf maxy (copy-seq maxy))
+ (setf newmaxy t))
+ (setf (svref maxy k) 0))))
+ (yloop j+1 sum)
+ (decf sum b-coef.j)
+ (when (minusp sum)
+ (return nil)))))))
+
+ (filter nil
+ ;; eliminate solutions with only two variables
+ ;; and solutions that that are greater than a previous solution and are thus composable
+ ;; store the solution if it passes the tests
+;; (format t "~%" ) (dotimes (i nxcoefs) (format t "~4d" (svref xsol i)))
+;; (format t " ") (dotimes (j nycoefs) (format t "~4d" (svref ysol j)))
+ (cond
+ ((and
+ (loop for i from (+ 1 (loop for k below nxcoefs when (plusp (svref xsol k)) return k)) below nxcoefs
+ never (plusp (svref xsol i))) ;returns t if xsol has only one nonzero value
+ (loop for j from (+ 1 (loop for k below nycoefs when (plusp (svref ysol k)) return k)) below nycoefs
+ never (plusp (svref ysol j)))) ;returns t if ysol has only one nonzero value
+ )
+ ((loop for v in complex-solutions ;returns t if new solution is greater than previous one
+ thereis (and
+ (loop with xsol1 = (car v)
+ for i below nxcoefs
+ always (>= (svref xsol i) (svref xsol1 i)))
+ (loop with ysol1 = (cdr v)
+ for j below nycoefs
+ always (>= (svref ysol j) (svref ysol1 j)))))
+ )
+ (t
+ (check-unify-bag-basis-size)
+ (setf complex-solutions-tail
+ (if complex-solutions-tail
+ (setf (cdr complex-solutions-tail)
+ (cons (cons (copy-seq xsol)
+ (copy-seq ysol))
+ nil))
+ (setf complex-solutions
+ (cons (cons (copy-seq xsol)
+ (copy-seq ysol))
+ nil))))))))
+
+ (xloop 0 0 initial-maxsum)))))
+ (when (trace-unify-bag-basis?)
+ (print-unify-bag-basis nxcoefs nycoefs a-coef-array b-coef-array simple-solution complex-solutions))
+ (values simple-solution complex-solutions))))
+
+(declare-snark-option use-subsume-bag t t)
+
+(defun ac-unify (cc x y subst)
+ (unify-bag cc (args x) (args y) subst (head x)))
+
+(defun unify-bag (cc terms1 terms2 subst fn)
+ (cond
+ ((and (use-subsume-bag?) (frozen-p terms2 subst))
+ (subsume-bag cc terms1 terms2 subst fn))
+ ((and (use-subsume-bag?) (frozen-p terms1 subst))
+ (subsume-bag cc terms2 terms1 subst fn))
+ ((meter-unify-bag?)
+ (let ((start-time (get-internal-run-time)))
+ (unwind-protect
+ (let-options ((meter-unify-bag nil)) ;only meter top-level calls
+ (unify-bag* cc fn terms1 terms2 subst))
+ (let ((elapsed-time (/ (- (get-internal-run-time) start-time)
+ (float internal-time-units-per-second))))
+ (when (implies (numberp (meter-unify-bag?)) (<= (meter-unify-bag?) elapsed-time))
+ (format t "~2&~,3F seconds to unify-bag ~S and ~S."
+ elapsed-time
+ (flatten-term (make-compound* fn terms1) subst)
+ (flatten-term (make-compound* fn terms2) subst)))))))
+ (t
+ (unify-bag* cc fn terms1 terms2 subst))))
+
+(defun unify-bag* (cc fn terms1 terms2 subst)
+ (let ((identity (let ((id (function-identity2 fn)))
+ (cond
+ ((neq none id)
+ id)
+ (t
+ none))))
+ (nxcoefs 0) (nycoefs 0)
+ (x-term-is-ground nil) (y-term-is-ground nil)
+ (all-x-term-ground t) (all-y-term-ground t)
+ firsta firstb firstx firsty
+ (terms-and-counts (count-arguments fn terms2 subst (count-arguments fn terms1 subst) -1)))
+ (loop for tc in terms-and-counts
+ as count = (tc-count tc)
+ when (plusp count)
+ do (incf nxcoefs)
+ (unless firsta
+ (setf firsta count)
+ (setf firstx (tc-term tc)))
+ (when (or (not x-term-is-ground) all-x-term-ground)
+ (if (frozen-p (tc-term tc) subst)
+ (setf x-term-is-ground t)
+ (setf all-x-term-ground nil)))
+ else
+ when (minusp count)
+ do (incf nycoefs)
+ (unless firstb
+ (setf firstb (- count))
+ (setf firsty (tc-term tc)))
+ (when (or (not y-term-is-ground) all-y-term-ground)
+ (if (frozen-p (tc-term tc) subst)
+ (setf y-term-is-ground t)
+ (setf all-y-term-ground nil))))
+ (cond
+ ((and (eql 0 nxcoefs) (eql 0 nycoefs))
+ (funcall cc subst))
+ ((or (eql 0 nxcoefs) (eql 0 nycoefs))
+ (unless (eq none identity)
+ (unify-identity cc terms-and-counts subst identity)))
+ ((and (eql 1 nxcoefs) (eql 1 nycoefs)) ;unify-identity is an unimplemented possibility too
+ (cond
+ ((eql firsta firstb)
+ (unify cc firstx firsty subst))
+ ((eql 0 (rem firstb firsta))
+ (when (unfrozen-variable-p firstx)
+ (unify cc firstx (make-compound* fn (consn firsty nil (/ firstb firsta))) subst)))
+ ((eql 0 (rem firsta firstb))
+ (when (unfrozen-variable-p firsty)
+ (unify cc (make-compound* fn (consn firstx nil (/ firsta firstb))) firsty subst)))
+ (t
+ (when (and (unfrozen-variable-p firstx) (unfrozen-variable-p firsty))
+ (let ((n (lcm firsta firstb))
+ (newvar (make-variable (function-sort fn))))
+ (prog->
+ (unify firstx (make-compound* fn (consn newvar nil (/ n firsta))) subst ->* subst)
+ (unify cc firsty (make-compound* fn (consn newvar nil (/ n firstb))) subst)))))))
+ ((and (eql 1 nxcoefs) (eql 1 firsta)) ;unify-identity is an unimplemented possibility too
+ (when (unfrozen-variable-p firstx)
+ (unify cc firstx
+ (make-compound* fn (loop for tc in terms-and-counts
+ as count = (tc-count tc)
+ when (minusp count)
+ nconc (consn (tc-term tc) nil (- count))))
+ subst
+ )))
+ ((and (eql 1 nycoefs) (eql 1 firstb)) ;unify-identity is an unimplemented possibility too
+ (when (unfrozen-variable-p firsty)
+ (unify cc (make-compound* fn (loop for tc in terms-and-counts
+ as count = (tc-count tc)
+ when (plusp count)
+ nconc (consn (tc-term tc) nil count)))
+ firsty
+ subst
+ )))
+ (all-y-term-ground
+ (loop for tc in terms-and-counts
+ do (setf (tc-count tc) (- (tc-count tc))))
+ (unify-bag0 cc fn nycoefs nxcoefs terms-and-counts identity subst all-y-term-ground all-x-term-ground))
+ (t
+ (unify-bag0 cc fn nxcoefs nycoefs terms-and-counts identity subst all-x-term-ground all-y-term-ground)))))
+
+(defun sort-terms-and-counts (terms-and-counts subst)
+ ;; compounds < constants & frozen variables < unfrozen variables
+ (stable-sort terms-and-counts
+ (lambda (tc1 tc2)
+ (let ((x (tc-term tc1)) (y (tc-term tc2)))
+ (dereference
+ x subst
+ :if-variable (dereference y subst :if-variable (and (variable-frozen-p x)
+ (not (variable-frozen-p y))))
+ :if-constant (dereference y subst :if-variable (not (variable-frozen-p y)))
+ :if-compound (dereference y subst :if-variable t :if-constant t))))))
+
+(defun unify-bag0 (cc fn nxcoefs nycoefs terms-and-counts identity subst all-x-term-ground all-y-term-ground)
+ (let ((a-coef-array (make-array nxcoefs))
+ (b-coef-array (make-array nycoefs))
+ (x-term-array (make-array nxcoefs))
+ (y-term-array (make-array nycoefs)))
+ (loop for tc in (sort-terms-and-counts ;initialize a-coef-array, x-term-array
+ (loop for x in terms-and-counts when (plusp (tc-count x)) collect x)
+ subst)
+ as i from 0
+ do (setf (a-coef i) (tc-count tc))
+ (setf (x-term i) (tc-term tc)))
+ (loop for tc in (sort-terms-and-counts ;initialize b-coef-array, y-term-array
+ (loop for x in terms-and-counts when (minusp (tc-count x)) collect x)
+ subst)
+ as j from 0
+ do (setf (b-coef j) (- (tc-count tc)))
+ (setf (y-term j) (tc-term tc)))
+ (catch 'unify-bag-basis-quit
+ (mvlet (((values simple-solution complex-solutions)
+ (unify-bag-basis nxcoefs nycoefs a-coef-array b-coef-array x-term-array y-term-array identity subst
+ all-x-term-ground all-y-term-ground)))
+ (dotimes (i nxcoefs) (setf (a-coef i) nil)) ;reuse a-coef-array as x-bind-array
+ (dotimes (j nycoefs) (setf (b-coef j) nil)) ;reuse b-coef-array as y-bind-array
+ (unify-bag1 cc fn nxcoefs nycoefs a-coef-array b-coef-array x-term-array y-term-array subst identity
+ simple-solution complex-solutions)))))
+
+(defmacro nosol3x (s)
+ `(and (null (x-bind i)) ;x-term unmatched, but no later simple-solution applies
+ (or (eq none identity)
+ (not (unfrozen-variable-p (x-term i))))
+ (loop for j1 from ,s below nycoefs
+ as simple-solution.i.j1 = (aref simple-solution i j1)
+ never (and (consp simple-solution.i.j1)
+ (or (and (null (y-bind j1)) (eql 1 (cdr simple-solution.i.j1)))
+ (unfrozen-variable-p (y-term j1)))))))
+
+(defmacro nosol3y (s)
+ `(and (null (y-bind j)) ;y-term unmatched, but no later simple-solution applies
+ (or (eq none identity)
+ (not (unfrozen-variable-p (y-term j))))
+ (loop for i1 from ,s below nxcoefs
+ as simple-solution.i1.j = (aref simple-solution i1 j)
+ never (and (consp simple-solution.i1.j)
+ (or (and (null (x-bind i1)) (eql 1 (car simple-solution.i1.j)))
+ (unfrozen-variable-p (x-term i1)))))))
+
+(defmacro unify-bag2* (x subst)
+ `(if ,x
+ (unify-bag2 ,x ,subst)
+ (unless (or (loop for i below nxcoefs thereis (nosol3x 0))
+ (loop for j below nycoefs thereis (nosol3y 0)))
+ (unify-bag3 0 0 ,subst))))
+
+(defun unify-bag1 (cc fn
+ nxcoefs nycoefs
+ x-bind-array y-bind-array
+ x-term-array y-term-array subst
+ identity simple-solution complex-solutions)
+ (labels
+ ((unify-bag2 (complex-solns subst)
+ (let ((xsol (caar complex-solns))
+ (ysol (cdar complex-solns)))
+ (cond
+ ((and ;check that this solution can be added in
+ (loop for i below nxcoefs
+ as xsol.i = (svref xsol i)
+ never (and (neql 0 xsol.i)
+ (or (neql 1 xsol.i) (x-bind i))
+ (not (unfrozen-variable-p (x-term i)))))
+ (loop for j below nycoefs
+ as ysol.j = (svref ysol j)
+ never (and (neql 0 ysol.j)
+ (or (neql 1 ysol.j) (y-bind j))
+ (not (unfrozen-variable-p (y-term j))))))
+ (when (test-option8?)
+ (unless (and (neq none identity) ; AC1 UNIFICATION SUPPORT?
+ (loop for i below nxcoefs
+ never (and (plusp (svref xsol i))
+ (not (unfrozen-variable-p (x-term i)))))
+ (loop for j below nycoefs
+ never (and (plusp (svref ysol j))
+ (not (unfrozen-variable-p (y-term j))))))
+ (unify-bag2* (cdr complex-solns) subst)))
+ (let ((newvar (or (dotimes (j nycoefs)
+ (when (and (eql 1 (svref ysol j))
+ (not (unfrozen-variable-p (y-term j))))
+ (return (y-term j))))
+ (dotimes (i nxcoefs)
+ (when (and (eql 1 (svref xsol i))
+ (not (unfrozen-variable-p (x-term i))))
+ (return (x-term i))))
+ (make-variable (function-sort fn)))))
+ (dotimes (i nxcoefs)
+ (let ((xsol.i (svref xsol i)))
+ (unless (eql 0 xsol.i)
+ (setf (x-bind i) (consn newvar (x-bind i) xsol.i)))))
+ (dotimes (j nycoefs)
+ (let ((ysol.j (svref ysol j)))
+ (unless (eql 0 ysol.j)
+ (setf (y-bind j) (consn newvar (y-bind j) ysol.j)))))
+ (unify-bag2* (cdr complex-solns) subst))
+ (dotimes (i nxcoefs)
+ (let ((xsol.i (svref xsol i)))
+ (unless (eql 0 xsol.i)
+ (setf (x-bind i) (nthcdr xsol.i (x-bind i))))))
+ (dotimes (j nycoefs)
+ (let ((ysol.j (svref ysol j)))
+ (unless (eql 0 ysol.j)
+ (setf (y-bind j) (nthcdr ysol.j (y-bind j))))))
+ (unless (test-option8?)
+ (unless (and (neq none identity) ; AC1 UNIFICATION SUPPORT?
+ (loop for i below nxcoefs
+ never (and (plusp (svref xsol i))
+ (not (unfrozen-variable-p (x-term i)))))
+ (loop for j below nycoefs
+ never (and (plusp (svref ysol j))
+ (not (unfrozen-variable-p (y-term j))))))
+ (unify-bag2* (cdr complex-solns) subst)))
+ )
+ (t
+ (unify-bag2* (cdr complex-solns) subst)))))
+
+ (unify-bag3* (i j+1 subst)
+ (if (eql j+1 nycoefs)
+ (let ((i+1 (+ i 1)))
+ (if (eql i+1 nxcoefs)
+ (progn
+ (when (trace-unify-bag-bindings?)
+ (terpri-comment)
+ (format t "Unify-bag will try to unify")
+ (print-bindings x-term-array x-bind-array nxcoefs)
+ (print-bindings y-term-array y-bind-array nycoefs)
+ (terpri))
+ (bind-xterm 0 subst)) ;start unifying terms and bindings
+ (unify-bag3 i+1 0 subst)))
+ (unify-bag3 i j+1 subst)))
+
+ (unify-bag3 (i j subst)
+ (let ((simple-solution.i.j (aref simple-solution i j))
+ (j+1 (+ j 1)))
+ (cond
+ ((consp simple-solution.i.j)
+ (let ((m (car simple-solution.i.j))
+ (n (cdr simple-solution.i.j))
+ (x-term.i (x-term i))
+ (y-term.j (y-term j))
+ (x-bind.i (x-bind i))
+ (y-bind.j (y-bind j)))
+ (cond
+ ((and (or (and (null x-bind.i) (eql 1 m))
+ (unfrozen-variable-p x-term.i))
+ (or (and (null y-bind.j) (eql 1 n))
+ (unfrozen-variable-p y-term.j)))
+ (unless (and (neq none identity) ;AC1 UNIFICATION SUPPORT
+ (unfrozen-variable-p x-term.i)
+ (unfrozen-variable-p y-term.j))
+ (when (or x-bind.i y-bind.j)
+ (unless (or (nosol3x j+1) (nosol3y (+ i 1)))
+ (unify-bag3* i j+1 subst))))
+ (cond
+ ((and (null x-bind.i) (eql 1 m)
+ (null y-bind.j) (eql 1 n)
+ (not (unfrozen-variable-p x-term.i))
+ (not (unfrozen-variable-p y-term.j))
+ (not (special-unify-p x-term.i subst))
+ (not (special-unify-p y-term.j subst)))
+ (setf (x-bind i) (cons x-term.i nil))
+ (setf (y-bind j) (cons y-term.j nil))
+ (prog->
+ (unify x-term.i y-term.j subst ->* subst)
+ (unify-bag3* i j+1 subst)))
+ (t
+ (let ((newvar (cond
+ ((not (unfrozen-variable-p y-term.j))
+ y-term.j)
+ ((not (unfrozen-variable-p x-term.i))
+ x-term.i)
+ (t
+ (make-variable (function-sort fn))))))
+ (setf (x-bind i) (consn newvar x-bind.i m))
+ (setf (y-bind j) (consn newvar y-bind.j n))
+ (unify-bag3* i j+1 subst))))
+ (setf (x-bind i) x-bind.i)
+ (setf (y-bind j) y-bind.j)
+ (unless (and (neq none identity) ;AC1 UNIFICATION SUPPORT
+ (unfrozen-variable-p x-term.i)
+ (unfrozen-variable-p y-term.j))
+ (unless (or x-bind.i y-bind.j)
+ (unless (or (nosol3x j+1) (nosol3y (+ i 1)))
+ (unify-bag3* i j+1 subst)))))
+ (t
+ (unless (or (nosol3x j+1) (nosol3y (+ i 1)))
+ (unify-bag3* i j+1 subst))))))
+ (t
+ (unify-bag3* i j+1 subst)))))
+
+ (bind-xterm (i subst)
+ (prog->
+ (x-term i -> x-term.i)
+ (x-bind i -> x-bind.i)
+ (+ i 1 -> i+1)
+ (cond
+ ((eql i+1 nxcoefs) ;unify x-term and x-bind, then do (bind-yterm 0)
+ (cond
+ ((null x-bind.i)
+ (unify x-term.i identity subst ->* subst)
+ (bind-yterm 0 subst))
+ ((null (cdr x-bind.i))
+ (cond
+ ((eq x-term.i (car x-bind.i))
+ (bind-yterm 0 subst))
+ (t
+ (unify x-term.i (car x-bind.i) subst ->* subst)
+ (bind-yterm 0 subst))))
+ (t
+ (unify x-term.i (make-compound* fn x-bind.i) subst ->* subst)
+ (bind-yterm 0 subst))))
+ (t ;unify x-term and x-bind, then do (bind-xterm i+1)
+ (cond
+ ((null x-bind.i)
+ (unify x-term.i identity subst ->* subst)
+ (bind-xterm i+1 subst))
+ ((null (cdr x-bind.i))
+ (cond
+ ((eq x-term.i (car x-bind.i))
+ (bind-xterm i+1 subst))
+ (t
+ (unify x-term.i (car x-bind.i) subst ->* subst)
+ (bind-xterm i+1 subst))))
+ (t
+ (unify x-term.i (make-compound* fn x-bind.i) subst ->* subst)
+ (bind-xterm i+1 subst)))))))
+
+ (bind-yterm (j subst)
+ (prog->
+ (y-term j -> y-term.j)
+ (y-bind j -> y-bind.j)
+ (+ j 1 -> j+1)
+ (cond
+ ((eql j+1 nycoefs) ;unify y-term and y-bind, then do (funcall function)
+ (cond
+ ((null y-bind.j)
+ (unify cc y-term.j identity subst))
+ ((null (cdr y-bind.j))
+ (cond
+ ((eq y-term.j (car y-bind.j))
+ (funcall cc subst))
+ (t
+ (unify cc y-term.j (car y-bind.j) subst))))
+ (t
+ (unify cc y-term.j (make-compound* fn y-bind.j) subst))))
+ (t ;unify y-term and y-bind, then do (bind-yterm j+1)
+ (cond
+ ((null y-bind.j)
+ (unify y-term.j identity subst ->* subst)
+ (bind-yterm j+1 subst))
+ ((null (cdr y-bind.j))
+ (cond
+ ((eq y-term.j (car y-bind.j))
+ (bind-yterm j+1 subst))
+ (t
+ (unify y-term.j (car y-bind.j) subst ->* subst)
+ (bind-yterm j+1 subst))))
+ (t
+ (unify y-term.j (make-compound* fn y-bind.j) subst ->* subst)
+ (bind-yterm j+1 subst)))))))
+
+ (print-bindings (term bind ncoefs)
+ (dotimes (i ncoefs)
+ (format t "~% ~S & ~S" (svref term i) (make-a1-compound* fn identity (svref bind i))))))
+
+ (unify-bag2* complex-solutions subst)))
+
+(defun unify-identity (cc terms-and-counts subst identity)
+ (let ((x (first terms-and-counts))
+ (y (rest terms-and-counts)))
+ (cond
+ ((eql 0 (tc-count x))
+ (cond
+ ((null y)
+ (funcall cc subst))
+ (t
+ (unify-identity cc y subst identity))))
+ (t
+ (cond
+ ((null y)
+ (unify cc (tc-term x) identity subst))
+ (t
+ (prog->
+ (unify (tc-term x) identity subst ->* subst)
+ (unify-identity cc y subst identity))))))))
+
+;;; unify-bag.lisp EOF
diff --git a/snark-20120808r02/src/unify-vector.abcl b/snark-20120808r02/src/unify-vector.abcl
new file mode 100644
index 0000000..91c6ccd
Binary files /dev/null and b/snark-20120808r02/src/unify-vector.abcl differ
diff --git a/snark-20120808r02/src/unify-vector.lisp b/snark-20120808r02/src/unify-vector.lisp
new file mode 100644
index 0000000..eab1dd0
--- /dev/null
+++ b/snark-20120808r02/src/unify-vector.lisp
@@ -0,0 +1,135 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: unify-vector.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; unify-vector implements incomplete associative unification
+;;; complete associative unification is infinitary
+
+(defun first-and-rest-of-vector (terms subst fn identity)
+ (cond
+ ((null terms)
+ (values none nil))
+ (t
+ (let ((term (first terms)))
+ (dereference
+ term subst
+ :if-compound (when (eq fn (head term))
+ (return-from first-and-rest-of-vector
+ (first-and-rest-of-vector (append (args term) (rest terms)) subst fn identity)))
+ :if-constant (when (eql identity term)
+ (return-from first-and-rest-of-vector
+ (first-and-rest-of-vector (rest terms) subst fn identity))))
+ (values term (rest terms))))))
+
+(defun unify-identity-with-vector (cc terms subst fn identity)
+ (let ((vars nil) term)
+ (loop
+ (setf (values term terms) (first-and-rest-of-vector terms subst fn identity))
+ (cond
+ ((eq none term)
+ (dolist (var vars)
+ (setf subst (bind-variable-to-term var identity subst)))
+ (funcall cc subst)
+ (return))
+ ((and (unfrozen-variable-p term)
+ (constant-sort-p identity (variable-sort term)))
+ (pushnew term vars))
+ (t
+ (return))))))
+
+(defun unify-variable-with-vector (cc var arg args subst fn identity max)
+ ;; case where var matches arg plus one or more terms from args
+ (when (and (implies max (<= 2 max))
+ (subsort? (function-sort fn) (variable-sort var)))
+ (let ((l nil)
+ (count 0))
+ (loop
+ (cond
+ ((or (eq none arg)
+ (not (implies max (>= max count)))
+ (variable-occurs-p var arg subst))
+ (return))
+ (t
+ (setf l (append l (list arg)))
+ (when (<= 2 (incf count))
+ (funcall cc (bind-variable-to-term var (make-compound* fn l) subst) args))
+ (setf (values arg args) (first-and-rest-of-vector args subst fn identity))))))))
+
+(defun unify-variable-with-vector-max (args args2 subst fn identity)
+ (and (frozen-p args subst)
+ (- (+ 1 (argument-count-a1 fn args subst identity))
+ (argument-count-a1 fn args2 subst identity t))))
+
+(defun associative-unify (cc x y subst)
+ (unify-vector cc (args x) (args y) subst (head x)))
+
+(defun unify-vector (cc args1 args2 subst fn &optional (identity (function-identity2 fn)))
+ ;; terminating, incomplete associative unification--no variable splitting
+ (prog->
+ (first-and-rest-of-vector args1 subst fn identity -> firstargs1 restargs1)
+ (first-and-rest-of-vector args2 subst fn identity -> firstargs2 restargs2)
+ (cond
+ ((eql firstargs1 firstargs2)
+ (if (eq none firstargs1)
+ (funcall cc subst)
+ (unify-vector cc restargs1 restargs2 subst fn identity)))
+ ((eq none firstargs1)
+ (unless (eq none identity)
+ (unify-identity-with-vector cc args2 subst fn identity)))
+ ((eq none firstargs2)
+ (unless (eq none identity)
+ (unify-identity-with-vector cc args1 subst fn identity)))
+ ((and (null restargs1) (null restargs2))
+ (unify cc firstargs1 firstargs2 subst))
+ (t
+ (when (unfrozen-variable-p firstargs1)
+ (unless (eq none identity)
+ (when (constant-sort-p identity (variable-sort firstargs1))
+ (unify-vector cc restargs1 args2 (bind-variable-to-term firstargs1 identity subst) fn identity)))
+ (when restargs2
+ (unify-variable-with-vector
+ firstargs1 firstargs2 restargs2 subst fn identity
+ (unify-variable-with-vector-max restargs2 restargs1 subst fn identity)
+ ->* subst restargs2)
+ (unify-vector cc restargs1 restargs2 subst fn identity)))
+ (when (unfrozen-variable-p firstargs2)
+ (unless (eq none identity)
+ (when (constant-sort-p identity (variable-sort firstargs2))
+ (unify-vector cc args1 restargs2 (bind-variable-to-term firstargs2 identity subst) fn identity)))
+ (when restargs1
+ (unify-variable-with-vector
+ firstargs2 firstargs1 restargs1 subst fn identity
+ (unify-variable-with-vector-max restargs1 restargs2 subst fn identity)
+ ->* subst restargs1)
+ (unify-vector cc restargs1 restargs2 subst fn identity)))
+ (unless (and (or (null restargs1) (null restargs2)) (eq none identity))
+ (if (and (compound-appl-p firstargs1)
+ (compound-appl-p firstargs2)
+ (eq (heada firstargs1) (heada firstargs2))
+ (or (special-unify-p firstargs1 subst)
+ (special-unify-p firstargs2 subst)))
+ (prog->
+ (unify-vector restargs1 restargs2 subst fn ->* subst)
+ (unify cc firstargs1 firstargs2 subst))
+ (prog->
+ (unify firstargs1 firstargs2 subst ->* subst)
+ (unify-vector cc restargs1 restargs2 subst fn identity))))))))
+
+;;; unify-vector.lisp EOF
diff --git a/snark-20120808r02/src/unify.abcl b/snark-20120808r02/src/unify.abcl
new file mode 100644
index 0000000..dc4d05f
Binary files /dev/null and b/snark-20120808r02/src/unify.abcl differ
diff --git a/snark-20120808r02/src/unify.lisp b/snark-20120808r02/src/unify.lisp
new file mode 100644
index 0000000..50e3d27
--- /dev/null
+++ b/snark-20120808r02/src/unify.lisp
@@ -0,0 +1,234 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: unify.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(declaim (special *subsuming*))
+
+(defvar *unify-special* t)
+
+(defstruct special-unification-problem
+ algorithms
+ term1
+ term2)
+
+(defun unify (cc term1 term2 &optional subst)
+ (macrolet
+ ((unify-variable*constant (u v)
+ `(if (and (not (variable-frozen-p ,u))
+ (constant-sort-p ,v (variable-sort ,u)))
+ (setf subst (bind-variable-to-term ,u ,v subst))
+ (return-from unify)))
+ (unify-variable*compound (u v)
+ `(if (and (not (variable-frozen-p ,u))
+ (if (embedding-variable-p ,u)
+ (not (embedding-variable-occurs-p (args ,v) subst))
+ (not (variable-occurs-p ,u (args ,v) subst)))
+ (let ((s (variable-sort ,u)))
+ (or (top-sort? s)
+ (subsort? (compound-sort ,v subst) s))))
+ (setf subst (bind-variable-to-term ,u ,v subst))
+ (return-from unify))))
+ (prog ((args1 nil) (args2 nil) (moreterms1 nil) (moreterms2 nil) oterm1 oterm2
+ (special-unification-problems nil) algrthm temp1 temp2
+ (tracing (trace-unify?)))
+ (when tracing
+ (let ((cc1 cc))
+ (setf cc (lambda (subst)
+ (format t "~2%RESULT = ~A" subst)
+ (funcall cc1 subst)))))
+ loop
+ (when tracing
+ (format t "~2%TERM1 = ~A" term1)
+ (format t "; ARGS1 = ~A" args1)
+ (format t "; MORETERMS1 = ~A" moreterms1)
+ (format t "~1%TERM2 = ~A" term2)
+ (format t "; ARGS2 = ~A" args2)
+ (format t "; MORETERMS2 = ~A" moreterms2)
+ (format t "~1%SPECIAL = ~A"
+ (mapcar (lambda (x)
+ (make-compound
+ *=*
+ (special-unification-problem-term1 x)
+ (special-unification-problem-term2 x)))
+ special-unification-problems))
+ (format t "~1%SUBST = ~A" subst))
+ (cond
+ ((eql term1 term2)
+ )
+ (t
+ (dereference2
+ term1 term2 subst
+ :if-variable*variable (cond
+ ((eq term1 term2)
+ )
+ ((and (embedding-variable-p term1) (embedding-variable-p term2))
+ (return-from unify))
+ ((variable-frozen-p term1)
+ (if (and (not (variable-frozen-p term2))
+ (subsort? (variable-sort term1) (variable-sort term2)))
+ (setf subst (bind-variable-to-term term2 term1 subst))
+ (return-from unify)))
+ ((variable-frozen-p term2)
+ (if (subsort? (variable-sort term2) (variable-sort term1))
+ (setf subst (bind-variable-to-term term1 term2 subst))
+ (return-from unify)))
+ (t
+ (when (prefer-to-bind-p term2 term1)
+ (psetq term1 term2 term2 term1))
+ (let ((sterm1 (variable-sort term1))
+ (sterm2 (variable-sort term2)))
+ (cond
+ ((subsort? sterm2 sterm1)
+ (setf subst (bind-variable-to-term term1 term2 subst)))
+ ((subsort? sterm1 sterm2)
+ (setf subst (bind-variable-to-term term2 term1 subst)))
+ (t
+ (let ((sz (sort-intersection sterm1 sterm2)))
+ (if (null sz)
+ (return-from unify)
+ (let ((z (make-variable sz)))
+ (setf subst (bind-variable-to-term term2 z (bind-variable-to-term term1 z subst)))))))))))
+ :if-compound*compound (unless (eq term1 term2)
+ (cond
+ ((neq (setf temp1 (head term1)) (head term2))
+ (return-from unify))
+ ((eq *cons* temp1)
+ (unless (eq (setf temp1 (cdr term1)) (setf temp2 (cdr term2)))
+ (push temp1 moreterms1)
+ (push temp2 moreterms2))
+ (setf term1 (car term1) term2 (car term2))
+ (go loop))
+ (t
+ (setf oterm1 term1 oterm2 term2)
+ (setf term1 (argsa term1) term2 (argsa term2) algrthm (function-unify-code temp1))
+ (cond
+ ((not algrthm)
+ (cond
+ ((or args1 args2)
+ (push term1 moreterms1)
+ (push term2 moreterms2))
+ (t
+ (setf args1 term1)
+ (setf args2 term2))))
+ ((or (null *unify-special*) ;might-unify-p ignores some special-unification problems
+ (and (consp *unify-special*)
+ (not (subsetp algrthm *unify-special*))))
+ )
+ ((or args1 args2 moreterms1 special-unification-problems)
+ (push (make-special-unification-problem :algorithms algrthm :term1 oterm1 :term2 oterm2)
+ special-unification-problems))
+ (t
+ (dolist (fun algrthm)
+ (funcall fun cc oterm1 oterm2 subst))
+ (return-from unify))))))
+ :if-constant*constant (unless (eql term1 term2)
+ (return-from unify))
+ :if-variable*compound (unify-variable*compound term1 term2)
+ :if-compound*variable (unify-variable*compound term2 term1)
+ :if-variable*constant (unify-variable*constant term1 term2)
+ :if-constant*variable (unify-variable*constant term2 term1)
+ :if-compound*constant (return-from unify)
+ :if-constant*compound (return-from unify))))
+ ;; term1 and term2 have been unified
+ (cond
+ (args1
+ (cond
+ (args2
+ (setf term1 (pop args1))
+ (setf term2 (pop args2))
+ (go loop))
+ (t
+ (return-from unify))))
+ (args2
+ (return-from unify))
+ (moreterms1
+ (setf term1 (pop moreterms1))
+ (setf term2 (pop moreterms2))
+ (go loop))
+ (special-unification-problems
+ (unify-special cc special-unification-problems subst))
+ (t
+ (funcall cc subst))))))
+
+(defun unify-p (x y &optional subst)
+ (prog->
+ (unify x y subst ->* subst)
+ (declare (ignore subst))
+ (return-from unify-p t))
+ nil)
+
+(defun might-unify-p (x y &optional subst)
+ ;; returns nil if x and y are definitely not unifiable
+ ;; used by unify-bag to identify nonunifiable arguments
+ (let ((*unify-special* '(unify-commute)))
+ (unify-p x y subst)))
+
+(defun unifiers (x y &optional subst)
+ (let ((unifiers nil) unifiers-last)
+ (prog->
+ (unify x y subst ->* subst)
+ (collect subst unifiers))
+ unifiers))
+
+(defun unify-special (cc special-unification-problems subst)
+ (prog->
+ (first special-unification-problems -> x)
+ (rest special-unification-problems -> l)
+ (cond
+ ((null l)
+ (dolist (special-unification-problem-algorithms x) ->* fun)
+ (funcall fun (special-unification-problem-term1 x) (special-unification-problem-term2 x) subst ->* subst)
+ (funcall cc subst))
+ (t
+ (dolist (special-unification-problem-algorithms x) ->* fun)
+ (funcall fun (special-unification-problem-term1 x) (special-unification-problem-term2 x) subst ->* subst)
+ (unify-special cc l subst)))))
+
+(defun commutative-unify (cc x y subst)
+ (let* ((terms1 (args x))
+ (terms2 (args y))
+ (x1 (first terms1)) (l1 (rest terms1)) (y1 (first l1)) (z1 (rest l1))
+ (x2 (first terms2)) (l2 (rest terms2)) (y2 (first l2)) (z2 (rest l2)))
+ ;; terms1 = (x1 . l1) = (x1 y1 . z1)
+ ;; terms2 = (x2 . l2) = (x2 y2 . z2)
+ (cond
+ ((equal-p x1 x2 subst)
+ (unify cc l1 l2 subst))
+ ((equal-p x1 y2 subst)
+ (unify cc l1 (cons x2 z2) subst))
+ ((equal-p y1 x2 subst)
+ (unify cc (cons x1 z1) l2 subst))
+ ((equal-p y1 y2 subst)
+ (unify cc (cons x1 z1) (cons x2 z2) subst))
+ (t
+ (unify cc terms1 terms2 subst)
+ (unless (or (equal-p x1 y1 subst)
+ (equal-p x2 y2 subst))
+ (unify cc terms1 (list* y2 x2 z2) subst))))))
+
+(defun dont-unify (cc x y subst)
+ ;; can use this to prevent resolution of list-to-atom formulas, for example
+ (cond
+ (*subsuming*
+ (unify cc (args x) (args y) subst))
+ ((equal-p x y subst)
+ (funcall cc subst))))
+
+;;; unify.lisp EOF
diff --git a/snark-20120808r02/src/useful.abcl b/snark-20120808r02/src/useful.abcl
new file mode 100644
index 0000000..2caf25d
Binary files /dev/null and b/snark-20120808r02/src/useful.abcl differ
diff --git a/snark-20120808r02/src/useful.lisp b/snark-20120808r02/src/useful.lisp
new file mode 100644
index 0000000..4bfb77f
--- /dev/null
+++ b/snark-20120808r02/src/useful.lisp
@@ -0,0 +1,167 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: useful.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+#+lucid
+(defmacro lambda (&rest args)
+ `(function (lambda ,@args)))
+
+(defmacro setq-once (var form)
+ ;; return value of var if non-nil
+ ;; otherwise set var to value of form and return it
+ `(or ,var (setf ,var ,form) (error "setq-once value is nil.")))
+
+(definline assoc/eq (item alist)
+ #+lucid (assoc item alist) ;depending on the implementation,
+ #-lucid (assoc item alist :test #'eq) ;specifying EQ can make assoc faster
+ )
+
+#+lucid
+(defmacro declaim (&rest declaration-specifiers)
+ (list* 'eval-when
+ '(compile load eval)
+ (mapcar (lambda (x) `(proclaim ',x)) declaration-specifiers)))
+
+#+lucid
+(defmacro constantly (object)
+ (function (lambda (&rest args)
+ (declare (ignore args))
+ object)))
+
+(defun list-p (x)
+ ;; if x is a null terminated list, return its length
+ ;; otherwise return nil
+ (let ((n 0))
+ (declare (type integer n))
+ (loop
+ (cond
+ ((null x)
+ (return n))
+ ((atom x)
+ (return nil))
+ (t
+ (incf n)
+ (setf x (rest x)))))))
+
+(defvar *outputting-comment* nil)
+
+(definline comment* (output-stream)
+ (princ "; " output-stream)
+ (setf *outputting-comment* t) ;not stream specific bug
+ nil)
+
+(definline nocomment* (output-stream)
+ (declare (ignore output-stream))
+ (setf *outputting-comment* nil))
+
+(defun comment (&optional (output-stream *standard-output*))
+ (unless *outputting-comment*
+ (comment* output-stream)))
+
+(defun nocomment (&optional (output-stream *standard-output*))
+ (declare (ignorable output-stream))
+ (nocomment* output-stream))
+
+(defun terpri (&optional (output-stream *standard-output*))
+ (cl:terpri output-stream)
+ (nocomment* output-stream))
+
+(defun terpri-comment (&optional (output-stream *standard-output*))
+ (cl:terpri output-stream)
+ (comment* output-stream))
+
+(defvar *terpri-indent* 0)
+(declaim (type fixnum *terpri-indent*))
+
+(defun terpri-comment-indent (&optional (output-stream *standard-output*))
+ (cl:terpri output-stream)
+ (comment* output-stream)
+ (dotimes (dummy *terpri-indent*)
+ (declare (ignorable dummy))
+ (princ " " output-stream)))
+
+(defun terpri-indent (&optional (output-stream *standard-output*))
+ (cl:terpri output-stream)
+ (nocomment* output-stream)
+ (dotimes (dummy *terpri-indent*)
+ (declare (ignorable dummy))
+ (princ " " output-stream)))
+
+(defun unimplemented (&optional (datum "Unimplemented functionality.") &rest args)
+ (apply #'error datum args))
+
+(defvar *hash-dollar-package* nil)
+(defvar *hash-dollar-readtable* nil)
+
+(defun hash-dollar-reader (stream subchar arg)
+ ;; reads exp in #$exp into package (or *hash-dollar-package* *package*) with case preserved
+ (declare (ignore subchar arg))
+ (let ((*readtable* *hash-dollar-readtable*)
+ (*package* (or *hash-dollar-package* *package*)))
+ (read stream t nil t)))
+
+(defun initialize-hash-dollar-reader ()
+ (unless *hash-dollar-readtable*
+ (setf *hash-dollar-readtable* (copy-readtable nil))
+ (setf (readtable-case *hash-dollar-readtable*) :preserve)
+ (set-dispatch-macro-character #\# #\$ 'hash-dollar-reader *hash-dollar-readtable*)
+ (set-dispatch-macro-character #\# #\$ 'hash-dollar-reader)
+ t))
+
+(initialize-hash-dollar-reader)
+
+(defstruct (hash-dollar
+ (:constructor make-hash-dollar (symbol))
+ (:print-function print-hash-dollar-symbol3)
+ (:copier nil))
+ (symbol nil :read-only t))
+
+(defun print-hash-dollar-symbol3 (x stream depth)
+ (declare (ignore depth))
+ (let* ((symbol (hash-dollar-symbol x))
+ (*readtable* *hash-dollar-readtable*)
+ (*package* (or (symbol-package symbol) *package*)))
+ (princ "#$" stream)
+ (prin1 symbol stream)))
+
+(defun hash-dollar-symbolize (x)
+ (cond
+ ((consp x)
+ (cons (hash-dollar-symbolize (car x)) (hash-dollar-symbolize (cdr x))))
+ ((and (symbolp x) (not (null x)) #+ignore (not (keywordp x)))
+ (make-hash-dollar x))
+ (t
+ x)))
+
+(defun hash-dollar-prin1 (object &optional (output-stream *standard-output*))
+ (prin1 (hash-dollar-symbolize object) output-stream)
+ object)
+
+(defun hash-dollar-print (object &optional (output-stream *standard-output*))
+ (prog2
+ (terpri output-stream)
+ (hash-dollar-prin1 object output-stream)
+ (princ " " output-stream)))
+
+;;; in MCL, (hash-dollar-print '|a"b|) erroneously prints #$a"b instead of #$|a"b|
+;;; it appears that readtable-case = :preserve suppresses all escape character printing,
+;;; not just those for case
+
+;;; useful.lisp EOF
diff --git a/snark-20120808r02/src/variables.abcl b/snark-20120808r02/src/variables.abcl
new file mode 100644
index 0000000..87f8043
Binary files /dev/null and b/snark-20120808r02/src/variables.abcl differ
diff --git a/snark-20120808r02/src/variables.lisp b/snark-20120808r02/src/variables.lisp
new file mode 100644
index 0000000..0f7794c
--- /dev/null
+++ b/snark-20120808r02/src/variables.lisp
@@ -0,0 +1,77 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: variables.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defconstant $number-of-variable-blocks 1000)
+(defconstant $number-of-variables-per-block 6000)
+(defconstant $number-of-variables-in-blocks (* $number-of-variable-blocks $number-of-variables-per-block))
+
+(defvar *variables*) ;tables to translate (sort number) pairs to variables
+(defvar *next-variable-number* 0) ;next number to use for new unique variable
+(declaim (type integer *next-variable-number*))
+
+(defstruct (variable
+ (:constructor make-variable0 (sort number))
+ (:copier nil)
+ (:print-function print-variable))
+ number
+ sort)
+
+(defun initialize-variables ()
+ (setf *variables* (list (make-sparse-vector) (make-hash-table :test #'equal)))
+ (setf *next-variable-number* $number-of-variables-in-blocks)
+ nil)
+
+(defun make-variable (&optional (sort (top-sort)) number)
+ ;; if number is specified, return canonical variable for that sort and number
+ ;; if number is not specified, create a new unique variable with that sort
+ ;;
+ ;; variable identity must be testable by EQ
+ ;; this variable representation must also be understood by dereference
+ ;;
+ ;; don't create last variable in a block; when incrementing variable numbers,
+ ;; the following variable would be in the next block creating confusion
+ (cond
+ (number
+ (let ((vars (if (top-sort? sort)
+ (first *variables*)
+ (let ((v (second *variables*)))
+ (or (gethash sort v) (setf (gethash sort v) (make-sparse-vector)))))))
+ (or (sparef vars number)
+ (progn
+ (cl:assert (<= 0 number))
+ (cl:assert (< number $number-of-variables-in-blocks))
+ (cl:assert (/= 0 (mod (+ number 1) $number-of-variables-per-block)))
+ (setf (sparef vars number) (make-variable0 sort number))))))
+ (t
+ (setf *next-variable-number* (+ (setf number *next-variable-number*) 1))
+ (make-variable0 sort number))))
+
+
+(defun variable-block (n)
+ (declare (fixnum n))
+ (cl:assert (< 0 n $number-of-variable-blocks))
+ (* $number-of-variables-per-block n))
+
+(defun variable-block-0-p (varnum)
+ (declare (fixnum varnum))
+ (> $number-of-variables-per-block varnum))
+
+;;; variables.lisp EOF
diff --git a/snark-20120808r02/src/variant.abcl b/snark-20120808r02/src/variant.abcl
new file mode 100644
index 0000000..7cb0ab6
Binary files /dev/null and b/snark-20120808r02/src/variant.abcl differ
diff --git a/snark-20120808r02/src/variant.lisp b/snark-20120808r02/src/variant.lisp
new file mode 100644
index 0000000..8dab1b8
--- /dev/null
+++ b/snark-20120808r02/src/variant.lisp
@@ -0,0 +1,148 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: variant.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defvar *extended-variant* nil)
+
+(defun variant (cc x y &optional subst matches)
+ (macrolet
+ ((variant1 (x y)
+ `(let ((v (assoc ,x matches)))
+ (cond
+ ((null v)
+ (when (null (rassoc ,y matches))
+ (setf matches (acons ,x ,y matches))))
+ ((eq (cdr v) ,y)
+ t)))))
+ (dereference2
+ x y subst
+ :if-constant*constant (cond
+ (*extended-variant*
+ (when (and (same-sort? (constant-sort x) (constant-sort y))
+ (variant1 x y))
+ (funcall cc matches)))
+ ((eql x y)
+ (funcall cc matches)))
+ :if-compound*compound (let ((xhead (head x)) (yhead (head y)))
+ (cond
+ ((and *extended-variant*
+ (not (function-logical-symbol-p xhead))
+ (not (function-logical-symbol-p yhead))
+ (not (eq *cons* xhead))
+ (not (eq *cons* yhead))
+ (not (equality-relation-symbol-p xhead))
+ (not (equality-relation-symbol-p yhead)))
+ (when (variant1 xhead yhead)
+ (variantl cc (argsa x) (argsa y) subst matches)))
+ ((neq xhead yhead)
+ )
+ ((eq *cons* xhead)
+ (prog->
+ (variant (car x) (car y) subst matches ->* matches)
+ (variant cc (cdr x) (cdr y) subst matches)))
+ (t
+ (let ((funs (function-variant-code xhead)))
+ (if funs
+ (dolist (fun funs)
+ (funcall fun cc x y subst matches))
+ (variantl cc (argsa x) (argsa y) subst matches))))))
+ :if-variable*variable (when (and (same-sort? (variable-sort x) (variable-sort y))
+ (variant1 x y))
+ (funcall cc matches)))))
+
+(defun variantl (cc x y subst matches)
+ (cond
+ ((null x)
+ (when (null y)
+ (funcall cc matches)))
+ ((rest x)
+ (when (rest y)
+ (prog->
+ (variantl (rest x) (rest y) subst matches ->* matches)
+ (variant cc (first x) (first y) subst matches))))
+ ((null (rest y))
+ (variant cc (first x) (first y) subst matches))))
+
+(defun variant-p (x y &optional subst)
+ (prog->
+ (variant x y subst ->* matches)
+ (return-from variant-p (or matches t)))
+ nil)
+
+(defun variant-bag (cc x y subst matches)
+ (variant-bag0 cc (args x) (args y) subst matches (head x)))
+
+(defun variant-bag0 (cc terms1 terms2 subst matches fn)
+ (let ((counts1 (count-arguments fn terms1 subst))
+ (counts2 (count-arguments fn terms2 subst)))
+ (cond
+ ((null counts1)
+ (when (null counts2)
+ (funcall cc subst)))
+ ((null counts2)
+ )
+ ((null (cdr counts1))
+ (when (null (cdr counts2))
+ (variant cc (tc-term (car counts1)) (tc-term (car counts2)) subst matches)))
+ ((null (cdr counts2))
+ )
+ ((and (length= (cddr counts1) (cddr counts2))
+ (submultisetp (let (w)
+ (dolist (tc counts1)
+ (push (tc-count tc) w))
+ w)
+ (let (w)
+ (dolist (tc counts2)
+ (push (tc-count tc) w))
+ w)))
+ (variant-bag* cc counts1 counts2 subst matches)))))
+
+(defun variant-bag* (cc counts1 counts2 subst matches)
+ (let ((count1 (car counts1)))
+ (dolist (count2 counts2)
+ (when (eql (tc-count count1) (tc-count count2))
+ (cond
+ ((null (cdr counts1))
+ (variant cc (tc-term count1) (tc-term count2) subst matches))
+ (t
+ (prog->
+ (variant (tc-term count1) (tc-term count2) subst matches ->* matches)
+ (variant-bag* cc (cdr counts1) (remove count2 counts2) subst matches))))))))
+
+(defun variant-commute (cc x y subst matches)
+ ;; It is assumed that commutative functions that are not assocative
+ ;; have at least two arguments only the first two of which commute.
+ (let ((terms1 (args x))
+ (terms2 (args y)))
+ (variantl cc terms1 terms2 subst matches)
+ (variantl cc terms1 (list* (second terms2) (first terms2) (cddr terms2)) subst matches)))
+
+(defun variant-vector (cc x y subst matches)
+ (let ((fn (head x))
+ (terms1 (args x))
+ (terms2 (args y)))
+ (and (or *extended-variant* (similar-argument-list-ac1-p fn terms1 terms2 subst))
+ (variantl cc
+ (argument-list-a1 fn terms1 subst)
+ (argument-list-a1 fn terms2 subst)
+ subst
+ matches))))
+
+;;; variant.lisp EOF
diff --git a/snark-20120808r02/src/weight.abcl b/snark-20120808r02/src/weight.abcl
new file mode 100644
index 0000000..1fef2e0
Binary files /dev/null and b/snark-20120808r02/src/weight.abcl differ
diff --git a/snark-20120808r02/src/weight.lisp b/snark-20120808r02/src/weight.lisp
new file mode 100644
index 0000000..cdb117a
--- /dev/null
+++ b/snark-20120808r02/src/weight.lisp
@@ -0,0 +1,197 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: weight.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+(defun depth (x &optional subst head-if-associative)
+ (dereference
+ x subst
+ :if-constant 0
+ :if-variable 0
+ :if-compound-cons (+ 1 (max (depth (carc x) subst) (depth (cdrc x) subst)))
+ :if-compound-appl (let ((head (heada x)))
+ (cond
+ ((eq head head-if-associative)
+ (loop for x1 in (argsa x) maximize (depth x1 subst head)))
+ ((function-associative head)
+ (+ 1 (loop for x1 in (argsa x) maximize (depth x1 subst head))))
+ (t
+ (+ 1 (loop for x1 in (argsa x) maximize (depth x1 subst))))))))
+
+(defun mindepth (x &optional subst head-if-associative)
+ (dereference
+ x subst
+ :if-constant 0
+ :if-variable 0
+ :if-compound-cons (+ 1 (min (mindepth (carc x) subst) (mindepth (cdrc x) subst)))
+ :if-compound-appl (let ((head (heada x)))
+ (cond
+ ((eq head head-if-associative)
+ (loop for x1 in (argsa x) minimize (mindepth x1 subst head)))
+ ((function-associative head)
+ (+ 1 (loop for x1 in (argsa x) minimize (mindepth x1 subst head))))
+ (t
+ (+ 1 (loop for x1 in (argsa x) minimize (mindepth x1 subst))))))))
+
+(definline constantly-one (x)
+ (declare (ignore x))
+ 1)
+
+(definline constantly-nil (x)
+ (declare (ignore x))
+ nil)
+
+(definline variable-weight1 (variable)
+ (let ((w (variable-weight?)))
+ (if (numberp w) w (funcall w variable))))
+
+(defmacro weight-macro (weight-fn constant-weight-fn variable-weight-fn function-weight-fn function-weight-code-fn)
+ `(dereference
+ x subst
+ :if-constant (,constant-weight-fn x)
+ :if-variable (,variable-weight-fn x)
+ :if-compound-cons (+ (,weight-fn (carc x) subst) (,weight-fn (cdrc x) subst) (,function-weight-fn *cons*))
+ :if-compound-appl (let ((head (heada x)))
+ (dolist (fun (,function-weight-code-fn head)
+ (cond
+ ((function-associative head) ;do something different for zero or one args?
+ (let ((args (argsa x)))
+ (+ (loop for x1 in args sum (,weight-fn x1 subst))
+ (* (,function-weight-fn head) (+ 1 (length (rrest args)))))))
+ (t
+ (+ (loop for x1 in (argsa x) sum (,weight-fn x1 subst))
+ (,function-weight-fn head)))))
+ (let ((v (funcall fun x subst)))
+ (unless (or (null v) (eq none v))
+ (return v)))))))
+
+(defun weight (x &optional subst)
+ (weight-macro
+ weight
+ constant-weight
+ variable-weight1
+ function-weight
+ function-weight-code))
+
+(defun size (x &optional subst)
+ (weight-macro
+ size
+ constantly-one
+ constantly-one
+ constantly-one
+ constantly-nil))
+
+(defun weigh-first-two-arguments (x &optional subst)
+ (dereference
+ x subst
+ :if-compound-appl (let ((args (argsa x)))
+ (and (rest args)
+ (+ (weight (first args) subst)
+ (weight (second args) subst)
+ (function-weight (heada x)))))))
+
+(defun maximum-argument-weight (args subst head-if-associative)
+ (loop for arg in args
+ maximize (if (and head-if-associative
+ (dereference
+ arg subst
+ :if-compound-appl (eq head-if-associative (heada arg))))
+ (maximum-argument-weight (argsa arg) subst head-if-associative)
+ (weight arg subst))))
+
+(defun weightm (x &optional subst)
+ (dereference
+ x subst
+ :if-constant (weight x)
+ :if-variable (weight x)
+ :if-compound-cons (+ (max (weight (carc x) subst) (weight (cdrc x) subst)) (function-weight *cons*))
+ :if-compound-appl (let ((head (heada x)))
+ (+ (maximum-argument-weight (argsa x) subst (and (function-associative head) head))
+ (function-weight head)))))
+
+(defstruct (symbol-count
+ (:type list)
+ (:constructor make-symbol-count ())
+ (:copier nil))
+ (total 0 :type fixnum)
+ (alist nil))
+
+(defun symbol-count (x &optional subst scount)
+ ;; computes the total number of symbols in x and
+ ;; an alist for counts of constants and functions in x
+ ;; count 2 f's for f(x,y,z)=f(f(x,y),z)=f(x,f(y,z))
+ (macrolet
+ ((symbol-count1 (symbol count)
+ `(let* ((count ,count)
+ (alist (symbol-count-alist (or scount (setf scount (make-symbol-count)))))
+ (v (assoc ,symbol alist)))
+ (if v
+ (incf (cdr v) count)
+ (setf (symbol-count-alist scount) (acons ,symbol count alist)))
+ (incf (symbol-count-total scount) count))))
+ (dereference
+ x subst
+ :if-constant (symbol-count1 x 1)
+ :if-compound-cons (progn
+ (symbol-count1 *cons* 1)
+ (symbol-count (carc x) subst scount)
+ (symbol-count (cdrc x) subst scount))
+ :if-compound-appl (let ((head (heada x))
+ (args (argsa x)))
+ (symbol-count1 head (if (function-associative head)
+ (+ 1 (length (rrest args)))
+ 1))
+ (dolist (x1 args)
+ (symbol-count x1 subst scount)))
+ :if-variable (incf (symbol-count-total scount)))
+ scount))
+
+(definline symbol-count-not-greaterp1 (scount1 scount2)
+ (let ((alist2 (symbol-count-alist scount2)))
+ (dolist (v1 (symbol-count-alist scount1) t)
+ (let ((v2 (assoc (carc v1) alist2)))
+ (when (or (null v2) (> (the fixnum (cdrc v1)) (the fixnum (cdrc v2))))
+ (return nil))))))
+
+(defun symbol-count-not-greaterp (scount1 scount2)
+ (and (not (> (symbol-count-total scount1) (symbol-count-total scount2)))
+ (symbol-count-not-greaterp1 scount1 scount2)))
+
+(defun wff-symbol-counts (wff &optional subst)
+ (let ((poscount nil)
+ (negcount nil))
+ (prog->
+ (map-atoms-in-wff wff ->* atom polarity)
+ (unless (eq :neg polarity)
+ (setf poscount (symbol-count atom subst poscount)))
+ (unless (eq :pos polarity)
+ (setf negcount (symbol-count atom subst negcount))))
+ (list poscount negcount)))
+
+(defun wff-symbol-counts-not-greaterp (scounts1 scounts2)
+ (let ((poscount1 (first scounts1))
+ (negcount1 (second scounts1))
+ poscount2
+ negcount2)
+ (and (implies poscount1 (and (setf poscount2 (first scounts2)) (not (> (symbol-count-total poscount1) (symbol-count-total poscount2)))))
+ (implies negcount1 (and (setf negcount2 (second scounts2)) (not (> (symbol-count-total negcount1) (symbol-count-total negcount2)))))
+ (implies poscount1 (symbol-count-not-greaterp1 poscount1 poscount2))
+ (implies negcount1 (symbol-count-not-greaterp1 negcount1 negcount2)))))
+
+;;; weight.lisp EOF
diff --git a/snark-20120808r02/src/wffs.abcl b/snark-20120808r02/src/wffs.abcl
new file mode 100644
index 0000000..099805b
Binary files /dev/null and b/snark-20120808r02/src/wffs.abcl differ
diff --git a/snark-20120808r02/src/wffs.lisp b/snark-20120808r02/src/wffs.lisp
new file mode 100644
index 0000000..2468763
--- /dev/null
+++ b/snark-20120808r02/src/wffs.lisp
@@ -0,0 +1,680 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: wffs.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel .
+
+(in-package :snark)
+
+;;; wff = well-formed formula
+;;; atom = atomic fomula
+
+(defun map-atoms-in-clause (cc wff0)
+ (labels
+ ((map-atoms (wff polarity)
+ (dereference
+ wff nil
+ :if-constant (cond
+ ((eq true wff)
+ (when (eq :pos polarity)
+ (not-clause-error wff0)))
+ ((eq false wff)
+ (when (eq :neg polarity)
+ (not-clause-error wff0)))
+ (t
+ (funcall cc wff polarity)))
+ :if-variable (not-clause-error wff0)
+ :if-compound-cons (not-clause-error wff0)
+ :if-compound-appl (case (function-logical-symbol-p (heada wff))
+ ((nil)
+ (funcall cc wff polarity))
+ (not
+ (map-atoms (arg1a wff) (if (eq :pos polarity) :neg :pos)))
+ (and
+ (if (eq :pos polarity)
+ (not-clause-error wff0)
+ (dolist (arg (argsa wff))
+ (map-atoms arg :neg))))
+ (or
+ (if (eq :neg polarity)
+ (not-clause-error wff0)
+ (dolist (arg (argsa wff))
+ (map-atoms arg :pos))))
+ (implies
+ (if (eq :neg polarity)
+ (not-clause-error wff0)
+ (let ((args (argsa wff)))
+ (map-atoms (first args) :neg)
+ (map-atoms (second args) :pos))))
+ (implied-by
+ (if (eq :neg polarity)
+ (not-clause-error wff0)
+ (let ((args (argsa wff)))
+ (map-atoms (first args) :pos)
+ (map-atoms (second args) :neg))))))))
+ (map-atoms wff0 :pos)))
+
+(defun map-atoms-in-wff (cc wff &optional (polarity :pos))
+ (dereference
+ wff nil
+ :if-constant (unless (or (eq true wff) (eq false wff))
+ (funcall cc wff polarity))
+ :if-variable (not-wff-error wff)
+ :if-compound-cons (not-wff-error wff)
+ :if-compound-appl (let ((head (heada wff)))
+ (if (function-logical-symbol-p head)
+ (map-atoms-in-list-of-wffs cc (argsa wff) (function-polarity-map head) polarity)
+ (funcall cc wff polarity))))
+ nil)
+
+(defun map-atoms-in-wff-and-compose-result (cc wff &optional (polarity :pos))
+ (dereference
+ wff nil
+ :if-constant (if (or (eq true wff) (eq false wff))
+ wff
+ (funcall cc wff polarity))
+ :if-variable (not-wff-error wff)
+ :if-compound-cons (not-wff-error wff)
+ :if-compound-appl (prog->
+ (heada wff -> head)
+ (cond
+ ((function-logical-symbol-p head)
+ (argsa wff -> args)
+ (cond
+ ((null args)
+ wff)
+ ((null (rest args))
+ (first args -> arg)
+ (map-atoms-in-wff-and-compose-result cc arg (map-polarity (first (function-polarity-map head)) polarity) -> arg*)
+ (if (eq arg arg*) wff (fancy-make-compound* head (list arg*))))
+ (t
+ (map-atoms-in-list-of-wffs-and-compose-result cc args (function-polarity-map head) polarity -> args*)
+ (if (eq args args*) wff (fancy-make-compound* head args*)))))
+ (t
+ (funcall cc wff polarity))))))
+
+(defun map-terms-in-wff (cc wff &optional subst (polarity :pos))
+ (prog->
+ (map-atoms-in-wff wff polarity ->* atom polarity)
+ (map-terms-in-atom cc atom subst polarity)))
+
+(defun map-terms-in-wff-and-compose-result (cc wff &optional subst (polarity :pos))
+ (prog->
+ (map-atoms-in-wff-and-compose-result wff polarity ->* atom polarity)
+ (map-terms-in-atom-and-compose-result cc atom subst polarity)))
+
+(defun map-terms-in-atom (cc atom &optional subst (polarity :pos))
+ (dereference
+ atom nil
+ :if-variable (not-wff-error atom)
+ :if-compound-cons (not-wff-error atom)
+ :if-compound-appl (map-terms-in-list-of-terms cc nil (argsa atom) subst polarity)))
+
+(defun map-terms-in-atom-and-compose-result (cc atom &optional subst (polarity :pos))
+ (dereference
+ atom nil
+ :if-constant atom
+ :if-variable (not-wff-error atom)
+ :if-compound-cons (not-wff-error atom)
+ :if-compound-appl (let* ((args (argsa atom))
+ (args* (map-terms-in-list-of-terms-and-compose-result cc nil args subst polarity)))
+ (if (eq args args*)
+ atom
+ (make-compound* (heada atom) args*)))))
+
+(defun map-terms-in-term (cc term &optional subst (polarity :pos))
+ (dereference
+ term subst
+ :if-constant (funcall cc term polarity)
+ :if-variable (funcall cc term polarity)
+ :if-compound-cons (progn
+ (map-terms-in-term cc (carc term) subst polarity)
+ (map-terms-in-term cc (cdrc term) subst polarity)
+ (funcall cc term polarity))
+ :if-compound-appl (let* ((head (heada term))
+ (head-if-associative (and (function-associative head) head)))
+ (map-terms-in-list-of-terms cc head-if-associative (argsa term) subst polarity)
+ (funcall cc term polarity))))
+
+(defun map-terms-in-term-and-compose-result (cc term &optional subst (polarity :pos))
+ (dereference
+ term subst
+ :if-constant (funcall cc term polarity)
+ :if-variable (funcall cc term polarity)
+ :if-compound-cons (lcons (map-terms-in-term-and-compose-result cc (car term) subst polarity)
+ (map-terms-in-term-and-compose-result cc (cdr term) subst polarity)
+ term)
+ :if-compound-appl (let* ((head (heada term))
+ (head-if-associative (and (function-associative head) head)))
+ (funcall cc
+ (let* ((args (argsa term))
+ (args* (map-terms-in-list-of-terms-and-compose-result cc head-if-associative args subst polarity)))
+ (if (eq args args*)
+ term
+ (make-compound* (head term) args*)))
+ polarity))))
+
+(defun map-terms-in-list-of-terms (cc head-if-associative terms subst polarity)
+ (dolist (term terms)
+ (dereference
+ term subst
+ :if-variable (funcall cc term polarity)
+ :if-constant (funcall cc term polarity)
+ :if-compound-cons (progn
+ (map-terms-in-term cc (carc term) subst polarity)
+ (map-terms-in-term cc (cdrc term) subst polarity)
+ (funcall cc term polarity))
+ :if-compound-appl (let ((head (heada term)))
+ (map-terms-in-list-of-terms
+ cc (and (function-associative head) head) (argsa term) subst polarity)
+ (unless (and head-if-associative (eq head head-if-associative))
+ (funcall cc term polarity))))))
+
+(defvar map-atoms-first nil)
+
+(defun map-atoms-in-list-of-wffs (cc wffs polarity-map polarity)
+ (cond
+ (map-atoms-first
+ (let ((polarity-map polarity-map))
+ (dolist (wff wffs)
+ (let ((polarity-fun (pop polarity-map)))
+ (unless (head-is-logical-symbol wff)
+ (map-atoms-in-wff cc wff (map-polarity polarity-fun polarity))))))
+ (let ((polarity-map polarity-map))
+ (dolist (wff wffs)
+ (let ((polarity-fun (pop polarity-map)))
+ (when (head-is-logical-symbol wff)
+ (map-atoms-in-wff cc wff (map-polarity polarity-fun polarity)))))))
+ (t
+ (let ((polarity-map polarity-map))
+ (dolist (wff wffs)
+ (let ((polarity-fun (pop polarity-map)))
+ (map-atoms-in-wff cc wff (map-polarity polarity-fun polarity))))))))
+
+(defun map-terms-in-list-of-terms-and-compose-result (cc head-if-associative terms subst polarity)
+ (cond
+ ((null terms)
+ nil)
+ (t
+ (let ((term (first terms)))
+ (dereference
+ term subst
+ :if-constant (lcons (funcall cc term polarity)
+ (map-terms-in-list-of-terms-and-compose-result
+ cc head-if-associative (rest terms) subst polarity)
+ terms)
+ :if-variable (lcons (funcall cc term polarity)
+ (map-terms-in-list-of-terms-and-compose-result
+ cc head-if-associative (rest terms) subst polarity)
+ terms)
+ :if-compound (cond
+ ((and head-if-associative (eq (head term) head-if-associative))
+ (append (map-terms-in-list-of-terms-and-compose-result
+ cc head-if-associative (args term) subst polarity)
+ (map-terms-in-list-of-terms-and-compose-result
+ cc head-if-associative (rest terms) subst polarity)))
+ (t
+ (lcons (map-terms-in-term-and-compose-result
+ cc term subst polarity)
+ (map-terms-in-list-of-terms-and-compose-result
+ cc head-if-associative (rest terms) subst polarity)
+ terms))))))))
+
+(defun map-atoms-in-list-of-wffs-and-compose-result (cc wffs polarity-map polarity)
+ ;; always called with at least two wffs
+ (let* ((x (first wffs))
+ (x* (map-atoms-in-wff-and-compose-result
+ cc x (map-polarity (first polarity-map) polarity)))
+ (y (rest wffs)))
+ (cond
+ ((null (rest y))
+ (let* ((z (first y))
+ (z* (map-atoms-in-wff-and-compose-result
+ cc z (map-polarity (second polarity-map) polarity))))
+ (cond
+ ((eq z z*)
+ (cond
+ ((eq x x*)
+ wffs)
+ (t
+ (cons x* y))))
+ (t
+ (list x* z*)))))
+ (t
+ (lcons x*
+ (map-atoms-in-list-of-wffs-and-compose-result
+ cc (rest wffs) (rest polarity-map) polarity)
+ wffs)))))
+
+(defun map-atoms-in-alist-of-wffs-and-compose-result (cc alist &optional polarity)
+ (lcons (let ((p (first alist)))
+ (lcons (car p) (map-atoms-in-wff-and-compose-result cc (cdr p) polarity) p))
+ (map-atoms-in-alist-of-wffs-and-compose-result cc (rest alist) polarity)
+ alist))
+
+(defun map-terms-in-list-of-wffs-and-compose-result (cc wffs subst polarity)
+ (lcons (map-terms-in-wff-and-compose-result cc (first wffs) subst polarity)
+ (map-terms-in-list-of-wffs-and-compose-result cc (rest wffs) subst polarity)
+ wffs))
+
+(defun map-conjuncts (cc wff)
+ (if (conjunction-p wff)
+ (mapc (lambda (wff) (map-conjuncts cc wff)) (args wff))
+ (funcall cc wff))
+ nil)
+
+(defun replace-atom-in-wff (wff atom value)
+ (let* ((replaced nil)
+ (wff* (prog->
+ (map-atoms-in-wff-and-compose-result wff ->* a p)
+ (declare (ignore p))
+ (if (equal-p atom a) ;would prefer to use eq
+ (progn (setf replaced t) value)
+ a))))
+ (cl:assert replaced)
+ wff*))
+
+(defun atoms-in-wff (wff &optional subst atoms)
+ (prog->
+ (last atoms -> atoms-last)
+ (map-atoms-in-wff wff :pos ->* atom polarity)
+ (declare (ignore polarity))
+ (unless (member-p atom atoms subst)
+ (collect atom atoms)))
+ atoms)
+
+(defun atoms-in-wffs (wffs &optional subst atoms)
+ (prog->
+ (dolist wffs ->* wff)
+ (setf atoms (atoms-in-wff wff subst atoms)))
+ atoms)
+
+(defun atoms-in-wff2 (wff &optional subst (polarity :pos) variable-block)
+ (let ((atoms-and-polarities nil) atoms-and-polarities-last)
+ (prog->
+ (map-atoms-in-wff wff polarity ->* atom polarity)
+ (when variable-block
+ (setf atom (instantiate atom variable-block)))
+ (assoc-p atom atoms-and-polarities subst -> v)
+ (cond
+ ((null v)
+ (collect (list atom polarity) atoms-and-polarities))
+ ((neq polarity (second v))
+ (setf (second v) :both))))
+ atoms-and-polarities))
+
+(defun atoms-in-clause2 (clause &optional except-atom renumber)
+ (let ((atoms-and-polarities nil) atoms-and-polarities-last
+ (except-atom-found nil)
+ (rsubst nil))
+ (prog->
+ (map-atoms-in-clause clause ->* atom polarity)
+ (cond
+ ((equal-p except-atom atom) ;would prefer to use eq
+ (setf except-atom-found t))
+ (t
+ (when renumber
+ (setf (values atom rsubst) (renumber-new atom nil rsubst)))
+ (collect (list atom polarity) atoms-and-polarities))))
+ (cl:assert (implies except-atom except-atom-found))
+ atoms-and-polarities))
+
+(defun atoms-to-clause2 (atoms-and-polarities)
+ ;; inverse of atoms-in-clause2
+ (cond
+ ((null atoms-and-polarities)
+ false)
+ ((null (rest atoms-and-polarities))
+ (let ((x (first atoms-and-polarities)))
+ (if (eq :pos (second x)) (first x) (make-compound *not* (first x)))))
+ (t
+ (make-compound*
+ *or*
+ (mapcar (lambda (x) (if (eq :pos (second x)) (first x) (make-compound *not* (first x))))
+ atoms-and-polarities)))))
+
+(defun atoms-in-clause3 (clause &optional except-atom renumber)
+ (let ((negatoms nil) negatoms-last
+ (posatoms nil) posatoms-last
+ (except-atom-found nil)
+ (rsubst nil))
+ (prog->
+ (map-atoms-in-clause clause ->* atom polarity)
+ (cond
+ ((equal-p except-atom atom) ;would prefer to use eq
+ (setf except-atom-found t))
+ (t
+ (when renumber
+ (setf (values atom rsubst) (renumber-new atom nil rsubst)))
+ (ecase polarity
+ (:neg
+ (collect atom negatoms))
+ (:pos
+ (collect atom posatoms))))))
+ (cl:assert (implies except-atom except-atom-found))
+ (values negatoms posatoms)))
+
+(defun atoms-to-clause3 (negatoms posatoms)
+ ;; inverse of atoms-in-clause3
+ (let ((literals nil) literals-last)
+ (dolist (atom negatoms)
+ (collect (make-compound *not* atom) literals))
+ (dolist (atom posatoms)
+ (collect atom literals))
+ (literals-to-clause literals)))
+
+(defun literals-in-clause (clause &optional except-atom renumber)
+ (let ((literals nil) literals-last
+ (except-atom-found nil)
+ (rsubst nil))
+ (prog->
+ (map-atoms-in-clause clause ->* atom polarity)
+ (cond
+ ((equal-p except-atom atom) ;would prefer to use eq
+ (setf except-atom-found t))
+ (t
+ (when renumber
+ (setf (values atom rsubst) (renumber-new atom nil rsubst)))
+ (ecase polarity
+ (:pos
+ (collect atom literals))
+ (:neg
+ (collect (make-compound *not* atom) literals))))))
+ (cl:assert (implies except-atom except-atom-found))
+ literals))
+
+(defun literals-to-clause (literals)
+ ;; inverse of literals-in-clause
+ (cond
+ ((null literals)
+ false)
+ ((null (rest literals))
+ (first literals))
+ (t
+ (make-compound* *or* literals))))
+
+(defun first-negative-literal-in-wff (wff)
+ (prog->
+ (map-atoms-in-wff wff ->* atom polarity)
+ (when (eq :neg polarity)
+ (return-from first-negative-literal-in-wff atom)))
+ nil)
+
+(defun first-positive-literal-in-wff (wff)
+ (prog->
+ (map-atoms-in-wff wff ->* atom polarity)
+ (when (eq :pos polarity)
+ (return-from first-positive-literal-in-wff atom)))
+ nil)
+
+(defun do-not-resolve (atom &optional subst)
+ (dereference
+ atom subst
+ :if-compound (function-do-not-resolve (head atom))
+ :if-constant (constant-do-not-resolve atom)))
+
+(defun do-not-factor (atom &optional subst)
+ (dereference
+ atom subst
+ :if-compound (function-do-not-factor (head atom))))
+
+(defun wff-positive-or-negative (wff)
+ ;; :pos if wff contains at least one atom and all atom occurrences are positive
+ ;; :neg if wff contains at least one atom and all atom occurrences are negative
+ ;; nil otherwise
+ (let ((result nil))
+ (prog->
+ (map-atoms-in-wff wff ->* atom polarity)
+ (unless (or (do-not-resolve atom) (eq result polarity))
+ (if (and (null result) (or (eq :pos polarity) (eq :neg polarity)))
+ (setf result polarity)
+ (return-from wff-positive-or-negative nil))))
+ result))
+
+(defun atom-satisfies-sequential-restriction-p (atom wff &optional subst)
+ (dereference
+ wff nil
+ :if-constant (equal-p atom wff subst)
+ :if-compound (if (function-logical-symbol-p (head wff))
+ (atom-satisfies-sequential-restriction-p atom (arg1 wff) subst)
+ (equal-p atom wff subst))))
+
+(defun term-satisfies-sequential-restriction-p (term wff &optional subst)
+ (dereference
+ wff nil
+ :if-compound (if (function-logical-symbol-p (head wff))
+ (term-satisfies-sequential-restriction-p term (arg1 wff) subst)
+ (occurs-p term wff subst))))
+
+(defun salsify (sat wff interpretation continuation)
+ #+(or symbolics ti) (declare (sys:downward-funarg continuation))
+ ;; SAT = T if trying to satisfy WFF, NIL if trying to falsify WFF
+ (cond
+ ((eq true wff)
+ (when sat
+ (funcall continuation interpretation)))
+ ((eq false wff)
+ (unless sat
+ (funcall continuation interpretation)))
+ (t
+ (let* ((head (and (compound-p wff) (head wff)))
+ (kind (and head (function-logical-symbol-p head))))
+ (ecase kind
+ (not
+ (salsify (not sat) (arg1 wff) interpretation continuation))
+ (and
+ (let ((args (args wff)))
+ (cond
+ ((null args)
+ (when sat
+ (funcall continuation interpretation)))
+ ((null (rest args))
+ (salsify sat (first args) interpretation continuation))
+ (sat
+ (let ((arg2 (if (null (cddr args))
+ (second args)
+ (make-compound* *and* (rest args)))))
+ (salsify sat (first args) interpretation
+ (lambda (i) (salsify sat arg2 i continuation)))))
+ (t
+ (dolist (arg args)
+ (salsify sat arg interpretation continuation))))))
+ (or
+ (let ((args (args wff)))
+ (cond
+ ((null args)
+ (unless sat
+ (funcall continuation interpretation)))
+ ((null (rest args))
+ (salsify sat (first args) interpretation continuation))
+ ((not sat)
+ (let ((arg2 (if (null (cddr args))
+ (second args)
+ (make-compound* *or* (rest args)))))
+ (salsify sat (first args) interpretation
+ (lambda (i) (salsify sat arg2 i continuation)))))
+ (t
+ (dolist (arg args)
+ (salsify sat arg interpretation continuation))))))
+ (implies
+ (let ((args (args wff)))
+ (cond
+ (sat
+ (salsify nil (first args) interpretation continuation)
+ (salsify t (second args) interpretation continuation))
+ (t
+ (salsify t (first args) interpretation
+ (lambda (i) (salsify nil (second args) i continuation)))))))
+ (implied-by
+ (let ((args (args wff)))
+ (cond
+ (sat
+ (salsify nil (second args) interpretation continuation)
+ (salsify t (first args) interpretation continuation))
+ (t
+ (salsify t (second args) interpretation
+ (lambda (i) (salsify nil (first args) i continuation)))))))
+ ((iff xor)
+ (let* ((args (args wff))
+ (arg1 (first args))
+ (arg2 (if (null (cddr args)) (second args) (make-compound* head (rest args)))))
+ (salsify (if (eq 'iff kind) sat (not sat))
+ (make-compound *and*
+ (make-compound *or* (make-compound *not* arg1) arg2)
+ (make-compound *or* (make-compound *not* arg2) arg1))
+ interpretation
+ continuation)))
+ ((if answer-if)
+ (let ((args (args wff)))
+ (salsify t (first args) interpretation (lambda (i) (salsify sat (second args) i continuation)))
+ (salsify nil (first args) interpretation (lambda (i) (salsify sat (third args) i continuation)))))
+ ((nil) ;atomic
+ (let ((v (assoc wff interpretation :test #'equal-p)))
+ (cond
+ ((null v)
+ (funcall continuation (cons (cons wff (if sat true false)) interpretation)))
+ ((eq (if sat true false) (cdr v))
+ (funcall continuation interpretation))))))))))
+
+(defun propositional-contradiction-p (wff)
+ (salsify t wff nil (lambda (i)
+ (declare (ignore i))
+ (return-from propositional-contradiction-p nil)))
+ t)
+
+(defun propositional-tautology-p (wff)
+ (propositional-contradiction-p (negate wff)))
+
+(defun flatten-term (term subst)
+ (dereference
+ term subst
+ :if-constant term
+ :if-variable term
+ :if-compound (let* ((head (head term))
+ (head-if-associative (and (function-associative head) head))
+ (args (args term))
+ (args* (flatten-list args subst head-if-associative)))
+ (if (eq args args*) ;CHECK (<= (LENGTH ARGS*) 2)??????
+ term
+ (make-compound* head args*)))))
+
+(defun flatten-list (terms subst head-if-associative)
+ (cond
+ ((null terms)
+ nil)
+ (t
+ (let ((term (first terms)))
+ (cond
+ ((and head-if-associative (dereference term subst :if-compound (eq (head term) head-if-associative)))
+ (flatten-list (append (args term) (rest terms)) subst head-if-associative))
+ (t
+ (lcons (flatten-term term subst)
+ (flatten-list (rest terms) subst head-if-associative)
+ terms)))))))
+
+(defun unflatten-term1 (term subst)
+ ;; when f is associative, (f a b c) -> (f a (f b c)); leaves (f) and (f a) alone; doesn't unflatten subterms
+ (dereference
+ term subst
+ :if-constant term
+ :if-variable term
+ :if-compound (let ((head (head term))
+ (args (args term)))
+ (cond
+ ((and (function-associative head) (rrest args))
+ (let* ((l (reverse args))
+ (term* (first l)))
+ (dolist (x (rest l))
+ (setf term* (make-compound head x term*)))
+ term*))
+ (t
+ term)))))
+
+(defun unflatten-term (term subst)
+ ;; when f is associative, (f a b c) -> (f a (f b c)); leaves (f) and (f a) alone; unflattens subterms too
+ (dereference
+ term subst
+ :if-constant term
+ :if-variable term
+ :if-compound (labels
+ ((unflatten-list (terms)
+ (lcons (unflatten-term (first terms) subst)
+ (unflatten-list (rest terms))
+ terms)))
+ (let* ((args (args term))
+ (args* (unflatten-list args)))
+ (unflatten-term1 (if (eq args args*) term (make-compound* (head term) args*)) subst)))))
+
+(defun flatten-args (fn args subst)
+ (labels
+ ((fa (args)
+ (if (null args)
+ args
+ (let ((arg (first args)))
+ (cond
+ ((dereference arg subst :if-compound-appl (eq fn (heada arg)))
+ (fa (append (argsa arg) (rest args))))
+ (t
+ (let* ((args1 (rest args))
+ (args1* (fa args1)))
+ (if (eq args1 args1*) args (cons arg args1*)))))))))
+ (fa args)))
+
+(defun fn-chain-tail (fn x subst &optional (len 0))
+ ;; for a fn chain, return tail and length
+ ;; (bag a b) = (bag-cons a (bag-cons b empty-bag)) -> empty-bag,2
+ ;; (bag* a b) = (bag-cons a b) -> b,1
+ (loop
+ (dereference
+ x subst
+ :if-variable (return-from fn-chain-tail (values x len))
+ :if-constant (return-from fn-chain-tail (values x len))
+ :if-compound (if (eq fn (head x))
+ (setf x (second (args x)) len (+ 1 len))
+ (return-from fn-chain-tail (values x len))))))
+
+(defun fn-chain-items (fn x subst)
+ ;; (bag a b) = (bag-cons a (bag-cons b empty-bag)) -> (a b)
+ ;; (bag* a b) = (bag-cons a b) -> (a)
+ (let ((items nil) items-last)
+ (loop
+ (dereference
+ x subst
+ :if-variable (return)
+ :if-constant (return)
+ :if-compound (if (eq fn (head x))
+ (let ((args (args x)))
+ (collect (first args) items)
+ (setf x (second args)))
+ (return))))
+ items))
+
+(defun make-fn-chain (fn items tail)
+ (labels
+ ((mfc (items)
+ (if (null items) tail (make-compound fn (first items) (mfc (rest items))))))
+ (mfc items)))
+
+(defun make-compound1 (fn identity arg1 arg2)
+ (cond
+ ((eql identity arg1)
+ arg2)
+ ((eql identity arg2)
+ arg1)
+ (t
+ (make-compound fn arg1 arg2))))
+
+;;; wffs.lisp EOF