First commits.

snark-20120808r02/src/ac-rpo.lisp

@@ -0,0 +1,304 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: ac-rpo.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+;;; recursive-path-ordering extensions for Rubio's "A fully syntactic AC-RPO"
+
+(defun ac-rpo-compare-compounds (fn xargs yargs subst)
+  (or (ac-rpo-cache-lookup fn xargs yargs)
+      (ac-rpo-cache-store fn xargs yargs (ac-rpo-compare-compounds* fn xargs yargs subst))))
+
+(defun ac-rpo-compare-compounds* (fn xargs yargs subst)
+  (let ((com1 nil) (com2 nil) (com3 nil) (com4 nil)
+        (always-> t) (always-< t) 
+        big-head-of-x no-small-head-of-x
+        big-head-of-y no-small-head-of-y)
+    (when (and (eq '= (setf com1 (compare-argument-counts xargs yargs subst)))
+               (eq '= (compare-term-multisets #'rpo-compare-terms xargs yargs subst '=)))
+      (return-from ac-rpo-compare-compounds* '=))
+    (dolist (yargs1 (emb-no-big fn yargs subst))
+      (case (ac-rpo-compare-compounds fn xargs yargs1 subst)
+        (?
+         (setf always-> nil))
+        ((< =)
+         (return-from ac-rpo-compare-compounds* '<))))
+    (when always->
+      (setf (values big-head-of-x no-small-head-of-x)
+        (big-head-and-no-small-head fn xargs subst))
+      (setf (values big-head-of-y no-small-head-of-y)
+        (big-head-and-no-small-head fn yargs subst))
+      (when (and (case (setf com4 (compare-no-small-heads fn no-small-head-of-x no-small-head-of-y subst nil))
+                   ((> =)
+                    t))
+                 (or (eq '> com1)
+                     (eq '> (setf com2 (compare-term-multisets #'rpo-compare-terms big-head-of-x big-head-of-y subst nil)))
+                     (case com1
+                       ((>= =)
+                        (cond
+                         ((and (eq big-head-of-y yargs) (eq '> com2))
+                          t)
+                         ((and (eq big-head-of-x xargs) (neq '> com2))
+                          nil)
+                         ((and (eq big-head-of-x xargs) (eq big-head-of-y yargs))
+                          (eq '> com2))
+                         (t
+                          (eq '> (setf com3 (compare-term-multisets #'rpo-compare-terms xargs yargs subst nil)))))))))
+        (return-from ac-rpo-compare-compounds* '>)))
+    (dolist (xargs1 (emb-no-big fn xargs subst))
+      (case (ac-rpo-compare-compounds fn xargs1 yargs subst)
+        (?
+         (setf always-< nil))
+        ((> =)
+         (return-from ac-rpo-compare-compounds* '>))))
+    (when always-<
+      (unless always->
+        (setf (values big-head-of-x no-small-head-of-x)
+          (big-head-and-no-small-head fn xargs subst))
+        (setf (values big-head-of-y no-small-head-of-y)
+          (big-head-and-no-small-head fn yargs subst)))
+      (when (and (case (or com4 (compare-no-small-heads fn no-small-head-of-x no-small-head-of-y subst nil))
+                   ((< =)
+                    t))
+                 (or (eq '< com1)
+                     (eq '< (or com2 (setf com2 (compare-term-multisets #'rpo-compare-terms big-head-of-x big-head-of-y subst nil))))
+                     (case com1
+                       ((<= =)
+                        (cond
+                         ((and (eq big-head-of-x xargs) (eq '< com2))
+                          t)
+                         ((and (eq big-head-of-y yargs) (neq '< com2))
+                          nil)
+                         ((and (eq big-head-of-x xargs) (eq big-head-of-y yargs))
+                          (eq '< com2))
+                         (t
+                          (eq '< (or com3 (compare-term-multisets #'rpo-compare-terms xargs yargs subst '<)))))))))
+        (return-from ac-rpo-compare-compounds* '<)))
+    '?))
+
+(defun emb-no-big (fn args subst)
+  ;; defn 12
+  (let ((revargs nil) (result nil) result-last)
+    (dotails (args args)
+      (let ((argi (first args)))
+        (when (dereference argi subst :if-compound (neq '> (symbol-ordering-compare (head argi) fn)))
+          (dolist (argij (args argi))
+            (collect (revappend
+                      revargs
+                      (dereference
+                       argij subst
+                       :if-variable (cons argij (rest args))
+                       :if-constant (cons argij (rest args))
+                       :if-compound (if (eq fn (head argij))
+                                        (append (flatargs argij subst) (rest args))
+                                        (cons argij (rest args)))))
+              result)))
+        (push argi revargs)))
+    result))
+
+(defun big-head-and-no-small-head (fn args subst)
+  ;; defn 2: big-head is multiset of arguments for which (> (top arg) fn)
+  ;; defn 7: no-small-head is multiset of arguments for which (not (< (top arg) fn))
+  (labels
+    ((big-head-and-no-small-head* (args)
+       (if (null args)
+           (values nil nil)
+           (let* ((l (rest args))
+                  (arg (first args))
+                  (com (dereference
+                        arg subst
+                        :if-variable '?
+                        :if-constant (symbol-ordering-compare arg fn)
+                        :if-compound (symbol-ordering-compare (head arg) fn))))
+             (mvlet (((values big-head no-small-head) (big-head-and-no-small-head* l)))
+               (values (if (eq '> com)
+                           (if (eq big-head l) args (cons arg big-head))
+                           big-head)
+                       (if (neq '< com)
+                           (if (eq no-small-head l) args (cons arg no-small-head))
+                           no-small-head)))))))
+    (big-head-and-no-small-head* args)))
+
+(defun compare-no-small-heads (fn no-small-head-of-x no-small-head-of-y subst testval)
+  ;; defn 11 comparison function adds the following
+  ;; conditions to the usual comparison
+  ;;  (> compound compound') : (or (> (head compound) fn) (>= (head compound) (head compound'))
+  ;;  (> constant compound)  : (or (> constant fn) (> constant (head compound)))
+  ;;  (> compound constant)  : (or (> (head compound) fn) (> (head compound) constant))
+  ;;  (> compound variable)  : (> (head compound) fn)
+  (labels
+    ((compare (x y subst testval)
+       (dereference2
+        x y subst
+        :if-variable*variable (if (eq x y) '= '?)
+        :if-variable*constant '?
+        :if-constant*variable '?
+        :if-constant*constant (symbol-ordering-compare x y)
+        :if-compound*variable (if (eq '> (symbol-ordering-compare (head x) fn)) (rpo-compare-compound*variable x y subst testval) '?)
+        :if-variable*compound (if (eq '> (symbol-ordering-compare (head y) fn)) (rpo-compare-variable*compound x y subst testval) '?)
+        :if-compound*constant (ecase testval
+                                (>
+                                 (and (or (eq '> (symbol-ordering-compare (head x) fn))
+                                          (eq '> (symbol-ordering-compare (head x) y)))
+                                      (rpo-compare-compound*constant x y subst testval)))
+                                (<
+                                 (and (or (eq '> (symbol-ordering-compare y fn))
+                                          (eq '> (symbol-ordering-compare y (head x))))
+                                      (rpo-compare-compound*constant x y subst testval)))
+                                ((nil)
+                                 (ecase (rpo-compare-compound*constant x y subst testval)
+                                   (>
+                                    (if (or (eq '> (symbol-ordering-compare (head x) fn))
+                                            (eq '> (symbol-ordering-compare (head x) y)))
+                                        '>
+                                        '?))
+                                   (<
+                                    (if (or (eq '> (symbol-ordering-compare y fn))
+                                            (eq '> (symbol-ordering-compare y (head x))))
+                                        '<
+                                        '?))
+                                   (?
+                                    '?))))
+        :if-constant*compound (opposite-order (compare y x subst (opposite-order testval)))
+        :if-compound*compound (ecase testval
+                                (=
+                                 (rpo-compare-compounds x y subst testval))
+                                (>
+                                 (and (or (eq '> (symbol-ordering-compare (head x) fn))
+                                          (case (symbol-ordering-compare (head x) (head y))
+                                            ((> =)
+                                             t)))
+                                      (rpo-compare-compounds x y subst testval)))
+                                (<
+                                 (and (or (eq '> (symbol-ordering-compare (head y) fn))
+                                          (case (symbol-ordering-compare (head y) (head x))
+                                            ((> =)
+                                             t)))
+                                      (rpo-compare-compounds x y subst testval)))
+                                ((nil)
+                                 (ecase (rpo-compare-compounds x y subst testval)
+                                   (>
+                                    (if (or (eq '> (symbol-ordering-compare (head x) fn))
+                                            (case (symbol-ordering-compare (head x) (head y))
+                                              ((> =)
+                                               t)))
+                                        '>
+                                        '?))
+                                   (<
+                                    (if (or (eq '> (symbol-ordering-compare (head y) fn))
+                                            (case (symbol-ordering-compare (head y) (head x))
+                                              ((> =)
+                                               t)))
+                                        '<
+                                        '?))
+                                   (=
+                                    '=)	;this added case is the only change in version 20090905r007
+                                   (?
+                                    '?)))))))
+    (compare-term-multisets #'compare no-small-head-of-x no-small-head-of-y subst testval)))
+
+(defun compare-argument-counts (xargs yargs subst)
+  ;; xargs.subst and yargs.subst are already flattened argument lists
+  ;; of the same associative function
+  ;; this is the AC-RPO comparison of #(x) and #(y) that returns
+  ;; =, >, <, >=, =<, or ?
+  (let ((variable-counts nil) (variable-count 0) (nonvariable-count 0))
+    (labels
+      ((count-arguments (args inc)
+         (declare (fixnum inc))
+         (let (v)
+           (dolist (term args)
+             (dereference
+              term subst
+              :if-variable (cond
+                            ((null variable-counts)
+                             (setf variable-counts (cons (make-tc term inc) nil)))
+                            ((setf v (assoc/eq term variable-counts))
+                             (incf (tc-count v) inc))
+                            (t
+                             (push (make-tc term inc) variable-counts)))
+              :if-constant (incf nonvariable-count inc)
+              :if-compound (incf nonvariable-count inc))))))
+      (count-arguments xargs 1)
+      (count-arguments yargs -1)
+      (dolist (v variable-counts)
+        (let ((c (tc-count v)))
+          (cond
+           ((plusp c)
+            (if (minusp variable-count)
+                (return-from compare-argument-counts '?)
+                (incf variable-count c)))
+           ((minusp c)
+            (if (plusp variable-count)
+                (return-from compare-argument-counts '?)
+                (incf variable-count c))))))
+      (cond
+       ((plusp variable-count)
+        (cond
+         ((minusp nonvariable-count)
+          (let ((d (+ variable-count nonvariable-count)))
+            (cond
+             ((eql 0 d)
+              '>=)
+             ((plusp d)
+              '>)
+             (t
+              '?))))
+         (t
+          '>)))
+       ((minusp variable-count)
+        (cond
+         ((plusp nonvariable-count)
+          (let ((d (+ variable-count nonvariable-count)))
+            (cond
+             ((eql 0 d)
+              '=<)
+             ((minusp d)
+              '<)
+             (t
+              '?))))
+         (t
+          '<)))
+       ((eql 0 nonvariable-count)
+        '=)
+       (t
+        (if (plusp nonvariable-count) '> '<))))))
+
+(defun ac-rpo-cache-lookup (fn xargs yargs)
+  (dolist (x *ac-rpo-cache* nil)
+    (when (and (eq fn (first x))
+               (eql-list xargs (first (setf x (rest x))))
+               (eql-list yargs (first (setf x (rest x)))))
+      (return (first (rest x))))))
+
+(defun ac-rpo-cache-store (fn xargs yargs com)
+  (push (list fn xargs yargs com) *ac-rpo-cache*)
+  com)
+
+(defun eql-list (l1 l2)
+  (loop
+    (cond
+     ((null l1)
+      (return (null l2)))
+     ((null l2)
+      (return nil))
+     ((neql (pop l1) (pop l2))
+      (return nil)))))
+
+;;; ac-rpo.lisp EOF

snark-20120808r02/src/agenda-system.lisp

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

snark-20120808r02/src/agenda.lisp

@@ -0,0 +1,234 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-agenda -*-
+;;; File: agenda.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2008.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark-agenda)
+
+(defstruct (agenda
+            (:print-function print-agenda3)
+            (:copier nil))
+  (name "" :read-only t)
+  (length 0)
+  (length-limit nil)
+  (length-limit-deletion-action #'identity :read-only t)
+  (same-item-p #'eql :read-only t)
+  (buckets (make-sparse-vector)))
+
+;;; an agenda index value (priority) is (list integer_1 ... integer_n) or (list* integer_1 ... integer_n)
+;;; which are both treated as the same sequence integer_1 ... integer_n
+;;; this includes (list* integer) = integer as an agenda index value
+;;; agenda index values are compared lexicographically in left-to-right order
+;;; if one is prefix of another, they must be equal, e.g., can't have (2 18) and (2 18 1)
+;;; agenda buckets are deques stored in nested sparse-vectors indexed by agenda index values
+
+(defun find-agenda-bucket (buckets value &optional create)
+  (labels
+    ((find-agenda-bucket* (buckets value)
+       (cond
+        ((atom value)
+         (or (sparef buckets value)
+             (if create (setf (sparef buckets value) (make-deque)) nil)))
+        ((null (rest value))
+         (or (sparef buckets (first value))
+             (if create (setf (sparef buckets (first value)) (make-deque)) nil)))
+        (t
+         (let ((v (sparef buckets (first value))))
+           (cond
+            (v
+             (find-agenda-bucket* v (rest value)))
+            (create
+             (find-agenda-bucket* (setf (sparef buckets (first value)) (make-sparse-vector)) (rest value)))
+            (t
+             nil)))))))
+    (find-agenda-bucket* buckets value)))
+
+(defun first-or-last-nonempty-agenda-bucket (buckets last)
+  (labels
+    ((first-or-last-nonempty-agenda-bucket* (buckets)
+       (prog->
+         (map-sparse-vector-with-indexes buckets :reverse last ->* x i)
+         (cond
+          ((sparse-vector-p x)
+           (first-or-last-nonempty-agenda-bucket* x))
+          ((deque-empty? x)
+           (setf (sparef buckets i) nil))
+          (t
+           (return-from first-or-last-nonempty-agenda-bucket x))))))
+    (first-or-last-nonempty-agenda-bucket* buckets)
+    nil))
+
+(definline first-nonempty-agenda-bucket (buckets)
+  (first-or-last-nonempty-agenda-bucket buckets nil))
+
+(definline last-nonempty-agenda-bucket (buckets)
+  (first-or-last-nonempty-agenda-bucket buckets t))
+
+(defun collect-agenda-buckets (buckets)
+  (let ((result nil) result-last)
+    (labels
+      ((collect-agenda-buckets* (buckets revalue)
+         (prog->
+           (map-sparse-vector-with-indexes buckets ->* x i)
+           (cond
+            ((sparse-vector-p x)
+             (collect-agenda-buckets* x (cons i revalue)))
+            ((deque-empty? x)
+             )
+            (t
+             (collect (list x (if (null revalue) i (reverse (cons i revalue)))) result))))))
+      (collect-agenda-buckets* buckets nil)
+      result)))
+
+(defun agenda-insert (item value agenda &optional at-front)
+  (let* ((buckets (agenda-buckets agenda))
+         (q (find-agenda-bucket buckets value :create)))
+    (unless (and (not (deque-empty? q)) (funcall (agenda-same-item-p agenda) item (if at-front (deque-first q) (deque-last q))))
+      (if at-front (deque-push-first q item) (deque-push-last q item))
+      (let ((limit (agenda-length-limit agenda))
+            (length (agenda-length agenda)))
+        (cond
+         ((and limit (<= limit length))
+          (let ((deleted-item (deque-pop-last (last-nonempty-agenda-bucket buckets))))
+            (cond
+             ((eql item deleted-item)
+              nil)
+             (t
+              (funcall (agenda-length-limit-deletion-action agenda) deleted-item)
+              t))))
+         (t
+          (setf (agenda-length agenda) (+ length 1))
+          t))))))
+
+(defun agenda-delete (item value agenda)
+  (let ((length (agenda-length agenda)))
+    (unless (eql 0 length)
+      (let ((q (find-agenda-bucket (agenda-buckets agenda) value)))
+        (when (and q (deque-delete q item))
+          (setf (agenda-length agenda) (- length 1))
+          t)))))
+
+(defun agenda-first (agenda &optional delete)
+  (cond
+   ((listp agenda)
+    (dolist (agenda agenda)
+      (unless (eql 0 (agenda-length agenda))
+        (return (agenda-first agenda delete)))))
+   (t
+    (let ((length (agenda-length agenda)))
+      (unless (eql 0 length)
+        (let ((q (first-nonempty-agenda-bucket (agenda-buckets agenda))))
+          (cond
+           (delete
+            (setf (agenda-length agenda) (- length 1))
+            (deque-pop-first q))
+           (t
+            (deque-first q)))))))))
+
+(defun pop-agenda (agenda)
+  (agenda-first agenda t))
+
+(defun map-agenda-buckets (function buckets)
+  (prog->
+    (map-sparse-vector buckets ->* x)
+    (cond
+     ((sparse-vector-p x)
+      (map-agenda-buckets function x))
+     (t
+      (funcall function x)))))
+
+(defun mapnconc-agenda (function agenda)
+  (let ((result nil) result-last)
+    (prog->
+      (map-agenda-buckets (agenda-buckets agenda) ->* q)
+      (mapnconc-deque q ->* item)
+      (cond
+       ((or (null function) (eq 'list function) (eq #'list function))
+        (collect item result))
+       (t
+        (ncollect (funcall function item) result))))))
+
+(defun agenda-delete-if (function agenda &optional apply-length-limit-deletion-action)
+  (prog->
+    (and apply-length-limit-deletion-action (agenda-length-limit-deletion-action agenda) -> deletion-action)
+    (map-agenda-buckets (agenda-buckets agenda) ->* q)
+    (deque-delete-if q ->* v)
+    (when (funcall function v)
+      (decf (agenda-length agenda))
+      (when deletion-action
+        (funcall deletion-action v))
+      t)))
+
+(defun limit-agenda-length (agenda limit)
+  (let ((length (agenda-length agenda)))
+    (setf (agenda-length-limit agenda) limit)
+    (when (and limit (< limit length))
+      (let ((i 0))
+        (agenda-delete-if (lambda (item) (declare (ignore item)) (> (incf i) limit)) agenda t)))))
+
+(defvar *agenda*)		;default agenda(s) for print-agenda to display
+
+(defun print-agenda (&key (agenda *agenda*) entries)
+  (cond
+   ((listp agenda)
+    (let ((all-empty t))
+      (dolist (agenda agenda)
+        (unless (eql 0 (agenda-length agenda))
+          (setf all-empty nil)
+          (print-agenda :agenda agenda :entries entries)))
+      (when all-empty
+        (format t "~%; All agendas are empty."))))
+   (t
+    (with-standard-io-syntax2
+      (format t "~%; The agenda of ~A has ~D entr~:@P~A"
+              (agenda-name agenda)
+              (agenda-length agenda)
+              (if (eql 0 (agenda-length agenda)) "." ":"))
+      (unless (eql 0 (agenda-length agenda))
+        (let ((buckets (collect-agenda-buckets (agenda-buckets agenda))))
+          (do* ((k (length buckets))
+                (k1 (ceiling k 3))
+                (k2 (ceiling (- k k1) 2))
+                (buckets3 (nthcdr (+ k1 k2) buckets))
+                (buckets2 (nbutlast (nthcdr k1 buckets) (- k k1 k2)))
+                (buckets1 (nbutlast buckets k2))
+                b)
+               ((null buckets1))
+            (setf b (pop buckets1))
+            (format t "~%; ~5D with value ~A" (deque-length (first b)) (second b))
+            (unless (null buckets2)
+              (setf b (pop buckets2))
+              (format t "~31T~5D with value ~A" (deque-length (first b)) (second b))
+              (unless (null buckets3)
+                (setf b (pop buckets3))
+                (format t "~61T~5D with value ~A" (deque-length (first b)) (second b))))))
+        (when (and entries (not (eql 0 (agenda-length agenda))))
+          (prog->
+            (dolist (collect-agenda-buckets (agenda-buckets agenda)) ->* x)
+            (first x -> q)
+            (second x -> value)
+            (unless (deque-empty? q)
+              (format t "~%;~%; Entries with value ~A:" value)
+              (mapnconc-deque (lambda (x) (format t "~%; ~A" x)) q))))))
+    nil)))
+
+(defun print-agenda3 (agenda stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (agenda stream :type t :identity nil)
+    (format stream "~S" (agenda-name agenda))))
+
+;;; agenda.lisp EOF

snark-20120808r02/src/alists.lisp

@@ -0,0 +1,121 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: alists.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+;; alists are assumed to be well formed:
+;; lists of dotted pairs ending with nil
+;; car of each dotted pair is a distinct constant
+
+(defun equal-alist-p (alist1 alist2 subst)
+  (and
+   (do ((p1 alist1 (rest p1))
+        (p2 alist2 (rest p2)))
+       (nil)
+     (dereference
+      p1 subst
+      :if-variable (return (dereference p2 subst :if-variable (eq p1 p2)))	;allow variable at end
+      :if-constant (return (dereference p2 subst :if-constant t))		;assume p1=p2=nil
+      :if-compound-cons (unless (dereference p2 subst :if-compound-cons t)
+                          (return nil))))
+   (do ((p1 alist1 (rest p1)))
+       (nil)
+     (dereference
+      p1 subst
+      :if-variable (return t)
+      :if-constant (return t)
+      :if-compound-cons (unless (do ((p2 alist2 (rest p2)))
+                                    (nil)
+                                  (dereference
+                                   p2 subst
+                                   :if-variable (return nil)
+                                   :if-constant (return nil)
+                                   :if-compound-cons (when (eql (car (first p1)) (car (first p2)))
+                                                       (return (equal-p (cdr (first p1)) (cdr (first p2)) subst)))))
+                          (return nil))))))
+
+(defun conjoin-alists (alist1 alist2)
+  (let ((result nil) result-last)
+    (dolist (x alist1)
+      (let ((x1 (car x)))
+        (dolist (y alist2 (collect x result))
+          (when (eql x1 (car y))
+            (collect (cons x1 (conjoin (cdr x) (cdr y))) result)
+            (return)))))
+    (dolist (y alist2)
+      (let ((y1 (car y)))
+        (dolist (x alist1 (collect y result))
+          (when (eql y1 (car x))
+            (return)))))
+    result))
+
+(defun conjoin-alist1 (key value alist)
+  (labels
+    ((conjoin-alist1 (alist)
+       (cond
+        ((null alist)
+         (values nil nil))
+        (t
+         (let ((p (first alist)))
+           (cond
+            ((eql key (car p))
+             (let ((p* (lcons (car p) (conjoin value (cdr p)) p)))
+               (values (if (eq p p*) alist (cons p* (rest alist))) t)))
+            (t
+             (let ((v (rest alist)))
+               (multiple-value-bind (v* found) (conjoin-alist1 v)
+                 (values (if (eq v v*) alist (cons p v*)) found))))))))))
+    (multiple-value-bind (alist* found) (conjoin-alist1 alist)
+      (if found alist* (cons (cons key value) alist*)))))
+
+(defun disjoin-alists (alist1 alist2)
+  (let ((result nil) result-last)
+    (dolist (x alist1)
+      (let ((x1 (car x)))
+        (dolist (y alist2 (collect x result))
+          (when (eql x1 (car y))
+            (collect (cons x1 (disjoin (cdr x) (cdr y))) result)
+            (return)))))
+    (dolist (y alist2)
+      (let ((y1 (car y)))
+        (dolist (x alist1 (collect y result))
+          (when (eql y1 (car x))
+            (return)))))
+    result))
+
+(defun disjoin-alist1 (key value alist)
+  (labels
+    ((disjoin-alist1 (alist)
+       (cond
+        ((null alist)
+         (values nil nil))
+        (t
+         (let ((p (first alist)))
+           (cond
+            ((eql key (car p))
+             (let ((p* (lcons (car p) (disjoin value (cdr p)) p)))
+               (values (if (eq p p*) alist (cons p* (rest alist))) t)))
+            (t
+             (let ((v (rest alist)))
+               (multiple-value-bind (v* found) (disjoin-alist1 v)
+                 (values (if (eq v v*) alist (cons p v*)) found))))))))))
+    (multiple-value-bind (alist* found) (disjoin-alist1 alist)
+      (if found alist* (cons (cons key value) alist*)))))
+
+;;; alists.lisp EOF

snark-20120808r02/src/argument-bag-ac.lisp

@@ -0,0 +1,82 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: argument-bag-ac.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defmacro inc-argument-count (compare-fun term counts inc not-found-form &optional cancel)
+  (let ((count (gensym)) (v (gensym)))
+    `(dolist (,v ,counts ,not-found-form)
+       (let ((,count (tc-count ,v)))
+	 (unless (eql 0 ,count)
+	   (when ,(cond
+		    ((member compare-fun '(equal-p))
+		     `(,compare-fun ,term (tc-term ,v) subst))
+		    (t
+		     `(,compare-fun ,term (tc-term ,v))))
+	     (setf (tc-count ,v) (+ ,count ,inc))
+	     ,@(when cancel
+		 `((unless ,cancel
+		     (when (if (plusp ,count) (minusp ,inc) (plusp ,inc))
+		       (setf ,cancel t)))))
+	     (return)))))))
+
+(defmacro count-argument (fn arg counts inc count-arguments-fun not-found-form &optional cancel)
+  `(dereference
+     ,arg subst
+     :if-variable (inc-argument-count eq ,arg ,counts ,inc ,not-found-form ,cancel)
+     :if-constant (inc-argument-count eql ,arg ,counts ,inc ,not-found-form ,cancel)
+     :if-compound (cond
+		    ((and ,fn (eq ,fn (head ,arg)))
+		     ,(if cancel
+			  `(if ,cancel
+			       (setf ,counts (,count-arguments-fun ,fn (args ,arg) subst ,counts ,inc))
+			       (setf (values ,counts ,cancel) (,count-arguments-fun ,fn (args ,arg) subst ,counts ,inc)))
+			  `(setf ,counts (,count-arguments-fun ,fn (args ,arg) subst ,counts ,inc))))
+		    (t
+		     (inc-argument-count equal-p ,arg ,counts ,inc ,not-found-form ,cancel)))))
+
+(defun count-arguments (fn args subst &optional counts (inc 1))
+  ;; creates list of term and count pairs for argument list
+  ;; term and count pair is represented as (term . count)
+  ;; return 2nd value T if a cancellation occurs
+  (let ((cancel nil))
+    (dolist (arg args)
+      (count-argument fn arg counts inc count-arguments (push (make-tc arg inc) counts) cancel))
+    (if cancel
+	(values counts t)
+	counts)))
+
+(defun recount-arguments (fn terms-and-counts subst)
+  (let (new-terms-and-counts)
+    (dolist (tc terms-and-counts)
+      (let ((term (tc-term tc)) (count (tc-count tc)))
+	(count-argument fn term new-terms-and-counts count count-arguments (push (make-tc term count) new-terms-and-counts))))
+    new-terms-and-counts))
+
+(defun term-size-difference (terms-and-counts subst &optional var0)
+  (let ((n 0))
+    (dolist (tc terms-and-counts)
+      (let ((count (tc-count tc)))
+	(unless (eql 0 count)
+	  (let ((term (tc-term tc)))
+	    (unless (and var0 (dereference term subst :if-variable (not (variable-frozen-p term))))
+	      (incf n (* count (size term subst))))))))
+    n))
+
+;;; argument-bag-ac.lisp EOF

snark-20120808r02/src/argument-list-a1.lisp

@@ -0,0 +1,145 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: argument-list-a1.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defun argument-list-a1 (fn args &optional subst (identity none))
+  ;; return list of arguments of associative function fn
+  ;; return undereferenced args if no flattening or identity elimination
+  (if (null args)
+      nil
+      (labels
+        ((argument-list-a1* (args)
+           (let* ((l (rest args))
+                  (l* (if (null l) nil (argument-list-a1* l)))
+                  (arg (first args))
+                  (arg* arg))
+             (cond
+              ((dereference arg* subst :if-compound-appl (eq fn (heada arg*)))
+               (let* ((v (argsa arg*))
+                      (v* (if (null v) nil (argument-list-a1* v))))
+                 (cond
+                  ((null l*)
+                   v*)
+                  ((null v*)
+                   l*)
+                  (t
+                   (append v* l*)))))
+              ((eql identity arg*)
+               l*)
+              ((eq l l*)
+               args)
+              (t
+               (cons arg l*))))))
+        (argument-list-a1* args))))
+
+(defun argument-count-a1 (fn args &optional subst (identity none) dont-count-variables)
+  (let ((c 0))
+    (dolist (arg args)
+      (dereference
+       arg subst
+       :if-compound-appl (if (eq fn (heada arg))
+                             (incf c (argument-count-a1 fn (argsa arg) subst identity dont-count-variables))
+                             (incf c))
+       :if-compound-cons (incf c)
+       :if-constant (unless (eql identity arg)
+                      (incf c))
+       :if-variable (unless (and dont-count-variables
+                                 (neq none identity)
+                                 (not (variable-frozen-p arg)))
+                      (incf c))))
+    c))
+
+(defun similar-argument-list-ac1-p (fn args1 args2 &optional subst (identity none))
+  ;; same number of variable, list, constant, and application arguments
+  ;; also same number of first constant and first function seen
+  (let ((nvari 0) (nconst 0) (nappl 0)
+	(const1 none) (head1 none) nconst1 nhead1)
+    (labels
+      ((similar-argument-list-ac1-p1 (arg)
+	 (dereference
+	   arg subst
+	   :if-variable (incf nvari)
+	   :if-constant (unless (eql identity arg)
+			  (cond
+			    ((eq const1 none)
+			     (setf const1 arg)
+			     (setf nconst1 1))
+			    ((eql arg const1)
+			     (incf nconst1))
+			    (t
+			     (incf nconst))))
+	   :if-compound (let ((head (head arg)))
+			  (if (eq fn head)
+			      (dolist (x (args arg))
+				(similar-argument-list-ac1-p1 x))
+			      (cond
+				((eq head1 none)
+				 (setf head1 head)
+				 (setf nhead1 1))
+				((eq head head1)
+				 (incf nhead1))
+				(t
+				 (incf nappl)))))))
+       (similar-argument-list-ac1-p2 (arg)
+	 (dereference
+	   arg subst
+	   :if-variable (if (eql 0 nvari)
+			    (return-from similar-argument-list-ac1-p nil)
+			    (decf nvari))
+	   :if-constant (unless (eql identity arg)
+			  (cond
+			    ((eq none const1)
+			     (return-from similar-argument-list-ac1-p nil))
+			    ((eql arg const1)
+			     (if (eql 0 nconst1)
+				 (return-from similar-argument-list-ac1-p nil)
+				 (decf nconst1)))
+			    (t
+			     (if (eql 0 nconst)
+				 (return-from similar-argument-list-ac1-p nil)
+				 (decf nconst)))))
+	   :if-compound (let ((head (head arg)))
+			  (if (eq fn head)
+			      (dolist (x (args arg))
+				(similar-argument-list-ac1-p2 x))
+			      (cond
+				((eq none head1)
+				 (return-from similar-argument-list-ac1-p nil))
+				((eq head head1)
+				 (if (eql 0 nhead1)
+				     (return-from similar-argument-list-ac1-p nil)
+				     (decf nhead1)))
+				(t
+				 (if (eql 0 nappl)
+				     (return-from similar-argument-list-ac1-p nil)
+				     (decf nappl)))))))))
+      (dolist (x args1)
+	(similar-argument-list-ac1-p1 x))
+      (dolist (x args2)
+	(similar-argument-list-ac1-p2 x))
+      (and (eql 0 nvari) (eql 0 nconst) (eql 0 nappl)))))
+
+(defun flatargs (term &optional subst)
+  (let ((fn (head term)))
+    (if (function-associative fn)
+	(argument-list-a1 fn (argsa term) subst)
+	(args term))))
+
+;;; argument-list-a1.lisp EOF

snark-20120808r02/src/assertion-analysis.lisp

@@ -0,0 +1,502 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: assertion-analysis.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+;;; the main purpose of this code is to recognize axioms
+;;; for commutativity, associativity, etc. so that the
+;;; appropriate function or relation symbol declarations can be
+;;; made when running TPTP problems, where stupid and inconvenient
+;;; rules do not allow any problem-specific input other than the axioms
+;;;
+;;; in general, using assertion-analysis to automatically declare
+;;; special properties of relations and functions is NOT encouraged
+
+(in-package :snark)
+
+(defvar *wff*)
+
+(declaim (special *extended-variant*))
+
+(defvar *assertion-analysis-patterns*)
+(defvar *assertion-analysis-function-info*)
+(defvar *assertion-analysis-relation-info*)
+
+(defstruct aa-function
+  function
+  (left-identities nil)
+  (right-identities nil)
+  (left-inverses nil)
+  (right-inverses nil)
+  (commutative nil)
+  (associative nil)
+  (closure-relations nil))
+
+(defstruct aa-relation
+  relation
+  (left-identities nil)
+  (right-identities nil)
+  (left-inverses nil)
+  (right-inverses nil)
+  (commutative nil)
+  (assoc1-p nil)
+  (assoc2-p nil)
+  (functional-p nil)
+  (closure-functions nil))
+
+(defun aa-function (f)
+  (let ((f# (funcall *standard-eql-numbering* :lookup f)))
+    (or (sparef *assertion-analysis-function-info* f#)
+        (progn
+	  (cl:assert (function-symbol-p f))
+	  (setf (sparef *assertion-analysis-function-info* f#)
+	        (make-aa-function :function f))))))
+
+(defun aa-relation (p)
+  (let ((p# (funcall *standard-eql-numbering* :lookup p)))
+    (or (sparef *assertion-analysis-relation-info* p#)
+        (progn
+	  (cl:assert (function-symbol-p p))
+	  (setf (sparef *assertion-analysis-relation-info* p#)
+	        (make-aa-relation :relation p))))))
+
+(defun print-assertion-analysis-note (name)
+  (with-standard-io-syntax2
+    (format t "~%; Recognized ~A assertion ~S." name (renumber *wff*))))
+
+(defun note-function-associative (f)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "associativity"))
+  (setf (aa-function-associative (aa-function f)) t))
+
+(defun note-function-commutative (f)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "commutativity"))
+  (setf (aa-function-commutative (aa-function f)) t))
+
+(defun note-function-left-identity (f e)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "left identity"))
+  (pushnew e (aa-function-left-identities (aa-function f))))
+
+(defun note-function-right-identity (f e)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "right identity"))
+  (pushnew e (aa-function-right-identities (aa-function f))))
+
+(defun note-function-left-inverse (f g e)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "possible left inverse"))
+  (pushnew (list g e) (aa-function-left-inverses (aa-function f)) :test #'equal))
+
+(defun note-function-right-inverse (f g e)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "possible right inverse"))
+  (pushnew (list g e) (aa-function-right-inverses (aa-function f)) :test #'equal))
+
+(defun note-relation-assoc1 (p)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "possible associativity"))
+  (setf (aa-relation-assoc1-p (aa-relation p)) t))
+
+(defun note-relation-assoc2 (p)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "possible associativity"))
+  (setf (aa-relation-assoc2-p (aa-relation p)) t))
+
+(defun note-relation-commutative (p)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "commutativity"))
+  (setf (aa-relation-commutative (aa-relation p)) t))
+
+(defun note-relation-left-identity (p e)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "possible left identity"))
+  (pushnew e (aa-relation-left-identities (aa-relation p))))
+
+(defun note-relation-right-identity (p e)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "possible right identity"))
+  (pushnew e (aa-relation-right-identities (aa-relation p))))
+
+(defun note-relation-left-inverse (p g e)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "possible left inverse"))
+  (pushnew (list g e) (aa-relation-left-inverses (aa-relation p)) :test #'equal))
+
+(defun note-relation-right-inverse (p g e)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "possible right inverse"))
+  (pushnew (list g e) (aa-relation-right-inverses (aa-relation p)) :test #'equal))
+
+(defun note-relation-functional (p)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "relation functionality"))
+  (setf (aa-relation-functional-p (aa-relation p)) t))
+
+(defun note-relation-closure (p f)
+  (when (print-assertion-analysis-notes?)
+    (print-assertion-analysis-note "relation function"))
+  (pushnew f (aa-relation-closure-functions (aa-relation p)))
+  (pushnew p (aa-function-closure-relations (aa-function f))))
+
+(defun function-associativity-tests ()
+  (let ((f (make-function-symbol (gensym) 2))
+	(x (make-variable))
+	(y (make-variable))
+	(z (make-variable)))
+    (list
+      ;; (= (f (f x y) z) (f x (f y z)))
+      (list (make-equality0 (make-compound f (make-compound f x y) z) (make-compound f x (make-compound f y z)))
+	    (list 'note-function-associative f)))))
+
+(defun function-commutativity-tests ()
+  (let ((f (make-function-symbol (gensym) 2))
+	(x (make-variable))
+	(y (make-variable)))
+    (list
+      ;; (= (f x y) (f y x))
+      (list (make-equality0 (make-compound f x y) (make-compound f y x))
+	    (list 'note-function-commutative f)))))
+
+(defun function-identity-tests ()
+  (let ((f (make-function-symbol (gensym) 2))
+	(e (gensym))
+	(x (make-variable)))
+    (list
+      ;; (= (f e x) x)
+      (list (make-equality0 (make-compound f e x) x)
+	    (list 'note-function-left-identity f e))
+      ;; (= (f x e) x)
+      (list (make-equality0 (make-compound f x e) x)
+	    (list 'note-function-right-identity f e)))))
+
+(defun function-inverse-tests ()
+  (let ((f (make-function-symbol (gensym) 2))
+	(g (make-function-symbol (gensym) 1))
+	(e (gensym))
+	(x (make-variable)))
+    (list
+      ;; (= (f (g x) x) e)
+      (list (make-equality0 (make-compound f (make-compound g x) x) e)
+	    (list 'note-function-left-inverse f g e))
+      ;; (= (f x (g x)) e)
+      (list (make-equality0 (make-compound f x (make-compound g x)) e)
+	    (list 'note-function-right-inverse f g e)))))
+
+(defun relation-associativity-tests ()
+  (let ((p (make-function-symbol (gensym) 3))
+	(x (make-variable))
+	(y (make-variable))
+	(z (make-variable))
+	(u (make-variable))
+	(v (make-variable))
+	(w (make-variable)))
+    (let ((a (make-compound p x y u))
+	  (b (make-compound p y z v))
+	  (c (make-compound p u z w))
+	  (d (make-compound p x v w)))
+      (list
+       ;; (or (not (p x y u)) (not (p y z v)) (not (p u z w)) (p x v w))
+       (list (make-compound *or*
+			    (make-compound *not* a)
+			    (make-compound *not* b)
+			    (make-compound *not* c)
+			    d)
+	     (list 'note-relation-assoc1 p))
+       ;; (implies (and (p x y u) (p y z v) (p u z w)) (p x v w))
+       (list (make-compound *implies*
+			    (make-compound *and* a b c)
+			    d)
+	     (list 'note-relation-assoc1 p))
+       ;; (or (not (p x y u)) (not (p y z v)) (not (p x v w)) (p u z w))
+       (list (make-compound *or*
+			    (make-compound *not* a)
+			    (make-compound *not* b)
+			    (make-compound *not* d)
+			    c)
+	     (list 'note-relation-assoc2 p))
+       ;; (implies (and (p x y u) (p y z v) (p x v w)) (p u z w))
+       (list (make-compound *implies*
+			    (make-compound *and* a b d)
+			    c)
+	     (list 'note-relation-assoc2 p))))))
+
+(defun relation-commutativity-tests ()
+  (let ((p (make-function-symbol (gensym) 3))
+	(x (make-variable))
+	(y (make-variable))
+	(z (make-variable)))
+    (loop for a in (list (make-compound p x y) (make-compound p x y z))
+	  as  b in (list (make-compound p y x) (make-compound p y x z))
+	  nconc (list
+		  ;; (or (not (p x y)) (p x y))  and  (or (not (p x y z)) (p y x z))
+		  (list (make-compound *or* (make-compound *not* a) b)
+			(list 'note-relation-commutative p))
+		  ;; (implies (p x y) (p y x))   and  (implies (p x y z) (p y x z))
+		  (list (make-compound *implies* a b)
+			(list 'note-relation-commutative p))))))
+
+(defun relation-identity-tests ()
+  (let ((p (make-function-symbol (gensym) 3))
+	(e (gensym))
+	(x (make-variable)))
+    (list
+      ;; (p e x x)
+      (list (make-compound p e x x)
+	    (list 'note-relation-left-identity p e))
+      ;; (p x e x)
+      (list (make-compound p x e x)
+	    (list 'note-relation-right-identity p e)))))
+
+(defun relation-inverse-tests ()
+  (let ((p (make-function-symbol (gensym) 3))
+	(g (make-function-symbol (gensym) 1))
+	(e (gensym))
+	(x (make-variable)))
+    (list
+      ;; (p (g x) x e)
+      (list (make-compound p (make-compound g x) x e)
+	    (list 'note-relation-left-inverse p g e))
+      ;; (p x (g x) e)
+      (list (make-compound p x (make-compound g x) e)
+	    (list 'note-relation-right-inverse p g e)))))
+
+(defun relation-functionality-tests ()
+  (let ((p (make-function-symbol (gensym) 3))
+	(x (make-variable))
+	(y (make-variable))
+	(z1 (make-variable))
+	(z2 (make-variable)))
+    (let ((a (make-compound p x y z1))
+	  (b (make-compound p x y z2))
+	  (c (make-equality0 z1 z2)))
+      (list
+	;; (or (not (p x y z1)) (not (p x y z2)) (= z1 z2))
+	(list
+	  (make-compound *or*
+			    (make-compound *not* a)
+			    (make-compound *not* b)
+			    c)
+	  (list 'note-relation-functional p))
+	;; (implies (and (p x y z1) (p x y z2)) (= z1 z2))
+	(list
+	  (make-compound *implies*
+			    (make-compound *and* a b)
+			    c)
+	  (list 'note-relation-functional p))))))
+
+(defun relation-closure-tests ()
+  (let ((p (make-function-symbol (gensym) 3))
+	(f (make-function-symbol (gensym) 2))
+	(x (make-variable))
+	(y (make-variable)))
+    (list
+      (list
+	(make-compound p x y (make-compound f x y))
+	(list 'note-relation-closure p f)))))
+
+(defun initialize-assertion-analysis ()
+  (setf *assertion-analysis-function-info* (make-sparse-vector))
+  (setf *assertion-analysis-relation-info* (make-sparse-vector))
+  (setf *assertion-analysis-patterns*
+	(nconc (function-associativity-tests)
+	       (function-commutativity-tests)
+	       (function-identity-tests)
+	       (function-inverse-tests)
+	       (relation-associativity-tests)
+	       (relation-commutativity-tests)
+	       (relation-identity-tests)
+	       (relation-inverse-tests)
+	       (relation-functionality-tests)
+	       (relation-closure-tests)
+	       ))
+  nil)
+
+(defun assertion-analysis (row)
+  (prog->
+    (when (row-bare-p row)
+      (row-wff row -> wff)
+      (identity wff -> *wff*)
+      (quote t -> *extended-variant*)
+      (dolist *assertion-analysis-patterns* ->* x)
+      (variant (first x) wff nil nil ->* varpairs)
+      (sublis varpairs (second x) -> decl)
+      (apply (first decl) (rest decl))
+      (return-from assertion-analysis))))
+
+(defun maybe-declare-function-associative (f)
+  (unless (function-associative f)
+    (when (or (use-associative-unification?) (function-commutative f))
+      (with-standard-io-syntax2
+        (if (function-commutative f)
+            (format t "~%; Declaring ~A to be associative-commutative." (function-name f))
+            (format t "~%; Declaring ~A to be associative." (function-name f))))
+      (declare-function (function-name f) (function-arity f) :associative t))))
+
+(defun maybe-declare-function-commutative (f)
+  (unless (function-commutative f)
+    (with-standard-io-syntax2
+      (if (function-associative f)
+          (format t "~%; Declaring ~A to be associative-commutative." (function-name f))
+          (format t "~%; Declaring ~A to be commutative." (function-name f))))
+    (declare-function (function-name f) (function-arity f) :commutative t)))
+
+(defun maybe-declare-relation-commutative (p)
+  (unless (function-commutative p)
+    (with-standard-io-syntax2
+      (format t "~%; Declaring ~A to be commutative." (function-name p)))
+    (declare-relation (function-name p) (function-arity p) :commutative t)))
+
+(defun maybe-declare-function-identity (f e)
+  (unless (neq none (function-identity f))
+    (when (and (use-associative-identity?) (function-associative f) (or (use-associative-unification?) (function-commutative f)))
+      (with-standard-io-syntax2
+        (format t "~%; Declaring ~A to have identity ~A." (function-name f) e))
+      (declare-function (function-name f) (function-arity f) :identity e))))
+
+(defun aa-relation-associative (p)
+  (if (or (aa-relation-commutative p)
+	  (function-commutative (aa-relation-relation p)))
+      (or (aa-relation-assoc1-p p) (aa-relation-assoc2-p p))
+      (and (aa-relation-assoc1-p p) (aa-relation-assoc2-p p))))
+
+(defun complete-assertion-analysis ()
+  (prog->
+    (map-sparse-vector *assertion-analysis-function-info* ->* f)
+    (when (aa-function-commutative f)
+      (maybe-declare-function-commutative (aa-function-function f)))
+    (when (aa-function-associative f)
+      (maybe-declare-function-associative (aa-function-function f))))
+  (prog-> 
+    (map-sparse-vector *assertion-analysis-relation-info* ->* p)
+    (when (aa-relation-commutative p)
+      (maybe-declare-relation-commutative (aa-relation-relation p))
+      (when (aa-relation-functional-p p)
+	(dolist (f (aa-relation-closure-functions p))
+	  (maybe-declare-function-commutative f))))
+    (when (aa-relation-associative p)
+      (when (aa-relation-functional-p p)
+	(dolist (f (aa-relation-closure-functions p))
+	  (maybe-declare-function-associative f)))))
+  (prog->
+    (map-sparse-vector *assertion-analysis-function-info* ->* f)
+    (aa-function-left-identities f -> left-identities)
+    (aa-function-right-identities f -> right-identities)
+    (aa-function-function f -> f)
+    (if (function-commutative f) (union left-identities right-identities) (intersection left-identities right-identities) -> identities)
+    (when (and identities (null (rest identities)))
+      (maybe-declare-function-identity f (first identities))))
+  (prog->
+    (map-sparse-vector *assertion-analysis-relation-info* ->* p)
+    (aa-relation-left-identities p -> left-identities)
+    (aa-relation-right-identities p -> right-identities)
+    (when (and (or left-identities right-identities) (aa-relation-functional-p p))
+      (dolist (aa-relation-closure-functions p) ->* f)
+      (if (function-commutative f) (union left-identities right-identities) (intersection left-identities right-identities) -> identities)
+      (when (and identities (null (rest identities)))
+        (maybe-declare-function-identity f (first identities))))))
+
+(define-plist-slot-accessor row :pure)
+
+(defun atom-rel# (atom)
+  (dereference
+   atom nil
+   :if-constant (constant-number atom)
+   :if-compound (function-number (head atom))))
+
+(defun purity-test (row-mapper)
+  (let ((relation-reference-counts (make-sparse-vector :default-value 0)))
+    (flet ((adjust-reference-counts (row n)
+             (prog->
+               (map-atoms-in-wff (row-wff row) ->* atom polarity)
+               (atom-rel# atom -> rel#)
+               (ecase polarity
+                 (:pos
+                  (incf (sparef relation-reference-counts rel#) n))
+                 (:neg
+                  (incf (sparef relation-reference-counts (- rel#)) n))
+                 (:both
+                  (incf (sparef relation-reference-counts rel#) n)
+                  (incf (sparef relation-reference-counts (- rel#)) n))))))
+      ;; count occurrences of signed relations
+      (prog->
+        (funcall row-mapper ->* row)
+        (unless (or (row-hint-p row) (eq :checking (row-pure row)))
+          ;; row might be mapped more than once, put :checking in pure slot and count once
+          (setf (row-pure row) :checking)
+          (adjust-reference-counts row 1)))
+      (loop
+        (when (print-pure-rows?)
+          (with-clock-on printing
+            (format t "~2&; Purity test finds")
+            (prog->
+              (map-sparse-vector-with-indexes relation-reference-counts ->* count signedrel#)
+              (abs signedrel# -> rel#)
+              (if (= signedrel# rel#) (- rel#) rel# -> oppsignedrel#)
+              (sparef relation-reference-counts oppsignedrel# -> oppcount)
+              (unless (and (< 0 signedrel#) (< 0 oppcount))
+                (format t "~%; ~5D positive and ~5D negative occurrences of ~S."
+                        (if (< 0 signedrel#) count oppcount)
+                        (if (> 0 signedrel#) count oppcount)
+                        (symbol-numbered rel#))))))
+        (let ((purerels nil))
+          ;; list in purerels relations that occur only positively or only negatively
+          (prog->
+            (map-sparse-vector-indexes-only relation-reference-counts ->* signedrel#)
+            (abs signedrel# -> rel#)
+            (if (= signedrel# rel#) (- rel#) rel# -> oppsignedrel#)
+            (when (= 0 (sparef relation-reference-counts oppsignedrel#))
+              (symbol-numbered rel# -> symbol)
+              (if (< 0 signedrel#) "positively" "negatively" -> sign)
+              (cond
+               ((not (function-symbol-p symbol))
+                (push rel# purerels)
+                (warn "~S is a proposition that occurs only ~A; disabling rows that contain it." symbol sign))
+               ((or (eq *=* symbol)
+                    (function-rewrite-code symbol)
+                    (if (< 0 signedrel#) (function-falsify-code symbol) (function-satisfy-code symbol)))
+                )
+               ((integerp (function-arity symbol))
+                (push rel# purerels)
+                (warn "~S is a ~D-ary relation that occurs only ~A; disabling rows that contain it." symbol (function-arity symbol) sign))
+               (t
+                (push rel# purerels)
+                (warn "~S is a relation that occurs only ~A; disabling rows that contain it." symbol sign)))))
+          ;; if purerels is empty, no (more) pure rows, remove :checking and return
+          (when (null purerels)
+            (prog->
+              (funcall row-mapper ->* row)
+              (when (eq :checking (row-pure row))
+                (setf (row-pure row) nil)))
+            (return))
+          ;; if row contains a relation in purerels, mark it as pure and decrement reference counts
+          ;; maybe some relations will be newly pure, so loop
+          (prog->
+            (funcall row-mapper ->* row)
+            (when (eq :checking (row-pure row))
+              (when (prog->
+                      (map-atoms-in-wff (row-wff row) ->* atom polarity)
+                      (declare (ignore polarity))
+                      (when (member (atom-rel# atom) purerels)
+                        (return-from prog-> t)))
+                (setf (row-pure row) t)
+                (adjust-reference-counts row -1)
+                (print-pure-row row))))))
+      nil)))
+
+;;; assertion-analysis.lisp EOF

snark-20120808r02/src/assertion-file.lisp

@@ -0,0 +1,262 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: assertion-file.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defmacro in-language (language)
+  (declare (ignore language))
+  `(warn "Ignoring IN-LANGUAGE form."))
+
+(defmacro in-kb (kb)
+  ;; use suspend/resume for this?  okbc calls?
+  (declare (ignore kb))
+  `(warn "Ignoring IN-KB form."))
+
+(defmacro has-author (author)
+  `(setf *form-author* ',author))
+
+(defmacro has-documentation (documentation)
+  `(setf *form-documentation* ',documentation))
+
+(defmacro has-name (name)
+  `(setf *form-name* ',name))
+
+(defmacro has-source (source)
+  `(setf *form-source* ',source))
+
+(declare-snark-option assertion-file-commands
+                      '(assertion
+                        has-author	;has-xxx specifies xxx for later assertions
+                        has-documentation
+                        has-name
+                        has-source
+                        in-package
+                        in-language
+                        in-kb
+                        declare-constant
+                        declare-function
+                        declare-relation
+                        declare-sort
+                        declare-subsort
+                        declare-sorts-incompatible
+                        declare-tptp-sort
+                        )		;every other form is an assertion
+                      :never-print)
+
+(declare-snark-option assertion-file-keywords
+                      '((:author *form-author*)
+                        (:documentation *form-documentation*)
+                        (:name *form-name*)
+                        (:source *form-source*))
+                      :never-print)
+
+(declare-snark-option assertion-file-format nil :never-print)
+(declare-snark-option assertion-file-if-does-not-exist :error :never-print)
+(declare-snark-option assertion-file-verbose nil :never-print)
+(declare-snark-option assertion-file-package :snark-user :never-print)
+(declare-snark-option assertion-file-readtable nil :never-print)
+(declare-snark-option assertion-file-negate-conjectures nil :never-print)
+
+(defun read-assertion-file (filespec
+                            &key
+                            (format (assertion-file-format?))
+                            (if-does-not-exist (assertion-file-if-does-not-exist?))
+                            (verbose (assertion-file-verbose?))
+                            (package (or (assertion-file-package?) *package*))
+                            (readtable (or (assertion-file-readtable?) *readtable*))
+                            (negate-conjectures (assertion-file-negate-conjectures?))
+                            hash-dollar
+                            (clock t))
+  ;; read-asssertion-file executes commands and return a list of calls on 'assertion'
+  ;; every form that is not a command (commands are named in (assertion-file-commands?))
+  ;; is treated as a formula to be asserted
+  (declare (ignorable verbose hash-dollar))
+  (let ((sort-declarations nil)
+        (subsort-declarations nil))
+    (labels
+      ((raf0 ()
+         (prog->
+           (identity readtable -> *readtable*)
+           (identity (assertion-file-commands?) -> commands)
+           (identity (assertion-file-keywords?) -> keywords)
+           (progv (mapcar #'second keywords)
+                  (consn nil nil (length keywords))
+             (funcall (let ((type (pathname-type filespec)))
+                        (cond
+                         ((or (string-equal "tptp" type) (string-equal "p" type) (string-equal "ax" type))
+                          'mapnconc-tptp-file-forms)
+                         ((or (string-equal "lisp" type) (string-equal "kif" type))
+                          'mapnconc-file-forms)
+                         ((eq :tptp format)
+                          'mapnconc-tptp-file-forms)
+                         (t
+                          'mapnconc-file-forms)))
+                      filespec
+                      :if-does-not-exist if-does-not-exist
+                      :package package
+                      ->* form)
+             (when form						;ignore nils
+               (and (consp form)
+                    (symbolp (first form))
+                    (first (member (first form) commands
+                                   :test #'string-equal		;command matching ignores package and case
+                                   :key #'symbol-name))
+                    -> command)
+               (case command
+                 ((nil)
+                  (setf form (list 'assertion form)))
+                 (assertion
+                  (setf form (cons command (append (rest form) nil)))
+                  (setf command nil))
+                 ((declare-sort declare-tptp-sort)
+                  (setf form (cons command (rest form)))
+                  (push form sort-declarations))
+                 (declare-subsort
+                  (setf form (cons command (rest form)))
+                  (push form subsort-declarations))
+                 ((declare-sorts-incompatible declare-constant declare-function declare-relation)
+                  (setf form (cons command (rest form)))
+                  (setf command nil))
+                 (otherwise
+                  (eval (cons command (rest form)))))
+               (unless command
+                 (case (and (consp form) (first form))
+                   (assertion
+                    (cond
+                     ((getf (cddr form) :ignore)
+                      nil)
+                     (t
+                      (when (and negate-conjectures (eq 'conjecture (getf (cddr form) :reason)))
+                        (setf (second form) (list 'not (second form)))
+                        (setf (getf (cddr form) :reason) 'negated_conjecture))
+                      (dolist (x keywords)
+                        (let ((v (symbol-value (second x))))
+                          (when (and v (eq none (getf (cddr form) (first x) none)))
+                            (nconc form (list (first x) v)))))
+                      (list form))))
+                   (otherwise
+                    (list form))))))))
+       (raf ()
+         (let ((l (raf0)))
+           (cond
+            (subsort-declarations
+             (setf subsort-declarations (topological-sort (nreverse subsort-declarations) 'must-precede-in-assertion-file))
+             (setf l (append subsort-declarations l))
+             (dolist (x sort-declarations)
+               (unless (member (unquote (second x)) subsort-declarations :key #'(lambda (x) (unquote (second x))))
+                 (push x l))))
+            (t
+             (dolist (x sort-declarations)
+               (push x l))))
+           l)))
+      (if clock
+          (with-clock-on read-assertion-file (raf))
+          (raf)))))
+
+(defun must-precede-in-assertion-file (x y)
+  (ecase (first x)
+    ((declare-sort declare-subsort)
+     (ecase (first y)
+       ((declare-sort declare-subsort)
+        (leafp (unquote (second x)) y))
+       ((declare-sorts-incompatible declare-constant declare-function declare-relation declare-proposition assertion)
+        t)))
+    (declare-sorts-incompatible
+     (ecase (first y)
+       ((declare-sort declare-subsort declare-sorts-incompatible)
+        nil)
+       ((declare-constant declare-function declare-relation declare-proposition assertion)
+        t)))
+    ((declare-constant declare-function declare-relation declare-proposition)
+     (eq 'assertion (first y)))
+    (assertion
+     nil)))
+
+(declare-snark-option refute-file-initialize t :never-print)
+(declare-snark-option refute-file-closure t :never-print)
+(declare-snark-option refute-file-options nil :never-print)
+(declare-snark-option refute-file-actions nil :never-print)
+(declare-snark-option refute-file-ignore-errors nil :never-print)
+(declare-snark-option refute-file-verbose t :never-print)
+(declare-snark-option refute-file-output-file nil :never-print)
+(declare-snark-option refute-file-if-exists nil :never-print)
+
+(defun refute-file (filespec
+                    &key
+                    (initialize (refute-file-initialize?))
+                    (closure (refute-file-closure?))
+                    (format (assertion-file-format?))
+		    (options (refute-file-options?))
+                    (actions (refute-file-actions?))
+                    (ignore-errors (refute-file-ignore-errors?))
+		    (verbose (refute-file-verbose?))
+                    (output-file (refute-file-output-file?))
+                    (if-exists (refute-file-if-exists?))
+                    (package (or (assertion-file-package?) *package*))
+                    (readtable (or (assertion-file-readtable?) *readtable*))
+                    (use-coder nil))
+  (labels
+    ((refute-file0 ()
+       (cond
+        (use-coder
+         (multiple-value-bind (axioms target op pred) (snark-user::condensed-detachment-problem-p (read-assertion-file filespec))
+           (declare (ignorable pred))
+           (if op
+               (snark-user::coder axioms target :op op :run-time-limit (if (numberp use-coder) use-coder nil))
+               (format t "~%Not recognized as a condensed-detachment problem."))))
+        (t
+         (when initialize
+           (initialize))
+         (mapc #'eval options)
+         (mapc #'eval (funcall 'read-assertion-file filespec
+                               :format format
+                               :package package
+                               :readtable readtable))
+         (mapc #'eval actions)
+         (when closure
+           (or (let ((*szs-filespec* filespec)) (closure)) :done)))))
+     (refute-file1 ()
+       (if verbose
+           (let ((result (time (refute-file0))))
+             (case result
+               (:proof-found
+                (unless (member (print-final-rows?) '(:tptp :tptp-too))
+                  (print-szs-status result nil filespec)))
+               ((:run-time-limit :agenda-empty)
+                (print-szs-status result nil filespec)))
+             (prin1 result))
+           (refute-file0)))
+     (refute-file2 ()
+       (prog2
+        (when verbose
+          (format t "~&; Begin refute-file ~A " filespec) (print-current-time) (terpri))
+        (if ignore-errors
+            (mvlet (((values value condition) (ignore-errors (refute-file1))))
+              (or value (princ condition)))
+            (refute-file1))
+        (when verbose
+          (format t "~&; End refute-file ~A "   filespec) (print-current-time) (terpri)))))
+    (if output-file
+        (with-open-file (stream output-file :direction :output :if-exists if-exists)
+          (when stream
+            (let ((*standard-output* stream) (*error-output* stream) (*trace-output* stream))
+              (refute-file2))))
+        (refute-file2))))
+
+;;; assertion-file.lisp EOF

snark-20120808r02/src/clocks.lisp

@@ -0,0 +1,169 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
+;;; File: clocks.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark-lisp)
+
+(defvar *clocks* nil)
+
+(defun make-clock-variable (name)
+    (cl:assert (symbolp name))
+    (let* ((s (symbol-name name))
+	   (v (intern (to-string "*%" s :-time%*) :snark-lisp))
+           (w (intern (to-string "*%" s :-count%*) :snark-lisp)))
+      (unless (assoc v *clocks*)
+	(setf *clocks* (nconc *clocks* (list (list v w))))
+	(proclaim `(special ,v ,w)))
+      (values v w)))
+
+(mapc #'make-clock-variable
+	'(
+          read-assertion-file
+          assert
+          process-new-row
+	  resolution
+	  paramodulation
+	  factoring
+          equality-factoring
+          embedding
+          condensing
+	  forward-subsumption
+	  backward-subsumption
+          clause-clause-subsumption
+	  forward-simplification
+	  backward-simplification
+	  ordering
+          ordering-ac
+	  sortal-reasoning
+          temporal-reasoning
+	  constraint-simplification
+	  term-hashing
+	  path-indexing
+          instance-graph-insertion
+          purity-testing
+          relevance-testing
+          satisfiability-testing
+	  printing
+	  halted
+	  test1
+	  test2
+	  test3
+	  ))
+
+(defvar *excluded-clocks* '(*%printing-time%* *%halted-time%*))
+
+(defvar *running-clocks* nil)
+(defvar *first-real-time-value* 0)
+(defvar *first-run-time-value* 0)
+(defvar *last-run-time-value* 0)
+(defvar *run-time-mark* 0)
+(declaim (type integer *first-real-time-value* *first-run-time-value* *last-run-time-value* *run-time-mark*))
+(defvar *total-seconds* 0.0)
+
+(defun initialize-clocks (&optional (excluded-clocks *excluded-clocks*))
+  (cl:assert (null *running-clocks*))
+  (setf *first-real-time-value* (get-internal-real-time))
+  (setf *run-time-mark* (setf *first-run-time-value* (get-internal-run-time)))
+  (setf *excluded-clocks* excluded-clocks)
+  (dolist (l *clocks*)
+    (dolist (v l)
+      (setf (symbol-value v) 0))))
+
+(defmacro with-clock-on (clock &body body)
+  (let (count)
+    (setf (values clock count) (make-clock-variable clock))
+    (let ((previously-running-clocks (make-symbol (symbol-name 'previously-running-clocks)))
+          (first-previously-running-clock (make-symbol (symbol-name 'first-previously-running-clock))))
+      `(let* ((,previously-running-clocks *running-clocks*)
+              (,first-previously-running-clock (first ,previously-running-clocks)))
+         (unless (eq ',clock ,first-previously-running-clock)
+           (if ,previously-running-clocks
+               (decf (symbol-value ,first-previously-running-clock) (- *last-run-time-value* (setf *last-run-time-value* (get-internal-run-time))))
+               (setf *last-run-time-value* (get-internal-run-time)))
+           (incf (symbol-value ',count))
+           (setf *running-clocks* (cons ',clock ,previously-running-clocks)))
+         (unwind-protect
+           (progn ,@body)
+           (unless (eq ',clock ,first-previously-running-clock)
+             (setf *running-clocks* ,previously-running-clocks)
+             (decf (symbol-value ',clock) (- *last-run-time-value* (setf *last-run-time-value* (get-internal-run-time))))))))))
+
+(defmacro with-clock-off (clock &body body)
+  ;; dummy with-clock-on
+  (make-clock-variable clock)
+  `(progn ,@body))
+
+(defun clock-name (clock)
+  (let ((name (symbol-name clock)))
+    (nsubstitute #\  #\- (subseq name 2 (- (length name) 7)))))
+
+(defun print-clocks (&optional (excluded-clocks *excluded-clocks*))
+  (let ((total-ticks (- (get-internal-run-time) *first-run-time-value*))
+        (time-included 0)
+        (time-excluded 0))
+    (format t "~%; Run time in seconds")
+    (dolist (l *clocks*)
+      (let* ((clk (first l))
+             (run-time (symbol-value clk)))
+        (cond
+         ((eql 0 run-time)
+          )
+         ((member clk excluded-clocks)
+          (format t (if (eql 0 time-excluded) " excluding ~(~A~)" ", ~(~A~)") (clock-name clk))
+          (incf time-excluded run-time))
+         (t
+          (incf time-included run-time)))))
+    (unless (eql 0 time-excluded)
+      (decf total-ticks time-excluded)
+      (format t " time"))
+    (princ ":")
+    (dolist (l *clocks*)
+      (let ((clk (first l))
+            (cnt (second l)))
+        (unless (member clk excluded-clocks)
+	  (let ((run-time (symbol-value clk))
+                (count (symbol-value cnt)))
+	    (unless (eql 0 count)
+              (format t "~%;~10,3F ~3D%   ~@(~A~)~48T(~:D call~:P)"
+                      (/ run-time (float internal-time-units-per-second))
+                      (if (eql 0 total-ticks) 0 (percentage run-time total-ticks))
+                      (clock-name clk)
+                      count))))))
+    (let ((other-time (- total-ticks time-included)))
+      (format t "~%;~10,3F ~3D%   Other"
+              (/ other-time (float internal-time-units-per-second))
+              (if (eql 0 total-ticks) 0 (percentage other-time total-ticks))))
+    (setf *total-seconds* (/ total-ticks (float internal-time-units-per-second)))
+    (format t "~%;~10,3F        Total" *total-seconds*)
+    (format t "~%;~10,3F        Real time" (/ (- (get-internal-real-time) *first-real-time-value*) (float internal-time-units-per-second)))
+    *total-seconds*))
+
+(defun total-run-time (&optional (excluded-clocks *excluded-clocks*))
+  (let ((total-ticks (- (get-internal-run-time) *first-run-time-value*)))
+    (dolist (l *clocks*)
+      (let ((clk (first l)))
+        (when (member clk excluded-clocks)
+          (decf total-ticks (symbol-value clk)))))
+    (/ total-ticks (float internal-time-units-per-second))))
+
+(defun print-incremental-time-used ()
+  (let ((time (get-internal-run-time)))
+    (format t "     ;~,3Fsec" (/ (- time *run-time-mark*) (float internal-time-units-per-second)))
+    (setf *run-time-mark* time)))
+
+;;; clocks.lisp EOF

snark-20120808r02/src/closure1.lisp

@@ -0,0 +1,66 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: closure1.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+;;; simple closure algorithm for small deduction tasks
+;;; that do not require features like indexing for performance
+
+(defun closure1 (items &key done unary-rules binary-rules ternary-rules (subsumption-test #'equal))
+  ;; compute closure of the union of items and done using rules and subsumption-test
+  ;; if done is given as an argument, it is assumed to be closed already
+  (flet ((unsubsumed (l1 l2 subsumption-test)
+           ;; return items in l2 that are not subsumed by any item in l1
+           (delete-if #'(lambda (item2)
+                          (some #'(lambda (item1)
+                                    (funcall subsumption-test item1 item2))
+                                l1))
+                      l2)))
+    (let ((todo (make-deque)))
+      (dolist (item items)
+        (deque-push-last todo item))
+      (loop
+        (when (deque-empty? todo)
+          (return done))
+        (let ((item1 (deque-pop-first todo)))
+          (when (unsubsumed done (list item1) subsumption-test)
+            (setf done (cons item1 (unsubsumed (list item1) done subsumption-test)))
+            (prog->
+              (dolist unary-rules ->* rule)
+              (funcall rule item1 ->* new-item)
+              (when (eq :inconsistent new-item)
+                (return-from closure1 new-item))
+              (deque-push-last todo new-item))
+            (prog->
+              (dolist binary-rules ->* rule)
+              (dolist done ->* item2)
+              (funcall rule item1 item2 ->* new-item)
+              (when (eq :inconsistent new-item)
+                (return-from closure1 new-item))
+              (deque-push-last todo new-item))
+            (prog->
+              (dolist ternary-rules ->* rule)
+              (dolist done ->* item2)
+              (dolist done ->* item3)
+              (funcall rule item1 item2 item3 ->* new-item)
+              (when (eq :inconsistent new-item)
+                (return-from closure1 new-item))
+              (deque-push-last todo new-item))))))))
+
+;;; closure1.lisp EOF

snark-20120808r02/src/code-for-bags4.lisp

@@ -0,0 +1,116 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: code-for-bags4.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defvar *singleton-bag*)
+(defvar *bag-union*)
+
+;;; $$bag and $$bag* terms are translated into a standardized internal representation for bags
+;;; that has $$$bag-union as the top function symbol
+;;; ($$bag)        -> ($$bag-union)
+;;; ($$bag a)      -> ($$bag-union ($$singleton-bag a))
+;;; ($$bag a b)    -> ($$bag-union ($$singleton-bag a) ($$singleton-bag b))
+;;; ($$bag a b c)  -> ($$bag-union ($$singleton-bag a) ($$singleton-bag b) ($$singleton-bag c))
+;;; ($$bag* a)     -> ($$bag-union a)
+;;; ($$bag* a b)   -> ($$bag-union ($$singleton-bag a) b)
+;;; ($$bag* a b c) -> ($$bag-union ($$singleton-bag a) ($$singleton-bag b) c)
+
+;;; variables and terms that represent bags should always be enclosed in bag-union, bag, or bag* symbols
+;;; (bag-union a ?x) and a are not recognized as unifiable because they have different head symbols
+;;; (bag-union a ?x) and (bag-union a) can be unified
+
+(defun declare-code-for-bags ()
+  (declare-subsort 'bag :top-sort-a)
+  (declare-characteristic-relation '$$bagp #'bagp 'bag)
+  (declare-function1 '$$bag :any :macro t :input-code 'input-bag-term)
+  (declare-function1 '$$bag* :any :macro t :input-code 'input-bag*-term)
+  (setf *singleton-bag*					;should only be used as argument of bag-union
+        (declare-function1 '$$singleton-bag 1		;unexported symbol that shouldn't be visible to user
+                           :sort 'bag
+                           :constructor t))
+  (setf *bag-union*
+        (declare-function1 '$$bag-union 2
+                           :sort '(bag (t bag))
+                           :associative t
+                           :commutative t
+                           :identity '(function)	;use (bag-union) as identity
+                           :keep-head t
+                           :to-lisp-code 'bag-union-term-to-lisp))
+  (declare-ordering-greaterp '$$bag-union '$$singleton-bag)
+  (declare-function1 '$$bag-to-list 1 :sort 'list :rewrite-code #'(lambda (x s) (bag-to-list (arg1 x) s)))
+  (declare-function1 '$$list-to-bag 1 :sort 'bag  :rewrite-code #'(lambda (x s) (list-to-bag (arg1 x) s)))
+  nil)
+
+(defun bagp (x &optional subst)
+  (dereference x subst :if-compound-appl (eq *bag-union* (heada x))))
+
+(defun input-bag-term (head args polarity)
+  (declare (ignore head))
+  (input-term1 `($$bag-union ,@(mapcar #'(lambda (arg) `($$singleton-bag ,arg)) args)) polarity))
+
+(defun input-bag*-term (head args polarity)
+  (require-n-or-more-arguments head args polarity 1)
+  (input-term1 `($$bag-union ,@(mapcar #'(lambda (arg) `($$singleton-bag ,arg)) (butlast args)) ,(first (last args))) polarity))
+
+(defun bag-union-term-to-lisp (head args subst)
+  (mvlet* (((:values u v) (split-if #'(lambda (x) (dereference x subst :if-compound-appl (eq *singleton-bag* (heada x))))
+                                    (argument-list-a1 head args subst)))
+           (u (mapcar #'(lambda (x) (dereference x subst) (term-to-lisp (arg1a x) subst)) u))
+           (v (mapcar #'(lambda (x) (term-to-lisp x subst)) v)))
+    (cond
+     ((null v)
+      `(,(current-function-name '$$bag :any) ,@u))
+     ((null u)
+      `(,(function-name *bag-union*) ,@v))
+     (t
+      `(,(function-name *bag-union*) (,(current-function-name '$$bag :any) ,@u) ,@v)))))
+
+(defun bag-to-list (bag &optional subst)
+  (dereference
+   bag subst
+   :if-variable none
+   :if-constant none
+   :if-compound-cons none
+   :if-compound-appl (cond
+                      ((eq *bag-union* (heada bag))
+                       (mapcar #'(lambda (x)
+                                   (if (dereference x subst :if-compound-appl (eq *singleton-bag* (heada x)))
+                                       (first (argsa x))
+                                       (return-from bag-to-list none)))
+                               (argument-list-a1 *bag-union* (argsa bag) subst)))
+                      (t
+                       none))))
+
+(defun list-to-bag (list &optional subst)
+  (dereference
+   list subst
+   :if-variable none
+   :if-compound-appl none
+   :if-constant (if (null list) (make-compound *bag-union*) none)
+   :if-compound-cons (let ((sbags nil))
+                       (loop
+                         (push (make-compound *singleton-bag* (pop list)) sbags)
+                         (dereference
+                          list subst
+                          :if-variable (return none)
+                          :if-compound-appl (return none)
+                          :if-constant (return (if (null list) (make-compound* *bag-union* (reverse sbags)) none)))))))
+
+;;; code-for-bags4.lisp EOF

snark-20120808r02/src/code-for-lists2.lisp

@@ -0,0 +1,34 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: code-for-lists2.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defun declare-code-for-lists ()
+  (declare-constant nil :locked t :constructor t :sort 'list)
+  (setf *cons* (declare-function1 '$$cons 2 :constructor t :to-lisp-code 'cons-term-to-lisp :sort 'list :ordering-status :left-to-right))
+
+  (declare-ordering-greaterp '$$cons nil)
+
+  (declare-function1 '$$list :any :macro t :input-code 'input-lisp-list)
+  (declare-function1 '$$list* :any :macro t :input-code 'input-lisp-list*)
+
+  (declare-characteristic-relation '$$listp #'listp 'list)
+  nil)
+
+;;; code-for-lists2.lisp EOF

snark-20120808r02/src/code-for-numbers3.lisp

@@ -0,0 +1,505 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: code-for-numbers3.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+;;; SNARK can evaluate arithmetic expressions as if by table lookup
+;;; for procedurally attached relations and functions
+;;;
+;;; most of what SNARK "knows" about numbers is limited by this notion of table lookup;
+;;; few if any more general properties are known
+;;; like (= (+ x 0) x), (= (* x 0) 0), (exists (x) (< x 0)),
+;;; associativity and commutativity of + and *, etc.
+;;;
+;;; this is intended to provide simple arithmetic calculation and not much if any symbolic algebra
+;;;
+;;; SNARK numbers are represented by Lisp rational numbers (integers or ratios)
+;;; and complex numbers with rational real and imaginary parts
+;;;
+;;; floating-point numbers are replaced by rationals when input
+;;;
+;;; SNARK number type hierarchy: number = complex > real > rational > integer
+;;;
+;;; arithmetic relations are encoded in terms of $less
+;;; using lexicographic ordering of complex numbers
+;;; that also enables additive cancellation law
+;;; and multiplicative cancellation law for multiplication by nonzero reals
+
+(defvar *sum*)
+(defvar *product*)
+(defvar *less*)
+(defvar *reciprocal*)
+
+(defun rnumberp (x)
+  ;; test for SNARK number, no floats
+  (or (rationalp x) (and (complexp x) (rationalp (realpart x)) (rationalp (imagpart x)))))
+
+(defun nonzero-rnumberp (x)
+  (and (rnumberp x) (neql 0 x)))
+
+(defun nonzero-rationalp (x)
+  (and (rationalp x) (neql 0 x)))
+
+(defun less? (x y)
+  ;; extend < to total lexicographic ordering of complex numbers so that
+  ;; a < b  or  a = b  or  a > b
+  ;; a < b  iff  a+c < b+c
+  ;; a < b  iff  a*c < b*c  (real c>0)
+  ;; a < b  iff  a*c > b*c  (real c<0)
+  (or (< (realpart x) (realpart y))
+      (and (= (realpart x) (realpart y))
+           (< (imagpart x) (imagpart y)))))
+
+(defun lesseq? (x y)
+  (or (= x y) (less? x y)))
+
+(defun greater? (x y)
+  (less? y x))
+
+(defun greatereq? (x y)
+  (lesseq? y x))
+
+(defun euclidean-quotient (number &optional (divisor 1))
+  (mvlet (((values quotient remainder) (truncate number divisor)))
+    (if (minusp remainder)
+        (if (plusp divisor)
+            (values (- quotient 1) (+ remainder divisor))
+            (values (+ quotient 1) (- remainder divisor)))
+        (values quotient remainder))))
+
+(defun euclidean-remainder (number &optional (divisor 1))
+  ;; 0 <= remainder < abs(divisor)
+  (nth-value 1 (euclidean-quotient number divisor)))
+
+(defun ceiling-remainder (number &optional (divisor 1))
+  (nth-value 1 (ceiling number divisor)))
+
+(defun round-remainder (number &optional (divisor 1))
+  (nth-value 1 (round number divisor)))
+
+(defun declare-arithmetic-characteristic-relation (name pred sort &rest options)
+  (apply 'declare-characteristic-relation name pred sort :constraint-theory 'arithmetic options))
+
+(defun declare-arithmetic-relation (name arity &rest options)
+  (apply 'declare-relation2 name arity
+         :constraint-theory 'arithmetic
+         `(,@options :sort ((t number)))))
+
+(defun declare-arithmetic-function (name arity &rest options &key (sort 'number) &allow-other-keys)
+  (apply 'declare-function2 name arity
+         :constraint-theory 'arithmetic
+         (if (consp sort) options `(:sort (,sort (t number)) ,@options))))
+
+(defun declare-code-for-numbers ()
+  (declare-constant 0)
+  (declare-constant 1)
+  (declare-constant -1)
+
+  (declare-arithmetic-characteristic-relation '$$numberp   #'rnumberp  'number)
+  (declare-arithmetic-characteristic-relation '$$complexp  #'rnumberp  'complex)	;all Lisp numbers are SNARK complex numbers
+  (declare-arithmetic-characteristic-relation '$$realp     #'rationalp 'real)		;no floats though
+  (declare-arithmetic-characteristic-relation '$$rationalp #'rationalp 'rational)
+  (declare-arithmetic-characteristic-relation '$$integerp  #'integerp  'integer)
+  (declare-arithmetic-characteristic-relation '$$naturalp  #'naturalp  'natural)
+
+  (declare-arithmetic-inequality-relations)
+
+  (setf *sum* (declare-arithmetic-function '$$sum 2
+                                           :associative t
+                                           :commutative t
+                                           :sort 'number :sort-code 'arithmetic-term-sort-computer1
+                                           :rewrite-code (list #'(lambda (x s) (arithmetic-term-rewriter3 x s #'+ 0 none))
+                                                               'sum-term-rewriter1)
+                                           :arithmetic-relation-rewrite-code 'sum-rel-number-atom-rewriter))
+  
+  (setf *product* (declare-arithmetic-function '$$product 2
+                                               :associative t
+                                               :commutative t
+                                               :sort 'number :sort-code 'arithmetic-term-sort-computer1
+                                               :rewrite-code (list #'(lambda (x s) (arithmetic-term-rewriter3 x s #'* 1 0))
+                                                                   #'(lambda (x s) (distributivity-rewriter x s *sum*)))
+                                               :arithmetic-relation-rewrite-code 'product-rel-number-atom-rewriter))
+  
+  (declare-arithmetic-function '$$uminus     1 :sort 'number :sort-code 'arithmetic-term-sort-computer1 :rewrite-code 'uminus-term-rewriter)
+  (declare-arithmetic-function '$$difference 2 :sort 'number :sort-code 'arithmetic-term-sort-computer1 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter5 x s *sum* '$$uminus)))
+
+  (declare-arithmetic-function '$$floor      1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'floor)))
+  (declare-arithmetic-function '$$ceiling    1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'ceiling)))
+  (declare-arithmetic-function '$$truncate   1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'truncate)))
+  (declare-arithmetic-function '$$round      1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'round)))
+
+  ;; partial, guard against division by zero
+  (declare-arithmetic-function '$$quotient_f 2 :sort 'integer                                          :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'floor)))
+  (declare-arithmetic-function '$$quotient_c 2 :sort 'integer                                          :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'ceiling)))
+  (declare-arithmetic-function '$$quotient_t 2 :sort 'integer                                          :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'truncate)))
+  (declare-arithmetic-function '$$quotient_r 2 :sort 'integer                                          :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'round)))
+  (declare-arithmetic-function '$$quotient_e 2 :sort 'integer                                          :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'euclidean-quotient)))
+  (declare-arithmetic-function '$$remainder_f 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'mod)))
+  (declare-arithmetic-function '$$remainder_c 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'ceiling-remainder)))
+  (declare-arithmetic-function '$$remainder_t 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'rem)))
+  (declare-arithmetic-function '$$remainder_r 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'round-remainder)))
+  (declare-arithmetic-function '$$remainder_e 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'euclidean-remainder)))
+
+  ;; partial, guard against division by zero
+  (setf *reciprocal* (declare-arithmetic-function '$$reciprocal 1
+                                                  :sort 'number :sort-code 'arithmetic-term-sort-computer2
+                                                  :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rnumberp #'/))
+                                                  :arithmetic-relation-rewrite-code 'reciprocal-rel-number-atom-rewriter))
+  (declare-arithmetic-function '$$quotient  2 :sort 'number :sort-code 'arithmetic-term-sort-computer2 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter5 x s *product* '$$reciprocal)))
+
+  ;; abs of complex numbers might be irrational
+  (declare-arithmetic-function '$$abs       1 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter1 x s #'rationalp #'abs)))
+
+  (declare-arithmetic-function '$$realpart  1 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter1 x s #'rnumberp #'realpart)))
+  (declare-arithmetic-function '$$imagpart  1 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter1 x s #'rnumberp #'imagpart)))
+  nil)
+
+(defun declare-arithmetic-inequality-relations ()
+  (setf *less* (declare-arithmetic-relation '$$$less 2
+                                            :rewrite-code (list 'irreflexivity-rewriter
+                                                                #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'less?))
+                                                                'arithmetic-relation-rewriter
+                                                                'term-rel-term-to-0-rel-difference-atom-rewriter)
+                                            :falsify-code 'irreflexivity-falsifier))
+  (declare-arithmetic-relation '$$$greater   2 :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter4 x s '$$$less t nil)))
+  (declare-arithmetic-relation '$$$lesseq    2 :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter4 x s '$$$less t t)))
+  (declare-arithmetic-relation '$$$greatereq 2 :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter4 x s '$$$less nil t)))
+  (let ((inputter
+         (let ((done nil))
+           (function
+            (lambda (head args polarity)
+              (declare (ignorable head args polarity))
+              (unless done
+                (setf done t)
+                (assert '(forall (x) (not ($$less x x)))    :name :$$less-is-irreflexive)
+                (assert '(forall (x) (not ($$greater x x))) :name :$$greater-is-irreflexive)
+                (assert '(forall (x) ($$lesseq x x))        :name :$$lesseq-is-reflexive)
+                (assert '(forall (x) ($$greatereq x x))     :name :$$greatereq-is-reflexive)
+                (assert '(forall ((x number) (y number)) (implied-by ($$less x y)                 ($$$less x y)))  :name :solve-$$less-by-$$$less)
+                (assert '(forall ((x number) (y number)) (implied-by ($$greater x y)              ($$$less y x)))  :name :solve-$$greater-by-$$$less)
+                (assert '(forall ((x number) (y number)) (implied-by ($$lesseq x y)          (not ($$$less y x)))) :name :solve-$$lesseq-by-$$$less)
+                (assert '(forall ((x number) (y number)) (implied-by ($$greatereq x y)       (not ($$$less x y)))) :name :solve-$$greatereq-by-$$$less)
+                (assert '(forall ((x number) (y number)) (implied-by (not ($$less x y))      (not ($$$less x y)))) :name :solve-~$$less-by-$$$less)
+                (assert '(forall ((x number) (y number)) (implied-by (not ($$greater x y))   (not ($$$less y x)))) :name :solve-~$$greater-by-$$$less)
+                (assert '(forall ((x number) (y number)) (implied-by (not ($$lesseq x y))         ($$$less y x)))  :name :solve-~$$lesseq-by-$$$less)
+                (assert '(forall ((x number) (y number)) (implied-by (not ($$greatereq x y))      ($$$less x y)))  :name :solve-~$$greatereq-by-$$$less))
+              none)))))
+    (declare-relation '$$less      2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'less?)))
+    (declare-relation '$$greater   2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'greater?)))
+    (declare-relation '$$lesseq    2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'lesseq?)))
+    (declare-relation '$$greatereq 2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'greatereq?))))
+  nil)
+
+(defun arithmetic-term-sort-computer0 (term subst sort-names default-sort-name)
+  ;; when sort-names is '(integer rational real) and default-sort-name is number
+  ;; if all arguments are integers then integer
+  ;; elif all arguments are rationals then rational
+  ;; elif all arguments are reals then real
+  ;; else number
+  (let ((top-arg-sort (the-sort (pop sort-names))))
+    (dolist (arg (args term) top-arg-sort)
+      (let ((arg-sort (term-sort arg subst)))
+        (when (or (top-sort? arg-sort)
+                  (loop
+                    (cond
+                     ((subsort? arg-sort top-arg-sort)
+                      (return nil))
+                     ((null sort-names)
+                      (return t))
+                     (t
+                      (setf top-arg-sort (the-sort (pop sort-names)))))))
+          (return (the-sort default-sort-name)))))))
+
+(defun arithmetic-term-sort-computer1 (term subst)
+  (arithmetic-term-sort-computer0 term subst '(integer rational real) 'number))
+
+(defun arithmetic-term-sort-computer2 (term subst)
+  (arithmetic-term-sort-computer0 term subst '(rational real) 'number))
+
+(defun arithmetic-term-sort-computer3 (term subst)
+  (arithmetic-term-sort-computer0 term subst '(integer rational) 'real))
+
+(defun arithmetic-expr-args (x subst pred)
+  ;; return dereferenced arguments of x if all satisfy pred; otherwise, return none
+  (prog->
+    (split-if (args x) subst ->* arg)
+    (or (funcall pred arg) (return-from arithmetic-expr-args none))))
+
+(defun arithmetic-atom-rewriter1 (atom subst pred operator)
+  (let ((args (arithmetic-expr-args atom subst pred)))
+    (if (eq none args) none (if (apply operator args) true false))))
+
+(defun arithmetic-atom-rewriter4 (atom subst newhead reverse negate)
+  ;; a<=b -> ~(b<a)
+  ;; a>b -> b<a
+  ;; a>=b -> ~(a<b)
+  (declare (ignorable subst))
+  (let* ((args (args atom))
+         (atom* (make-compound* (input-relation-symbol newhead (length args)) (if reverse (reverse args) args))))
+    (if negate (negate atom*) atom*)))
+
+(defun arithmetic-term-rewriter1 (term subst pred operator)
+  (let ((args (arithmetic-expr-args term subst pred)))
+    (if (eq none args) none (declare-constant (apply operator args)))))
+
+(defun arithmetic-term-rewriter2 (term subst pred operator)
+  ;; like arithmetic-term-rewriter1 but last argument must be nonzero
+  (let ((args (arithmetic-expr-args term subst pred)))
+    (if (or (eq none args) (eql 0 (first (last args)))) none (declare-constant (apply operator args)))))
+
+(defun arithmetic-term-rewriter3 (term subst operator identity absorber)
+  ;; combines numerical arguments in sum and product terms
+  (let* ((head (head term))
+         (args (args term))
+         (args* (argument-list-a1 head args subst identity)))
+    (cond
+     ((null args*)
+      identity)
+     ((null (rest args*))
+      (first args*))
+     (t
+      (mvlet (((values nums nonnums) (split-if #'rnumberp args* subst)))
+        (cond
+         ((null nums)
+          (if (eq args args*) none (make-compound* head args*)))
+         (t
+          (let ((num (if (null (rest nums)) (first nums) (declare-constant (apply operator nums)))))
+            (cond
+             ((eql absorber num)
+              num)
+             ((eql identity num)
+              (make-a1-compound* head identity nonnums))
+             ((and (eq args args*) (null (rest nums)) (let ((arg1 (first args))) (dereference arg1 subst :if-constant (eql num arg1))))
+              none)
+             (t
+              (make-a1-compound* head identity num nonnums)))))))))))
+
+(defun arithmetic-term-rewriter4 (term subst operator)
+  ;; for floor, ceiling, truncate, and round
+  (let ((arg (first (args term))))
+    (cond
+     ((dereference arg subst :if-constant (realp arg))
+      (declare-constant (funcall operator arg)))
+     ((subsort? (term-sort arg subst) (the-sort 'integer))
+      arg)
+     (t
+      none))))
+
+(defun arithmetic-term-rewriter5 (term subst op2 op1)
+  ;; ($$difference a b) -> ($$sum a ($$uminus b))
+  ;; ($$quotient a b) -> ($$product a ($$reciprocal b))
+  (declare (ignorable subst))
+  (mvlet (((list a b) (args term)))
+    (make-compound (input-function-symbol op2 2) a (make-compound (input-function-symbol op1 1) b))))
+
+(defun decompose-product-term (term subst)
+  (if (dereference term subst :if-compound-appl t)
+      (let ((head (heada term)))
+        (if (eq *product* head)
+            (mvlet* ((args (args term))
+                     ((values nums nonnums) (split-if #'rnumberp (argument-list-a1 head args subst) subst)))
+              (if (and nonnums nums (null (rest nums)) (not (eql 0 (first nums))))
+                  (values (make-a1-compound* head 1 nonnums) (first nums))
+                  (values term 1)))
+            (values term 1)))
+      (values term 1)))
+
+(defun sum-term-rewriter1 (term subst)
+  ;; collect equal arguments into products
+  ;; ($$sum a a b a) -> ($$sum ($$product 3 a) b)
+  ;; ($$sum ($$product 2 a b) ($$product b 3 a)) -> ($$product 5 a b))
+  (let ((rewritten nil))
+    (labels
+      ((combine-terms (terms)
+         (cond
+          ((null (rest terms))
+           terms)
+          (t
+           (mvlet (((values term1 mult1) (decompose-product-term (first terms) subst)))
+             ;; combine terms in (rest terms) then find a match for term1 if there is one
+             (mvlet* ((mult2 nil)
+                      ((values matches nonmatches) (prog->
+                                                     (split-if (combine-terms (rest terms)) subst ->* term2)
+                                                     (unless mult2
+                                                       (unless (rnumberp term2)	;don't combine numbers
+                                                         (mvlet (((values term2 mult) (decompose-product-term term2 subst)))
+                                                           (when (equal-p term1 term2 subst)
+                                                             (setf mult2 mult))))))))
+               (declare (ignorable matches))
+               (cond
+                (mult2
+                 (setf rewritten t)
+                 (let ((mult (declare-constant (+ mult1 mult2))))
+                   (cond
+                    ((eql 0 mult)
+                     nonmatches)
+                    ((eql 1 mult)
+                     (cons term1 nonmatches))
+                    ((dereference term1 subst :if-compound-appl (eq *product* (heada term1)))
+                     (cons (make-compound* *product* mult (args term1)) nonmatches))
+                    (t
+                     (cons (make-compound *product* mult term1) nonmatches)))))
+                ((eq (rest terms) nonmatches)
+                 terms)
+                (t
+                 (cons (first terms) nonmatches)))))))))
+      (let* ((head (head term))
+             (args (argument-list-a1 head (args term) subst))
+             (args* (combine-terms args)))
+        (if rewritten (make-a1-compound* head 0 args*) none)))))
+
+(defun uminus-term-rewriter (term subst)
+  ;; ($$uminus a) -> ($$product -1 a)
+  (declare (ignorable subst))
+  (make-compound *product* -1 (first (args term))))
+
+(defun arithmetic-relation-rewriter (atom subst)
+  (mvlet (((list a b) (args atom)))
+    (or (dereference2
+         a b subst
+         :if-constant*compound (and (rnumberp a)
+                                    (let ((fn (head b)))
+                                      (dolist (fun (function-arithmetic-relation-rewrite-code fn) nil)
+                                        (let ((v (funcall fun atom subst)))
+                                          (unless (eq none v)
+                                            (pushnew (function-code-name fn) *rewrites-used*)
+                                            (return v))))))
+         :if-compound*constant (and (rnumberp b)
+                                    (let ((fn (head a)))
+                                      (dolist (fun (function-arithmetic-relation-rewrite-code fn) nil)
+                                        (let ((v (funcall fun atom subst)))
+                                          (unless (eq none v)
+                                            (pushnew (function-code-name fn) *rewrites-used*)
+                                            (return v)))))))
+        none)))
+
+(defun term-rel-term-to-0-rel-difference-atom-rewriter (atom subst)
+  (mvlet ((rel (head atom))
+          ((list a b) (args atom)))
+    (cl:assert (eq *less* rel))
+    (cond
+     ((dereference2
+       a b subst
+       :if-variable*compound (variable-occurs-p a b subst)
+       :if-compound*variable (variable-occurs-p b a subst)
+       :if-constant*compound (and (not (rnumberp a)) (constant-occurs-p a b subst))
+       :if-compound*constant (and (not (rnumberp b)) (constant-occurs-p b a subst))
+       :if-compound*compound t)
+      (pushnew (function-code-name *product*) *rewrites-used*)
+      (pushnew (function-code-name *sum*) *rewrites-used*)
+      (make-compound rel 0 (make-compound *sum* b (make-compound *product* -1 a))))
+     (t
+      none))))
+
+(defun sum-rel-number-atom-rewriter (atom subst)
+  ;; (eq (sum 2 c) 6) -> (eq c 4) and (less 6 (sum 2 c)) -> (less 4 c) etc.
+  (mvlet ((rel (head atom))
+          ((list a b) (args atom)))
+    (cl:assert (or (eq *less* rel) (eq *=* rel)))
+    (or (dereference
+         a subst
+         :if-constant (and (rnumberp a)
+                           (dereference
+                            b subst
+                            :if-compound (and (eq *sum* (head b))
+                                              (let* ((args (args b)) (arg1 (first args)))
+                                                (and (rnumberp arg1)
+                                                     (make-compound (head atom) (declare-constant (- a arg1)) (make-a1-compound* *sum* 0 (rest args))))))))
+         :if-compound (and (eq *sum* (head a))
+                           (dereference
+                            b subst
+                            :if-constant (and (rnumberp b)
+                                              (let* ((args (args a)) (arg1 (first args)))
+                                                (and (rnumberp arg1)
+                                                     (make-compound (head atom) (make-a1-compound* *sum* 0 (rest args)) (declare-constant (- b arg1)))))))))
+        none)))
+
+(defun product-rel-number-atom-rewriter (atom subst)
+  ;; like sum-rel-number-atom-rewriter, but don't divide by zero, and reverse arguments when dividing by negative number
+  (mvlet ((rel (head atom))
+          ((list a b) (args atom)))
+    (cl:assert (or (eq *less* rel) (eq *=* rel)))
+    (or (dereference
+         a subst
+         :if-constant (and (rnumberp a)
+                           (dereference
+                            b subst
+                            :if-compound (and (eq *product* (head b))
+                                              (let* ((args (args b)) (arg1 (first args)))
+                                                (and (if (eq *less* rel) (nonzero-rationalp arg1) (nonzero-rnumberp arg1))
+                                                     (if (and (eq *less* rel) (minusp arg1))
+                                                         (make-compound (head atom) (make-a1-compound* *product* 0 (rest args)) (declare-constant (/ a arg1)))
+                                                         (make-compound (head atom) (declare-constant (/ a arg1)) (make-a1-compound* *product* 0 (rest args)))))))))
+         :if-compound (and (eq *product* (head a))
+                           (dereference
+                            b subst
+                            :if-constant (and (rnumberp b)
+                                              (let* ((args (args a)) (arg1 (first args)))
+                                                (and (if (eq *less* rel) (nonzero-rationalp arg1) (nonzero-rnumberp arg1))
+                                                     (if (and (eq *less* rel) (minusp arg1))
+                                                         (make-compound (head atom) (declare-constant (/ b arg1)) (make-a1-compound* *product* 0 (rest args)))
+                                                         (make-compound (head atom) (make-a1-compound* *product* 0 (rest args)) (declare-constant (/ b arg1))))))))))
+        none)))
+
+(defun reciprocal-rel-number-atom-rewriter (atom subst)
+  (mvlet ((rel (head atom))
+          ((list a b) (args atom)))
+    (cl:assert (or (eq *less* rel) (eq *=* rel)))
+    (cond
+     ((eq *less* rel)
+      none)
+     (t
+      (or (dereference
+           a subst
+           :if-constant (and (nonzero-rnumberp a)
+                             (dereference
+                              b subst
+                              :if-compound (and (eq *reciprocal* (head b))
+                                                (make-compound (head atom) (declare-constant (/ a)) (arg1 b)))))
+           :if-compound (and (eq *reciprocal* (head a))
+                             (dereference
+                              b subst
+                              :if-constant (and (nonzero-rnumberp b)
+                                                (make-compound (head atom) (arg1 a) (declare-constant (/ b)))))))
+          none)))))
+
+(defmethod checkpoint-theory ((theory (eql 'arithmetic)))
+  nil)
+
+(defmethod uncheckpoint-theory ((theory (eql 'arithmetic)))
+  nil)
+
+(defmethod restore-theory ((theory (eql 'arithmetic)))
+  nil)
+
+(defmethod theory-closure ((theory (eql 'arithmetic)))
+  nil)
+
+(defmethod theory-assert (atom (theory (eql 'arithmetic)))
+  (declare (ignorable atom))
+  nil)
+
+(defmethod theory-deny (atom (theory (eql 'arithmetic)))
+  (declare (ignorable atom))
+  nil)
+
+(defmethod theory-simplify (wff (theory (eql 'arithmetic)))
+  wff)
+
+;;; code-for-numbers3.lisp EOF

snark-20120808r02/src/code-for-strings2.lisp

@@ -0,0 +1,62 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: code-for-strings2.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defun declare-code-for-strings ()
+  (declare-characteristic-relation '$$stringp #'stringp 'string)
+
+  (declare-function1 '$$list-to-string 1 :rewrite-code 'list-to-string-term-rewriter :sort 'string)
+  (declare-function1 '$$string-to-list 1 :rewrite-code 'string-to-list-term-rewriter :sort 'list)	;nil and $$cons must be of sort list for this to work
+  nil)
+
+(defun string-list-p (x &optional subst)
+  (dereference
+    x subst
+    :if-constant (null x)
+    :if-compound-cons (and (let ((a (carc x)))
+                             (dereference a subst :if-constant (and (stringp a) (= 1 (length a)))))
+                           (string-list-p (cdrc x) subst))))
+
+(defun string-to-list (string)
+  ;; (string-to-list "abc") -> (list "a" "b" "c")
+  (map 'list (lambda (char) (declare-constant (string char))) string))
+
+(defun list-to-string (list &optional subst)
+  ;; (list-to-string (list "a" "b" "c")) -> "abc"
+  ;; list is already dereferenced
+  (cond
+   ((null list)
+    (declare-constant ""))
+   (t
+    (declare-constant (apply #'concatenate 'string (instantiate list subst))))))
+
+(defun list-to-string-term-rewriter (term subst)
+  (let ((x (first (args term))))
+    (if (dereference x subst :if-constant (null x) :if-compound-cons (string-list-p x subst))
+        (list-to-string x subst)
+        none)))
+
+(defun string-to-list-term-rewriter (term subst)
+  (let ((x (first (args term))))
+    (if (dereference x subst :if-constant (stringp x))
+        (string-to-list x)
+        none)))
+
+;;; code-for-strings2.lisp EOF

snark-20120808r02/src/coder.lisp

@@ -0,0 +1,714 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-user -*-
+;;; File: coder.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark-user)
+
+;;; coder finds shortest condensed-detachment proofs
+
+(defstruct (proof-line
+            (:constructor make-proof-line (number
+                                           just
+                                           wff
+                                           &optional
+                                           (wff-size (snark::size wff))
+                                           (wff-vars (snark::variables wff))))
+            (:copier nil))
+  (number 0 :read-only t)
+  (just nil :read-only t)
+  (wff nil :read-only t)
+  (wff-size 0 :read-only t)
+  (wff-vars nil :read-only t)
+  (target nil)
+  (hint nil)
+  (cut nil))
+
+(defvar *coder-start-time*)
+(defvar *coder-run-time-limit*)
+(defvar *coder-step-count*)
+(defvar *coder-derivation-count*)
+(defvar *coder-print-state-interval* 1000000)
+(defvar *coder-maximum-term-size-found*)
+(defvar *coder-maximum-target-size*)
+(defvar *coder-term-size-limit*)
+(defvar *coder-term-vars-limit*)
+(defvar *coder-ordering* :rpo)
+(defvar *coder-do-reverse-cd*)
+
+(defvar *test1* nil)
+(defvar *test2* nil)
+
+(defun coder (axioms target &rest options
+              &key (max 100) (min 1) (max-syms nil) (max-vars nil) (op nil) (variables nil)
+              kill avoid all-proofs must-use resume hints reverse-cd
+              (steps-to-use nil) (steps-to-use-count (length steps-to-use))
+              ((:run-time-limit *coder-run-time-limit*) nil)
+              (*test1* *test1*) (*test2* *test2*))
+  (let ((*print-pretty* nil))
+    (print (cons 'coder (mapcar (lambda (x) (kwote x t)) (list* axioms target options))))
+    (initialize)
+    (cl:assert (>= (length steps-to-use) steps-to-use-count 0))
+    (setf steps-to-use (if (= 0 steps-to-use-count) nil (mapcar #'coder-input-term steps-to-use)))
+    (setf variables (mapcar (lambda (x) (cons x (snark::make-variable))) variables))
+    (setf avoid (mapcar #'(lambda (x) (coder-input-term x variables)) avoid))
+    (use-term-ordering *coder-ordering*)
+    (use-default-ordering 'coder-default-symbol-ordering)
+    (ordering-functions>constants t)
+    (test-option19 t)
+    (prog->
+      (identity 0 -> naxioms)
+      (mapcar (lambda (x) (make-proof-line (incf naxioms) naxioms (coder-input-term x variables))) axioms  -> axioms)
+      (unless op
+        (dolist (x axioms)
+          (let ((x (proof-line-wff x)))
+            (when (and (compound-p x) (eql 2 (length (args x))))
+              (cond
+               ((null op)
+                (setf op (snark::function-name (head x))))
+               ((not (eq op (snark::function-name (head x))))
+                (warn "There is more than one binary relation; using condensed detachment for ~A." op)
+                (return)))))))
+      (reverse axioms -> axioms)
+      (declare-function (if reverse-cd 'rcd 'cd) 2 :ordering-status :left-to-right -> cd)
+      (input-target target -> target target-alist)
+      (and (not (contains-test-target? target))
+           (reduce #'max target-alist :key (lambda (x) (snark::size (cdr x))))
+           -> *coder-maximum-target-size*)
+      (mapcar #'coder-input-term hints -> hints)
+      (identity max-syms -> *coder-term-size-limit*)
+      (identity max-vars -> *coder-term-vars-limit*)
+      (identity reverse-cd -> *coder-do-reverse-cd*)
+      (identity nil -> all-targets-found)
+      (setf *coder-step-count* 0)
+      (setf *coder-derivation-count* 0)
+      (setf *coder-maximum-term-size-found* 0)
+      (get-internal-run-time -> *coder-start-time*)
+      (loop for nsteps from min to max
+            do (let (targets-found)
+                 (format t "~2%Search for ~D-step proof... " nsteps)
+                 (force-output)
+	         (setf targets-found (coder1 axioms target nsteps cd op kill avoid all-proofs must-use resume hints steps-to-use steps-to-use-count))
+	         (setf resume nil)
+                 (let ((run-time (round (- (get-internal-run-time) *coder-start-time*) internal-time-units-per-second)))
+                   (format t "~%~D steps in ~D seconds" *coder-step-count* run-time)
+                   (when (and *coder-run-time-limit* (< *coder-run-time-limit* run-time))
+                     (format t "; time limit exceeded")
+                     (return)))
+                 (when targets-found
+                   (setf target (remove-target target targets-found))
+                   (setf all-targets-found (nconc targets-found all-targets-found))
+                   (when (null target)
+                     (return)))))
+      (format t ".")
+      (mapcar (lambda (x) (or (car (rassoc x target-alist)) x)) all-targets-found))))
+
+(defun coder1 (axioms target nsteps cd op kill avoid all-proofs must-use resume hints steps-to-use steps-to-use-count)
+  (let ((together-target? (together-target? target))
+        (targets-found nil))
+    (labels
+      ((coder2 (lines nsteps unused target* ntargets steps-to-use steps-to-use-count)
+         ;; target* is used to record remaining targets only if target is a together-target
+         (cond
+          ((eql 0 nsteps)
+           (incf *coder-derivation-count*)
+           (cond
+            (together-target?
+             (cl:assert (null target*))		;all targets should have been matched
+             (print-proof lines)
+             (print-proof-for-otter-verification lines op)
+             (force-output)
+             (setf targets-found (rest target))
+             (unless all-proofs
+               (return-from coder1 targets-found)))
+            (t
+             (let ((found (target? target (proof-line-wff (first lines)))))	;is final wff a target?
+               (when found
+                 (setf (proof-line-target (first lines)) found)
+                 (print-proof lines)
+                 (print-proof-for-otter-verification lines op)
+                 (force-output)
+                 (dolist (v found)
+                   (pushnew v targets-found))
+                 (unless all-proofs
+                   (when (null (setf target (remove-target target found)))
+                     (return-from coder1 targets-found))))))))
+          (t
+           (flet
+             ((coder3 (x y xunused? yunused? new-line)
+                (let ((found (and together-target? (target? target* (proof-line-wff new-line)))))
+                  (cond
+                   (found
+                    ;;(princf *coder-step-count*)
+                    (cl:assert (null (rest found)) () "More than one together-target simultaneously satisfied.")
+                    (when (eql 0 (rem (incf *coder-step-count*) *coder-print-state-interval*))
+                      (let ((run-time (- (get-internal-run-time) *coder-start-time*)))
+                        (print-coder-state (cons new-line lines) run-time)
+                        (when (and *coder-run-time-limit* (< *coder-run-time-limit* (round run-time internal-time-units-per-second)))
+                          (return-from coder1 targets-found))))
+                    (setf (proof-line-target new-line) found)
+                    (coder2
+                     (cons new-line lines)
+                     (- nsteps 1)
+                     (let ((unused (if xunused? (remove x unused) unused)))
+                       (if yunused? (remove y unused) unused))
+                     (remove-target target* found)
+                     (- ntargets 1)
+                     steps-to-use
+                     steps-to-use-count))
+                   (t
+                    (let ((new-steps-to-use steps-to-use) (new-steps-to-use-count steps-to-use-count))
+                      (when (< 0 steps-to-use-count)
+                        (setf new-steps-to-use (remove-step-to-use (proof-line-wff new-line) steps-to-use))
+                        (unless (eq steps-to-use new-steps-to-use)
+                          (decf new-steps-to-use-count)))
+                      (cond
+                       ((if together-target?
+                            (>= (- nsteps 1) (+ ntargets new-steps-to-use-count))
+                            (if (= 1 nsteps)
+                                (= 0 steps-to-use-count)
+                                (> (- nsteps 1) new-steps-to-use-count)))
+                        ;;(princf *coder-step-count*)
+                        (when (eql 0 (rem (incf *coder-step-count*) *coder-print-state-interval*))
+                          (let ((run-time (- (get-internal-run-time) *coder-start-time*)))
+                            (print-coder-state (cons new-line lines) run-time)
+                            (when (and *coder-run-time-limit* (< *coder-run-time-limit* (round run-time internal-time-units-per-second)))
+                              (return-from coder1 targets-found))))
+                        (coder2
+                         (cons new-line lines)
+                         (- nsteps 1)
+                         (let ((unused (if xunused? (remove x unused) unused)))
+                           (cons new-line (if yunused? (remove y unused) unused)))
+                         target*
+                         ntargets
+                         new-steps-to-use
+                         new-steps-to-use-count)))))))))
+             (declare (dynamic-extent #'coder3))
+             (let ((new-lines nil)
+                   (new-line-number (+ (proof-line-number (first lines)) 1)))
+               (let ((nunused (length unused))
+                     (revlines (reverse lines)))
+                 (dolist (x revlines)		;use reverse to reorder search 2003-04-17
+                   (let ((xunused? (member x unused))
+                         (big nil))
+                     (dolist (y revlines)	;use reverse to reorder search 2004-01-10
+                       (let ((yunused? (and (not (eq x y)) (member y unused))))
+                         (unless (> (if xunused?
+                                        (if yunused? (- nunused 1) nunused)
+                                        (if yunused? nunused (+ nunused 1)))
+                                    (if (eql 1 ntargets) nsteps (+ nsteps ntargets -1)))
+                           (let ((just (make-compound cd (proof-line-just x) (proof-line-just y))))
+                             (when (or big
+                                       (and (eq '> (snark::simplification-ordering-compare-terms0
+                                                    just (proof-line-just (first lines)) nil '>))
+                                            (setf big t)))
+                             (prog->
+                               (do-cd (proof-line-wff x) (proof-line-wff y) op (eql ntargets nsteps) ->* new-wff new-wff-size cut)
+                               (if new-wff-size
+                                   (make-proof-line new-line-number just new-wff new-wff-size)
+                                   (make-proof-line new-line-number just new-wff)
+                                   -> new-line)
+                               (when cut
+                                 (setf (proof-line-cut new-line) t))
+                               (cond
+                                ((and resume
+                                      (let ((l1 resume) (l2 (coder-state (cons new-line lines))))
+                                        (loop
+                                          (cond
+                                           ((null l1)
+                                            (setf resume nil)
+                                            (setf *coder-step-count* -1)
+                                            (return nil))
+                                           ((null l2)
+                                            (return nil))
+                                           ((not (equal (pop l1) (pop l2)))
+                                            (return t))))))
+                                 )
+                                ((or hints *test1* *test2*)
+                                 (cond
+                                  ((and kill (funcall kill new-line))
+                                   )
+                                  ((and *test2* (backward-subsumes? new-line lines))
+                                   ;; reject all derivations beginning with lines
+                                   ;; when new-line is equal to an earlier line
+                                   ;; as well as when it strictly subsumes it
+                                   ;; as in the case below
+                                   (return-from coder2))
+                                  ((forward-subsumed? new-line lines)
+                                   )
+                                  ((and (not *test2*) (backward-subsumes? new-line lines))
+                                   ;; don't just block adding new-line to lines but
+                                   ;; reject all derivations beginning with lines
+                                   (return-from coder2))
+                                  (t
+                                   (push (list x y xunused? yunused? new-line) new-lines))))
+                                (t
+                                 (unless (or (and kill (funcall kill new-line))
+                                             (and avoid (member (proof-line-wff new-line) avoid :test #'snark::variant-p))
+                                             (forward-subsumed? new-line lines)
+                                             (backward-subsumes? new-line lines))
+                                   (coder3 x y xunused? yunused? new-line))))
+                               (when cut
+                                 (return)))))))))))
+               (when new-lines
+                 (dolist (new-line (if hints (sort-new-lines new-lines hints) (nreverse new-lines)))
+                   (apply #'coder3 new-line)))))))))
+      (let ((ntargets (if together-target? (length (rest target)) 1)))
+        (unless (> (+ ntargets steps-to-use-count) nsteps)
+          (coder2 axioms nsteps (selected-lines axioms must-use) target ntargets steps-to-use steps-to-use-count)))
+      targets-found)))
+
+(defun sort-new-lines (new-lines hints)
+  (dolist (x new-lines)
+    (when (member (proof-line-wff (fifth x)) hints :test #'snark::subsumes-p)
+      (setf (proof-line-hint (fifth x)) t)))
+  (stable-sort (nreverse new-lines)
+               (lambda (x y)
+                 (and (proof-line-hint (fifth x))
+                      (not (proof-line-hint (fifth y)))))))
+
+(defun selected-lines (lines nums)
+  (cond
+   ((eq t nums)
+    lines)
+   (t
+    (remove-if (lambda (line) (not (member (proof-line-number line) nums))) lines))))
+
+(defun coder-default-symbol-ordering (x y)
+  (if (numberp x)
+      (if (and (numberp y) (> x y)) '> '<)
+      '>))
+
+(defun forward-subsumed? (new-line lines)
+  ;; return true iff new-line is subsumed by an earlier line
+  (let ((new-wff (proof-line-wff new-line))
+        (new-wff-size (proof-line-wff-size new-line))
+        (new-wff-vars (proof-line-wff-vars new-line)))
+    (dolist (l lines nil)
+      (when (and (>= new-wff-size (proof-line-wff-size l))
+                 (snark::subsumed-p1 new-wff (proof-line-wff l) new-wff-vars))
+        (return t)))))
+
+(defun backward-subsumes? (new-line lines)
+  ;; return true iff new-line subsumes an earlier line that is not used to derive new-line
+  (let ((new-wff (proof-line-wff new-line))
+        (new-wff-size (proof-line-wff-size new-line)))
+    (dolist (l lines nil)
+      (let ((j (proof-line-just l)))
+        ;; don't backward subsume axioms or ancestors
+        (cond
+         ((not (compound-p j))	;l and rest of lines are all axioms
+          (return nil))
+         ((and (<= new-wff-size (proof-line-wff-size l))
+               (snark::subsumes-p1 new-wff (proof-line-wff l) (proof-line-wff-vars l))
+               (not (snark::occurs-p j (proof-line-just new-line) nil)))
+          (return t)))))))
+
+(defun do-cd (function x y op &optional last-line)
+  ;; perform condensed detachment operation
+  ;; with x as major premise and y as minor premise
+  ;; assume x and y are variable disjoint unless (eq x y)
+  ;; return result with new variables
+  (prog->
+    (when (and (compound-p x) (eq op (function-name (head x))))
+      (args x -> args)
+      (first args -> x1)
+      (second args -> x2)
+      (when *coder-do-reverse-cd*
+        (psetf x1 x2 x2 x1))
+      ;; (cd (i x t) s) always yields t for any s if x does not occur in t
+      ;; producing alternative derivations which differ only in which minor premise is used
+      ;; used to be enabled by *test3*, default since 2003-08-14
+      (and (snark::variable-p x1) (not (snark::occurs-p x1 x2)) -> cut)
+      ;; in this case, use same wff as major and minor premise, to avoid unnecessary use of y
+      ;; added 2003-11-30
+      (when (and cut (not (eq x y)))
+        (return-from do-cd))
+      (unify x1 (if (eq x y) (snark::renumber-new y) y) ->* subst)
+      (snark::size x2 subst -> n)
+      ;; don't create big terms that cannot subsume a target for the last line of proof
+      (unless (or (and last-line *coder-maximum-target-size* (< *coder-maximum-target-size* n))
+                  (and *coder-term-size-limit* (< *coder-term-size-limit* n))
+                  (and *coder-term-vars-limit* (< *coder-term-vars-limit* (length (snark::variables x2 subst)))))
+        (when (and (not *coder-term-size-limit*) (< *coder-maximum-term-size-found* n))
+          (format t " ~D syms " n)
+          (force-output)
+          (setf *coder-maximum-term-size-found* n))
+        (snark::renumber-new x2 subst -> x2*)
+        (unless cut
+          (setf cut (snark::variant-p x2 x2*)))
+        (funcall function x2* n cut)))))
+
+(defun just-line-number (j lines)
+  (proof-line-number (first (member j lines :key #'proof-line-just :test #'equal-p))))
+
+(defun just-list (j lines)
+  (if (compound-p j)
+      (cons (function-name (head j))
+            (mapcar (lambda (x)
+                      (if (compound-p x) (just-line-number x lines) x))
+                    (args j)))
+      j))
+
+(defun print-proof-line-just (line lines)
+  (let ((n (proof-line-number line))
+        (j (just-list (proof-line-just line) lines)))
+    (format t "~2D ~A" n (if (eql n j) 'ax j)))
+  (when (proof-line-cut line)
+    (format t "!")))
+
+(defun print-proof-line (line lines)
+  (let ((j (proof-line-just line)))
+    (format t "~%(") (print-proof-line-just line lines) (format t "~15T")
+    (print-term (snark::renumber (proof-line-wff line)))
+    (format t ")")
+    (cond
+     ((compound-p j)
+      (format t "~84T;~2D sym~:P, ~D var~:P"
+              (snark::size (proof-line-wff line))
+              (length (snark::variables (proof-line-wff line))))
+      (when (proof-line-target line)
+        (format t " target")))
+     ((not (member j lines
+                   :key #'proof-line-just
+                   :test (lambda (x y) (and (not (snark::equal-p x y)) (snark::occurs-p x y nil)))))
+      (format t "~84T;unused")))))
+
+(defun print-proof-lines (lines)
+  (mapc (lambda (line) (print-proof-line line lines)) lines))
+
+(defun print-proof (lines)
+  (format t "~2%Proof:")
+  (print-proof-lines (reverse lines))
+  (format t "~%End proof.")
+  (terpri))
+
+(defun coder-state (lines)
+  (let ((lines (reverse lines)))
+    (mapcan (lambda (line)
+              (let ((j (just-list (proof-line-just line) lines)))
+                (if (consp j) (list j) nil)))
+            lines)))
+
+(defun print-coder-state (lines &optional (run-time (- (get-internal-run-time) *coder-start-time*)))
+  (format t "~%  ~A ~5Dm "
+          (subseq (print-current-time nil t) 4 13)
+          (round run-time (* 60 internal-time-units-per-second)))
+  (mapc (lambda (x) (princ x) (princ " ")) (coder-state lines))
+  (force-output))
+
+;;; coder's target argument is either a normal-target or a together-target
+;;;
+;;; a single-target is one of
+;;;   a term - find generalization (or variant) of this term
+;;;   (TEST predicate)
+;;;
+;;; a normal-target is one of
+;;;   a single-target
+;;;   (OR normal-target1 ... normal-targetn)  - search until one target is found
+;;;   (AND normal-target1 ... normal-targetn) - search until all targets are found
+;;;
+;;; a together-target is
+;;;   (TOGETHER single-target1 ... single-targetn) - search until all targets are found in a single derivation
+;;;   it is assumed that no single formula will satisfy more than one of these targets
+
+(defvar *input-target-alist*)
+
+(defun input-target (target)
+  (let ((*input-target-alist* nil))
+    (values (cond
+             ((together-target? target)
+              (input-together-target target))
+             (t
+              (input-normal-target target)))
+            *input-target-alist*)))
+
+(defun together-target? (target)
+  (and (consp target) (eq 'together (first target))))
+
+(defun contains-test-target? (target)
+  (case (and (consp target) (first target))
+    (test
+     t)
+    ((and or together)
+     (some #'contains-test-target? (rest target)))))
+
+(defun wrap2 (f l)
+  (cl:assert (consp l))
+  (if (null (rest l)) (first l) (cons f l)))
+
+(defun coder-input-term (x &optional variables)
+  (snark::renumber-new
+   (snark::input-term
+    (if (stringp x) (read-infix-term x :case (readtable-case *readtable*)) x)
+    :*input-wff-substitution* variables)))
+
+(defun input-together-target (target)
+  (wrap2 (first target) (mapcar #'input-single-target (rest target))))
+
+(defun input-normal-target (target)
+  (cond
+   ((and (consp target) (member (first target) '(or and)))
+    (wrap2 (first target) (mapcar #'input-normal-target (rest target))))
+   (t
+    (input-single-target target))))
+
+(defun input-single-target (target)
+  (cl:assert (not (and (consp target) (member (first target) '(or and together)))))
+  (cond
+   ((and (consp target) (eq 'test (first target)))
+    target)
+   (t
+    (let ((target* (coder-input-term target)))
+      (push (cons target target*) *input-target-alist*)
+      target*))))
+
+(defun target? (target x &optional l)
+  ;; does x generalize a term in target?
+  (cond
+   ((and (consp target) (member (first target) '(or and together)))
+    (dolist (y (rest target) l)
+      (setf l (target? y x l))))
+   ((and (consp target) (eq 'test (first target)))
+    (if (funcall (second target) x) (adjoin target l) l))
+   (t
+    (if (snark::subsumes-p x target) (adjoin target l) l))))
+
+(defun remove-target (target l)
+  (cond
+   ((and (consp target) (eq 'or (first target)))
+    (let ((v (mapcar (lambda (y)
+                        (let ((y* (remove-target y l)))
+                          (or y* (return-from remove-target nil))))
+                      (rest target))))
+      (wrap2 'or v)))
+   ((and (consp target) (member (first target) '(and together)))
+    (let ((v (mapcan (lambda (y)
+                       (let ((y* (remove-target y l)))
+                         (and y* (list y*))))
+                     (rest target))))
+      (and v (wrap2 (first target) v))))
+   (t
+    (if (member target l) nil target))))
+
+(defun remove-step-to-use (wff steps-to-use)
+  (cond
+   ((null steps-to-use)
+    nil)
+   ((snark::subsumes-p wff (first steps-to-use))
+    (rest steps-to-use))
+   (t
+    (let* ((l (rest steps-to-use))
+           (l* (remove-step-to-use wff l)))
+      (if (eq l l*) steps-to-use (cons (first steps-to-use) l*))))))
+
+(defun print-proof-for-otter-verification (lines op)
+  ;; Bob Veroff provided the template for this script
+  (let ((lines (reverse lines)))
+    (format t "~%% OTTER SCRIPT TO TRY TO FIND SAME PROOF")
+    (format t "~%  set(hyper_res). clear(print_kept). clear(print_back_sub). assign(stats_level,0).")
+    (format t "~%  assign(bsub_hint_add_wt,-1000000). set(keep_hint_subsumers). assign(max_weight,1).")
+    (format t "~%  list(sos).                    % AXIOMS:")
+    (dolist (l lines)
+      (unless (compound-p (proof-line-just l))
+        (format t "~%    ") (print-term-for-otter2 (proof-line-wff l)) (format t ".")))
+    (format t "~%    end_of_list.")
+    (cond
+     (*coder-do-reverse-cd*
+      (format t "~%  list(usable).                 % REVERSED CONDENSED DETACHMENT RULE:")
+      (format t "~%    -P(~A(x,y)) | -P(y) | P(x)." (string-downcase (string op))))
+     (t
+      (format t "~%  list(usable).                 % CONDENSED DETACHMENT RULE:")
+      (format t "~%    -P(~A(x,y)) | -P(x) | P(y)." (string-downcase (string op)))))
+    (format t "~%    end_of_list.")
+    (let ((first t))
+      (dolist (l lines)
+        (when (proof-line-target l)
+          (cond
+           (first
+            (setf first nil)
+            (format t "~%  list(usable).                 % TARGET:"))
+           (t
+            (format t " |")))
+          (format t "~%    -") (print-term-for-otter2 (proof-line-wff l) t)))
+      (unless first
+        (format t ".~%    end_of_list.")))
+    (format t "~%  list(hints).                  % PROOF LINES:")
+    (dolist (l lines)
+      (format t "~%    ") (print-term-for-otter2 (proof-line-wff l)) (format t ".")
+      (format t "~72T%") (print-proof-line-just l lines)
+      (when (proof-line-target l)
+        (format t " TARGET")))
+    (format t "~%    end_of_list.")
+    (format t "~%% OTTER SCRIPT END~%")
+    ))
+
+(defun print-term-for-otter2 (term &optional ground)
+  (princ "P(")
+  (print-term-for-otter (snark::renumber term) ground)
+  (princ ")")
+  term)
+
+(defun print-term-for-otter (term &optional ground)
+  (dereference
+   term nil
+   :if-variable (cond
+                 (ground
+                  (princ #\c)
+                  (princ (snark::variable-number term)))
+                 (t
+                  (let ((n (snark::variable-number term)))
+                    (cond
+                     ((> 6 n)
+                      (princ (ecase n (0 #\x) (1 #\y) (2 #\z) (3 #\u) (4 #\v) (5 #\w))))
+                     (t
+                      (princ #\v)
+                      (princ n))))))
+   :if-constant (cond
+                 ((numberp term)
+                  (princ term))
+                 (t
+                  (princ #\c)
+                  (princ (string-downcase (string term)))))
+   :if-compound (progn 
+                  (princ (string-downcase (string (function-name (head term)))))
+                  (princ "(")
+                  (let ((first t))
+                    (dolist (arg (args term))
+                      (if first (setf first nil) (princ ","))
+                      (print-term-for-otter arg ground)))
+                  (princ ")")))
+  term)
+
+(defun comb (n m)
+  (/ (let ((v 1))
+       (dotimes (i m)
+         (setf v (* v (- n i))))
+       v)
+     (let ((v 1))
+       (dotimes (i (- m 1))
+         (setf v (* v (+ i 2))))
+       v)))
+
+(defun shorten-proof (proof &rest options
+                            &key (drop 3) (shorten-by 1) (naxioms 1) (targets '(-1)) all-proofs skip from to min max
+                            (variables '(x y z u v w v0
+					 x1 y1 z1 u1 v1 w1  v6  v7  v8  v9 v10 v11
+					 x2 y2 z2 u2 v2 w2 v12 v13 v14 v15 v16 v17
+					 x3 y3 z3 u3 v3 w3 v18 v19 v20 v21 v22 v23
+					 x4 y4 z4 u4 v4 w4 v24 v25 v26 v27 v28 v29
+					 x5 y5 z5 u5 v5 w5 v30 v31 v32 v33 v34 v35)))
+  ;; attempt to find a shorter proof than argument proof (a list of formulas)
+  ;; default is to assume there is a single axiom (first in proof) and single target (last in proof)
+  ;; to try to find a shorter proof,
+  ;; omit drop steps and search for a proof with fewer than drop steps to replace them
+  ;;
+  ;; :drop 0 :shorten-by 0 options can be used to reproduce proof
+  (print (cons 'shorten-proof (mapcar (lambda (x) (kwote x t)) (list* proof options))))
+  (when skip
+    (cl:assert (null from))
+    (setf from (+ skip 1)))
+  (let* ((l proof)
+         (proof-length (length proof))
+         (nsteps (- proof-length naxioms))
+         (target nil)
+         (source nil)
+         (found nil)
+         (count 0))
+    (dolist (i (reverse targets))		;collect targets into target
+      (push (nth (if (> 0 i) (+ proof-length i) i) proof) target))
+    (dotimes (i naxioms)	;collect axioms into source
+      (declare (ignorable i))
+      (push (pop l) source))
+    (when (eql 1 naxioms)			;if there is only one axiom, first step is forced,
+      (unless (or (member 2 targets) (member (- 1 proof-length) targets))
+        (setf l (rest l))))			;so omit it from candidates to be replaced
+    (setf l (set-difference l target))		;l is now list of potentially replaceable nontarget steps
+    (prog->
+      (length l -> len)
+      (comb len drop -> ncombs)
+      (choose l (- len drop) ->* kept-steps)	;shorten l by drop steps in all ways
+      (incf count)
+      (when (and to (< to count))
+        (return-from prog->))
+      (when (implies from (<= from count))
+        (format t "~2%Shorten proof attempt ~D of ~D" count ncombs)
+        (when (coder source
+                     (cons 'together (append target kept-steps))
+                     :min (or min (- nsteps drop))
+                     :max (or max (- nsteps shorten-by))
+                     :all-proofs all-proofs
+                     :variables variables)
+          (setf found t)
+          (unless all-proofs
+            (return-from prog->)))))
+    found))
+
+(defun strip-ors (wff)
+  (cond
+   ((and (consp wff) (eq 'or (first wff)))
+    (reduce #'append (mapcar #'strip-ors (rest wff))))
+   (t
+    (list wff))))
+
+(defun condensed-detachment-rule-p (wff)
+  ;; recognizer for (or (not (p (i ?x ?y))) (or (not (p ?x)) (p ?y)))
+  (let ((l (strip-ors wff)))
+    (and (= 3 (length l))
+         (let ((subst (some (lambda (x)
+                              (let ((subst (pattern-match '(not (?pred (?fun ?var1 ?var2))) x)))
+                                (and subst
+                                     (let ((var1 (sublis subst '?var1))
+                                           (var2 (sublis subst '?var2)))
+                                       (and (neq var1 var2)
+                                            (can-be-free-variable-name var1)
+                                            (can-be-free-variable-name var2)))
+                                     subst)))
+                            l)))
+           (and (member (sublis subst '(not (?pred ?var1))) l :test #'equal)
+                (member (sublis subst '(?pred ?var2)) l :test #'equal)
+                subst)))))
+
+(defun condensed-detachment-problem-p (assertions)
+  (and (every (lambda (x) (and (consp x) (eq 'assertion (first x)))) assertions)
+       (multiple-value-bind
+         (cd-rule subst)
+         (dolist (x assertions)
+           (let ((x (second x)))
+             (let ((subst (condensed-detachment-rule-p x)))
+               (when subst
+                 (return (values x subst))))))
+         (and cd-rule
+              (let ((axioms nil)
+                    (target nil)
+                    (axiom-pattern (sublis subst '((?pred ?x))))
+                    (target-pattern (sublis subst '(not (?pred ?x)))))
+                (dolist (x assertions (and axioms target (values (reverse axioms) target (sublis subst '?fun) (sublis subst '?pred))))
+                  (let ((x (second x)))
+                    (unless (eq cd-rule x)
+                      (let ((x (strip-ors x)))
+                        (cond
+                         ((pattern-match axiom-pattern x)
+                          (push (second (first x)) axioms))
+                         ((and (null target) (every (lambda (x) (pattern-match target-pattern x)) x))
+                          (setf target (if (null (rest x))
+                                           (second (second (first x)))
+                                           (cons 'together (mapcar (lambda (x) (second (second x))) x)))))
+                         (t
+                          (return nil))))))))))))
+
+;;; coder.lisp EOF

snark-20120808r02/src/collectors.lisp

@@ -0,0 +1,143 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
+;;; File: collectors.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark-lisp)
+
+(defun make-collector ()
+  (cons nil nil))
+
+(defun collector-value (collector)
+  (car collector))
+
+(defun collect-item (x collector)
+  ;; as in Interlisp TCONC,
+  ;; add single element x to the end of the list in (car collector)
+  ;; and update (cdr collector) to point to the end of the list
+  (setf x (cons x nil))
+  (cond
+    ((null collector)
+     (cons x x))
+    ((null (car collector))
+     (rplacd collector (setf (car collector) x)))
+    (t
+     (rplacd collector (setf (cddr collector) x)))))
+
+(defun collect-list (l collector)
+  ;; as in Interlisp LCONC,
+  ;; add list l to the end of the list in (car collector)
+  ;; and update (cdr collector) to point to the end of the list
+  (cond
+    ((null l)
+     collector)
+    ((null collector)
+     (cons l (last l)))
+    ((null (car collector))
+     (rplacd collector (last (setf (car collector) l))))
+    (t
+     (rplacd collector (last (setf (cddr collector) l))))))
+
+(defstruct (queue
+            (:constructor make-queue ())
+            (:copier nil))
+  (list nil :type list)
+  (last nil :type list))
+
+(defun queue-empty-p (queue)
+  (null (queue-list queue)))
+
+(defun enqueue (item queue)
+  (let ((l (cons item nil)))
+    (setf (queue-last queue) (if (queue-list queue) (setf (rest (queue-last queue)) l) (setf (queue-list queue) l)))
+    item))
+
+(defun dequeue (queue)
+  (let ((l (queue-list queue)))
+    (if l
+        (prog1 (first l) (setf (queue-list queue) (or (rest l) (setf (queue-last queue) nil))))
+        nil)))
+
+(defmacro collect (item place)
+  ;; like (setf place (nconc place (list item)))
+  ;; except last cell of list is remembered in place-last
+  ;; so that operation is O(1)
+  ;; it can be used instead of (push item place) + (nreverse place) loop idiom
+  ;; user must declare place-last variable or slot
+  (let* ((args (if (atom place)
+		   nil
+		   (mapcar (lambda (arg) (list (gensym) arg)) (rest place))))
+         (place (if (atom place)
+		    place
+		    (cons (first place) (mapcar #'first args))))
+         (place-last (if (atom place)
+                         (intern (concatenate
+				  'string
+				  (symbol-name place)
+				  (symbol-name :-last)))
+                         (cons (intern (concatenate
+					'string
+					(symbol-name (first place))
+					(symbol-name :-last)))
+                               (rest place))))
+         (v (gensym))
+         (l (gensym)))
+    `(let* ((,v (cons ,item nil)) ,@args (,l ,place))
+       (cond
+        ((null ,l)
+         (setf ,place (setf ,place-last ,v)))
+        (t
+         (rplacd ,place-last (setf ,place-last ,v))
+         ,l)))))
+
+(defmacro ncollect (list place)
+  ;; like (setf place (nconc place list))
+  ;; except last cell of list is remembered in place-last
+  (let* ((args (if (atom place)
+		   nil
+		   (mapcar (lambda (arg) (list (gensym) arg)) (rest place))))
+         (place (if (atom place)
+		    place
+		    (cons (first place) (mapcar #'first args))))
+         (place-last (if (atom place)
+                         (intern (concatenate
+				  'string
+				  (symbol-name place)
+				  (symbol-name :-last)))
+                         (cons (intern (concatenate
+					'string
+					(symbol-name (first place))
+					(symbol-name :-last)))
+                               (rest place))))
+         (v (gensym))
+         (l (gensym))
+         (e (gensym)))
+    `(let* ((,v ,list) ,@args (,l ,place))
+       (if  (null ,v)
+            ,l
+            (let ((,e (rest ,v)))
+              (setf ,e (if (null ,e) ,v (last ,e)))
+              (cond
+               ((null ,l)
+                (setf ,place-last ,e)
+                (setf ,place ,v))
+               (t
+                (rplacd ,place-last ,v)
+                (setf ,place-last ,e)
+                ,l)))))))
+
+;;; collectors.lisp EOF

snark-20120808r02/src/connectives.lisp

@@ -0,0 +1,550 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: connectives.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+;;; wff = well-formed formula
+;;; atom = atomic fomula
+
+(defun not-wff-error (x &optional subst)
+  (error "~A is not a formula." (term-to-lisp x subst)))
+
+(defun not-clause-error (x &optional subst)
+  (error "~A is not a clause." (term-to-lisp x subst)))
+
+(defun head-is-logical-symbol (wff)
+  (dereference
+    wff nil
+    :if-constant      nil
+    :if-variable      (not-wff-error wff)
+    :if-compound-cons (not-wff-error wff)
+    :if-compound-appl (function-logical-symbol-p (heada wff))))
+
+(defun negation-p (wff)
+  (eq 'not (head-is-logical-symbol wff)))
+
+(defun conjunction-p (wff)
+  (eq 'and (head-is-logical-symbol wff)))
+
+(defun disjunction-p (wff)
+  (eq 'or (head-is-logical-symbol wff)))
+
+(defun implication-p (wff)
+  (eq 'implies (head-is-logical-symbol wff)))
+
+(defun reverse-implication-p (wff)
+  (eq 'implied-by (head-is-logical-symbol wff)))
+
+(defun equivalence-p (wff)
+  (eq 'iff (head-is-logical-symbol wff)))
+
+(defun exclusive-or-p (wff)
+  (eq 'xor (head-is-logical-symbol wff)))
+
+(defun conditional-p (wff)
+  (eq 'if (head-is-logical-symbol wff)))
+
+(defun universal-quantification-p (wff)
+  (eq 'forall (head-is-logical-symbol wff)))
+
+(defun existential-quantification-p (wff)
+  (eq 'exists (head-is-logical-symbol wff)))
+
+(defun atom-p (wff)
+  (not (head-is-logical-symbol wff)))
+
+(defun literal-p (wff &optional (polarity :pos) strict)
+  ;; returns (values atom polarity)
+  ;; only atomic formulas and negated atomic formulas are strict literals
+  ;; nonstrict literals can have nested negations
+  (let ((v (head-is-logical-symbol wff)))
+    (cond
+     ((null v)
+      (values wff polarity))
+     ((eq 'not v)
+      (let ((wff1 (arg1a wff)))
+        (if strict
+            (and (atom-p wff1) (values wff1 (opposite-polarity polarity)))
+            (literal-p wff1 (opposite-polarity polarity)))))
+     (t
+      nil))))
+
+(defun clause-p (wff &optional no-true-false strict neg)
+  ;; only atomic formulas, negated atomic formulas, their disjunctions, and (optionally) true and false are strict clauses
+  ;; nonstrict clauses are implications etc. interpretable as single clauses
+  (labels
+    ((clause-p (wff neg)
+       (case (head-is-logical-symbol wff)
+         ((nil)
+          (implies no-true-false (not (or (eq true wff) (eq false wff)))))
+         (not
+          (if strict
+              (atom-p (arg1a wff))
+              (clause-p (arg1a wff) (not neg))))
+         (and
+          (and (not strict)
+               neg
+               (dolist (arg (argsa wff) t)
+                 (unless (clause-p arg t)
+                   (return nil)))))
+         (or
+          (and (not neg)
+               (if strict
+                   (dolist (arg (argsa wff) t)
+                     (unless (literal-p arg :pos t)
+                       (return nil)))
+                   (dolist (arg (argsa wff) t)
+                     (unless (clause-p arg nil)
+                       (return nil))))))
+         (implies
+          (and (not strict)
+               (not neg)
+               (let ((args (argsa wff)))
+                 (and (clause-p (first args) t)
+                      (clause-p (second args) nil)))))
+         (implied-by
+          (and (not strict)
+               (not neg)
+               (let ((args (argsa wff)))
+                 (and (clause-p (first args) nil)
+                      (clause-p (second args) t))))))))
+    (clause-p wff neg)))
+
+(defun equality-relation-symbol-p (fn)
+  (eq '= (function-boolean-valued-p fn)))
+
+(defun equality-p (wff)
+  (dereference
+    wff nil
+    :if-constant      nil
+    :if-variable      (not-wff-error wff)
+    :if-compound-cons (not-wff-error wff)
+    :if-compound-appl (equality-relation-symbol-p (head wff))))
+
+(defun positive-equality-wff-p (wff)
+  ;; nothing but strictly positive occurrences of equalities
+  (prog->
+    (map-atoms-in-wff wff ->* atom polarity)
+      (unless (and (eq :pos polarity) (equality-p atom))
+	(return-from positive-equality-wff-p nil)))
+  t)
+
+(declare-snark-option eliminate-negations nil nil)
+(declare-snark-option flatten-connectives t t)	;e.g., replace (and a (and b c)) by (and a b c)
+(declare-snark-option ex-join-negation t t)	;e.g., replace (equiv a false) by (not a)
+
+(defun conjoin* (wffs &optional subst)
+  (ao-join* wffs subst *and* true))
+
+(defun disjoin* (wffs &optional subst)
+  (ao-join* wffs subst *or* false))
+
+(defun conjoin (wff1 wff2 &optional subst)
+  (cond
+    ((or (eq wff1 wff2) (eq true wff1) (eq false wff2))
+     wff2)
+    ((or (eq false wff1) (eq true wff2))
+     wff1)
+    (t
+     (ao-join* (list wff1 wff2) subst *and* true))))
+
+(defun disjoin (wff1 wff2 &optional subst)
+  (cond
+    ((or (eq wff1 wff2) (eq false wff1) (eq true wff2))
+     wff2)
+    ((or (eq true wff1) (eq false wff2))
+     wff1)
+    (t
+     (ao-join* (list wff1 wff2) subst *or* false))))
+
+(defun ao-join* (wffs subst connective identity)
+  ;; create conjunction or disjunction of wffs
+  ;; handle true, false, equal and complementary wffs
+  (do ((not-identity (if (eq true identity) false true))
+       (wffs* nil) wffs*-last
+       (poswffs* nil)
+       (negwffs* nil)
+       wff)
+      ((null wffs)
+       (cond
+        ((null wffs*)
+         identity)
+        ((null (rest wffs*))
+         (first wffs*))
+        ((flatten-connectives?)
+         (make-compound* connective wffs*))
+        (t
+         (make-compound2 connective wffs*))))
+    (setf wff (pop wffs))
+    (when subst
+      (setf wff (instantiate wff subst)))
+    (cond
+     ((and (compound-p wff) (eq connective (head wff)))
+      (setf wffs (if wffs (append (argsa wff) wffs) (argsa wff))))
+     (t
+      (mvlet (((values wff neg) (not-not-eliminate wff)))
+        (if neg
+            (cond
+             ((and poswffs* (hts-member-p neg poswffs*))
+              (return not-identity))
+             ((hts-adjoin-p neg (or negwffs* (setf negwffs* (make-hash-term-set))))
+              (collect wff wffs*)))
+            (cond
+             ((eq identity wff)
+              )
+             ((eq not-identity wff)
+              (return not-identity))
+             ((and negwffs* (hts-member-p wff negwffs*))
+              (return not-identity))
+             ((hts-adjoin-p wff (or poswffs* (setf poswffs* (make-hash-term-set))))
+              (collect wff wffs*)))))))))
+
+(defun not-not-eliminate (wff)
+  (let ((neg nil) -wff)
+    (loop
+      (dereference
+       wff nil
+       :if-variable (return-from not-not-eliminate
+                      (if neg (values -wff wff) wff))
+       :if-constant (return-from not-not-eliminate
+                      (cond
+                       ((eq true wff)
+                        (if neg false true))
+                       ((eq false wff)
+                        (if neg true false))
+                       (t
+                        (if neg (values -wff wff) wff))))
+       :if-compound (cond
+                     ((eq *not* (head wff))
+                      (if neg (setf neg nil) (setf neg t -wff wff))
+                      (setf wff (arg1a wff)))
+                     (t
+                      (return-from not-not-eliminate
+                        (if neg (values -wff wff) wff))))))))
+
+(defun make-equivalence* (wffs &optional subst)
+  (ex-join* wffs subst *iff* true))
+
+(defun make-exclusive-or* (wffs &optional subst)
+  (ex-join* wffs subst *xor* false))
+
+(defun make-equivalence (wff1 wff2 &optional subst)
+  (cond
+    ((eq wff1 wff2)
+     true)
+    ((eq true wff1)
+     wff2)
+    ((eq true wff2)
+     wff1)
+    (t
+     (make-equivalence* (list wff1 wff2) subst))))
+
+(defun make-exclusive-or (wff1 wff2 &optional subst)
+  (cond
+    ((eq wff1 wff2)
+     false)
+    ((eq false wff1)
+     wff2)
+    ((eq false wff2)
+     wff1)
+    (t
+     (make-exclusive-or* (list wff1 wff2) subst))))
+
+(defun ex-join* (wffs subst connective identity)
+  ;; create equivalence or exclusive-or of wffs
+  ;; handle true, false, equal and complementary wffs
+  (let ((not-identity (if (eq true identity) false true))
+	n n1 n2 negate)
+    (setf n (length (setf wffs (argument-list-a1 connective wffs subst identity))))
+    (setf n1 (length (setf wffs (remove not-identity wffs))))
+    (setf negate (oddp (- n n1)))
+    (setf n n1)
+    (do ((wffs* nil) wff)
+	((null wffs)
+	 (cond
+	   ((null wffs*)
+	    (if negate not-identity identity))
+	   (t
+	    (when negate
+	      (setf wffs* (if (ex-join-negation?)
+			      (cons (negate (first wffs*)) (rest wffs*))
+			      (cons not-identity wffs*))))
+	    (cond
+	      ((null (rest wffs*))
+	       (first wffs*))
+	      ((flatten-connectives?)
+	       (make-compound* connective (nreverse wffs*)))
+	      (t
+	       (make-compound2 connective (nreverse wffs*)))))))
+      (setf wff (pop wffs))
+      (setf n1 (length (setf wffs (remove wff wffs :test (lambda (x y) (equal-p x y subst))))))
+      (setf n2 (length (setf wffs (remove wff wffs :test (lambda (x y) (complement-p x y subst))))))
+      (psetq n1 (- n n1)			;count of wff in wffs
+	     n2 (- n1 n2)			;count of ~wff in wffs
+	     n n2)				;length of new value of wffs
+      (cond
+       ((evenp n1)
+        (when (oddp n2)
+          (push wff wffs*)
+          (setf negate (not negate))	;was wrong (setf negate t); fixed 2011-05-13
+          ))
+       ((evenp n2)
+        (push wff wffs*))
+       (t
+        (setf negate (not negate))	;was wrong (setf negate t); fixed 2011-05-13
+        )))))
+
+(defun negate0 (wffs &optional subst)
+  (declare (ignore subst))
+  (cl:assert (eql 1 (length wffs)))
+  (make-compound* *not* wffs))
+
+(defun negate* (wffs &optional subst)
+  (cl:assert (eql 1 (length wffs)))
+  (negate (first wffs) subst))
+
+(defun make-implication* (wffs &optional subst)
+  (cl:assert (eql 2 (length wffs)))
+  (make-implication (first wffs) (second wffs) subst))
+
+(defun make-reverse-implication* (wffs &optional subst)
+  (cl:assert (eql 2 (length wffs)))
+  (make-reverse-implication (first wffs) (second wffs) subst))
+
+(defun make-conditional* (wffs &optional subst)
+  (cl:assert (eql 3 (length wffs)))
+  (make-conditional (first wffs) (second wffs) (third wffs) subst))
+
+(defun make-conditional-answer* (wffs &optional subst)
+  (cl:assert (eql 3 (length wffs)))
+  (make-conditional-answer (first wffs) (second wffs) (third wffs) subst))
+
+(defun negate (wff &optional subst)
+  (dereference
+    wff subst
+    :if-constant (cond
+		   ((eq true wff)
+		    false)
+		   ((eq false wff)
+		    true)
+                   ((eliminate-negations?)
+                    (proposition-complementer wff))
+		   (t
+		    (make-compound *not* wff)))
+    :if-variable (not-wff-error wff)
+    :if-compound-cons (not-wff-error wff)
+    :if-compound-appl (let ((head (heada wff)))
+		        (ecase (function-logical-symbol-p head)
+		          ((nil)			;atomic
+		           (cond
+			    ((eliminate-negations?)
+			     (make-compound* (relation-complementer head) (argsa wff)))
+			    (t
+			     (make-compound *not* wff))))
+                          (not
+		           (arg1a wff))
+		          (and
+		           (disjoin* (mapcar (lambda (arg)
+                                               (negate arg subst))
+                                             (argsa wff))
+                                     subst))
+		          (or
+		           (conjoin* (mapcar (lambda (arg)
+                                               (negate arg subst))
+                                             (argsa wff))
+                                     subst))
+		          ((implies implied-by iff xor)
+		           (make-compound *not* wff))
+		          (if
+		            (let ((args (argsa wff)))
+			      (make-compound head
+					     (first args)
+					     (negate (second args) subst)
+					     (negate (third args) subst))))))))
+
+(defun relation-complementer (fn)
+  ;; if complement has special properties
+  ;; such as associativity, rewrites, etc.,
+  ;; these must be declared explicitly by the user
+  (or (function-complement fn)
+      (setf (function-complement fn)
+            (declare-relation (complement-name (function-name fn)) (function-arity fn)))))
+
+(defun proposition-complementer (const)
+  (or (constant-complement const)
+      (setf (constant-complement const)
+            (declare-proposition (complement-name (constant-name const))))))
+
+(defun complement-name (nm &optional noninterned)
+  (let* ((s (symbol-name nm))
+         (~s (if (eql #\~ (char s 0))
+                 (subseq s 1)
+                 (to-string "~" s))))
+    (if noninterned
+        (make-symbol ~s)
+        (intern ~s (symbol-package nm)))))
+
+(defun make-implication (wff1 wff2 &optional subst)
+  (cond
+    ((eq true wff1)
+     wff2)
+    ((eq true wff2)
+     wff2)
+    ((eq false wff1)
+     true)
+    ((eq false wff2)
+     (negate wff1 subst))
+    ((equal-p wff1 wff2 subst)
+     true)
+    ((complement-p wff1 wff2 subst)
+     wff2)
+    ((and (compound-p wff2) (eq *implies* (head wff2)))
+     (let ((args2 (argsa wff2)))
+       (make-implication (conjoin wff1 (first args2) subst) (second args2) subst)))
+    ((eliminate-negations?)
+     (disjoin (negate wff1 subst) wff2 subst))
+    (t
+     (make-compound *implies* wff1 wff2))))
+
+(defun make-reverse-implication (wff2 wff1 &optional subst)
+  (cond
+    ((eq true wff1)
+     wff2)
+    ((eq true wff2)
+     wff2)
+    ((eq false wff1)
+     true)
+    ((eq false wff2)
+     (negate wff1 subst))
+    ((equal-p wff1 wff2 subst)
+     true)
+    ((complement-p wff1 wff2 subst)
+     wff2)
+    ((and (compound-p wff2) (eq *implied-by* (head wff2)))
+     (let ((args2 (argsa wff2)))
+       (make-reverse-implication (first args2) (conjoin (second args2) wff1 subst) subst)))
+    ((eliminate-negations?)
+     (disjoin wff2 (negate wff1 subst) subst))
+    (t
+     (make-compound *implied-by* wff2 wff1))))
+
+(defun make-conditional (wff1 wff2 wff3 &optional subst)
+  (cond
+    ((eq true wff1)
+     wff2)
+    ((eq false wff1)
+     wff3)
+    ((negation-p wff1)
+     (make-conditional (arg1 wff1) wff3 wff2 subst))
+    (t
+;;   (setf wff2 (substitute true wff1 wff2 subst))
+;;   (setf wff3 (substitute false wff1 wff3 subst))
+     (setf wff2 (prog->
+		  (map-atoms-in-wff-and-compose-result wff2 ->* atom polarity)
+		  (declare (ignore polarity))
+		  (if (equal-p wff1 atom subst) true atom)))
+     (setf wff3 (prog->
+		  (map-atoms-in-wff-and-compose-result wff3 ->* atom polarity)
+		  (declare (ignore polarity))
+		  (if (equal-p wff1 atom subst) false atom)))
+     (cond
+       ((eq true wff2)
+	(disjoin wff1 wff3 subst))
+       ((eq false wff2)
+	(conjoin (negate wff1 subst) wff3 subst))
+       ((eq true wff3)
+	(disjoin (negate wff1 subst) wff2 subst))
+       ((eq false wff3)
+	(conjoin wff1 wff2 subst))
+       ((equal-p wff2 wff3 subst)
+	wff2)
+       ((eliminate-negations?)
+	(disjoin
+	  (conjoin wff1 wff2 subst)
+	  (conjoin (negate wff1 subst) wff3 subst)
+	  subst))
+       (t
+	(make-compound *if* wff1 wff2 wff3))))))
+
+(defun make-conditional-answer (wff1 wff2 wff3 &optional subst)
+  (cond
+   ((eq true wff1)
+    wff2)
+   ((eq false wff1)
+    wff3)
+   ((negation-p wff1)
+    (make-conditional-answer (arg1 wff1) wff3 wff2 subst))
+   ((equal-p wff2 wff3 subst)
+    wff2)
+   (t
+    (make-compound *answer-if* wff1 wff2 wff3))))    
+
+(defun make-equality0 (term1 term2 &optional (relation *=*))
+  (make-compound relation term1 term2))
+
+(defun make-equality (term1 term2 &optional subst (relation *=*))
+  (cond
+    ((equal-p term1 term2 subst)
+     true)
+    (t
+     (make-compound relation term1 term2))))
+
+(defun complement-p (wff1 wff2 &optional subst)
+  (let ((appl nil) (neg nil))
+    (loop
+      (dereference
+	wff1 nil
+	:if-constant (return)
+	:if-variable (not-wff-error wff1)
+        :if-compound-cons (not-wff-error wff1)
+	:if-compound-appl (if (eq *not* (heada wff1))
+			      (setf neg (not neg) wff1 (arg1a wff1))
+			      (return (setf appl t)))))
+    (loop
+      (dereference
+	wff2 nil
+	:if-constant (return (and neg (eql wff1 wff2)))
+	:if-variable (not-wff-error wff2)
+        :if-compound-cons (not-wff-error wff2)
+	:if-compound-appl (if (eq *not* (heada wff2))
+			      (setf neg (not neg) wff2 (arg1a wff2))
+			      (return (and appl neg (equal-p wff1 wff2 subst))))))))
+
+(defun equal-or-complement-p (wff1 wff2 &optional subst)
+  (let ((appl nil) (neg nil))
+    (loop
+      (dereference
+	wff1 nil
+        :if-constant (return)
+        :if-variable (not-wff-error wff1)
+        :if-compound-cons (not-wff-error wff1)
+	:if-compound-appl (if (eq *not* (heada wff1))
+			      (setf neg (not neg) wff1 (arg1a wff1))
+			      (return (setf appl t)))))
+    (loop
+      (dereference
+	wff2 nil
+	:if-constant (return (and (eql wff1 wff2) (if neg :complement :equal)))
+	:if-variable (not-wff-error wff2)
+        :if-compound-cons (not-wff-error wff2)
+	:if-compound-appl (if (eq *not* (heada wff2))
+			      (setf neg (not neg) wff2 (arg1a wff2))
+			      (return (and appl (equal-p wff1 wff2 subst) (if neg :complement :equal))))))))
+
+;;; connectives.lisp EOF

snark-20120808r02/src/constants.lisp

@@ -0,0 +1,305 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: constants.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+;;; Lisp symbols, strings, numbers, and characters are used directly as SNARK constants
+;;; but SNARK needs to associate information with them
+;;; it is stored in constant-info structures found in *constant-info-table* hash-array
+;;; or *number-info-table* or *string-info-table* in the case of numbers and strings
+;;; that only require sort information be stored
+
+(defstruct constant-info
+  (hash-code0 (make-atom-hash-code) :read-only t)
+  (boolean-valued-p0 nil)		;overloaded to be input name of the proposition
+  (constructor0 nil)
+  (magic t)				;nil means don't make magic-set goal for this proposition
+  (allowed-in-answer0 t)
+  (kbo-weight0 1)
+  (weight0 1)
+  (sort0 (top-sort))
+  (plist nil))				;property list for more properties
+
+(definline constant-number (const)
+  (funcall *standard-eql-numbering* :lookup const))
+
+(defvar *constant-info-table*)
+
+(defmacro constant-info0 (const)
+  `(gethash ,const *constant-info-table*))
+
+(definline constant-info (const &optional (action 'error))
+  (or (constant-info0 const)
+      (init-constant-info const action)))
+
+(defun init-constant-info (const action)
+  (when action
+    (can-be-constant-name const action))
+  (constant-number const)		;initialize it at first occurrence
+  (let ((info (make-constant-info)))
+    (setf (constant-info0 const) info)))
+
+(defmacro define-constant-slot-accessor (name &key read-only)
+  (let ((constant-slot (intern (to-string :constant- name) :snark))
+        (constant-info-slot (intern (to-string :constant-info- name) :snark)))
+    `(progn
+       (#-(or allegro lispworks) definline #+(or allegro lispworks) defun ,constant-slot (const)
+         (,constant-info-slot (constant-info const)))
+       ,@(unless read-only
+           (list
+            `(defun (setf ,constant-slot) (value const)
+               (setf (,constant-info-slot (constant-info const)) value)))))))
+
+(define-constant-slot-accessor hash-code0 :read-only t)
+(define-constant-slot-accessor boolean-valued-p0)
+(define-constant-slot-accessor constructor0)
+(define-constant-slot-accessor magic)
+(define-constant-slot-accessor allowed-in-answer0)
+(define-constant-slot-accessor kbo-weight0)
+(define-constant-slot-accessor weight0)
+(define-constant-slot-accessor sort0)
+(define-constant-slot-accessor plist)
+
+(define-plist-slot-accessor constant :locked0)
+(define-plist-slot-accessor constant :documentation)
+(define-plist-slot-accessor constant :author)
+(define-plist-slot-accessor constant :source)
+(define-plist-slot-accessor constant :complement)	;complement of the symbol P is the symbol ~P
+(define-plist-slot-accessor constant :skolem-p)
+(define-plist-slot-accessor constant :created-p)
+(define-plist-slot-accessor constant :do-not-resolve)
+
+(defvar *number-info-table*)		;number -> (sort)
+(defvar *string-info-table*)		;string -> (sort canonical-string)
+
+(defstruct (number-info
+            (:type list)
+            (:copier nil))
+  sort)
+
+(defstruct (string-info
+            (:type list)
+            (:copier nil))
+  sort
+  (canonical nil :read-only t))
+
+(defmacro number-info (number)
+  `(gethash ,number *number-info-table*))
+
+(defmacro string-info (string)
+  `(gethash ,string *string-info-table*))
+
+(defun number-canonical (x)
+  (cl:assert (numberp x))
+  (cond
+   ((floatp x)
+    (rationalize x))
+   ((and (complexp x) (float (realpart x)))
+    (complex (rationalize (realpart x)) (rationalize (imagpart x))))
+   (t
+    x)))
+
+(defun declare-number (x)
+  (setf x (number-canonical x))
+  (or (number-info x)
+      (progn
+        (constant-number x)		;initialize it at first occurrence
+        (setf (number-info x) (make-number-info :sort (the-sort (number-sort-name x))))))
+  x)
+
+(defun declare-string (x)
+  (cl:assert (stringp x))
+  ;; canonicalize strings so that (implies (string= str1 str2) (eq (declare-string str1) (declare-string str2)))
+  (string-info-canonical
+   (or (string-info x)
+       (progn
+         (constant-number x)		;initialize it at first occurrence
+         (setf (string-info x) (make-string-info :sort (the-sort (declare-string-sort?)) :canonical x))))))
+
+(definline builtin-constant-p (x)
+  (or (numberp x) (stringp x)))
+
+(definline constant-builtin-p (const)
+  ;; equivalent to but faster than builtin-constant-p for known constants (can-be-constant-name is true)
+  (not (symbolp const)))
+
+(defun constant-hash-code (const)
+  (if (constant-builtin-p const) (+ 2 (mod (constant-number const) 1022)) (constant-hash-code0 const)))
+
+(definline constant-boolean-valued-p (const)
+  (if (constant-builtin-p const) nil (constant-boolean-valued-p0 const)))
+
+(definline constant-constructor (const)
+  (if (constant-builtin-p const) t (constant-constructor0 const)))
+
+(definline constant-allowed-in-answer (const)
+  (if (constant-builtin-p const) t (constant-allowed-in-answer0 const)))
+
+(definline constant-kbo-weight (const)
+  (if (constant-builtin-p const)
+      (let ((v (kbo-builtin-constant-weight?)))
+        (if (numberp v) v (funcall v const)))
+      (constant-kbo-weight0 const)))
+
+(definline constant-weight (const)
+  (if (constant-builtin-p const)
+      (let ((v (builtin-constant-weight?)))
+        (if (numberp v) v (funcall v const)))
+      (constant-weight0 const)))
+
+(defun constant-sort (const)
+  (cond
+   ((numberp const)
+    (number-info-sort (number-info const)))
+   ((stringp const)
+    (string-info-sort (string-info const)))
+   (t
+    (constant-sort0 const))))
+
+(defun (setf constant-sort) (value const)
+  (cond
+   ((numberp const)
+    (setf (number-info-sort (number-info const)) value))
+   ((stringp const)
+    (setf (string-info-sort (string-info const)) value))
+   (t
+    (setf (constant-sort0 const) value))))
+
+(definline constant-locked (const)
+  (if (constant-builtin-p const) t (constant-locked0 const)))
+
+(definline constant-name (const)
+  (or (constant-boolean-valued-p const) const))
+
+(defun constant-name-lessp (x y)
+  (cond
+    ((complexp x)
+     (if (complexp y) (or (< (realpart x) (realpart y)) (and (= (realpart x) (realpart y)) (< (imagpart x) (imagpart y)))) t))
+    ((complexp y)
+     nil)
+    ((realp x)
+     (if (realp y) (< x y) t))
+    ((realp y)
+     nil)
+    ((stringp x)
+     (if (stringp y) (string< x y) t))
+    ((stringp y)
+     nil)
+    (t
+     (string< x y))))
+
+(defun initialize-constants ()
+  (setf *constant-info-table* (make-hash-table))
+  (setf *number-info-table* (make-hash-table))
+  (setf *string-info-table* (make-hash-table :test #'equal))
+  nil)
+
+(defmacro set-slot-if-supplied (type slot)
+  (let ((slot-supplied (intern (to-string slot :-supplied) :snark))
+        (type-slot (intern (to-string type "-" slot) :snark)))
+    `(when ,slot-supplied
+       (setf (,type-slot symbol) ,slot))))
+
+(defun declare-constant-symbol0 (symbol
+                                 &key
+                                 alias
+                                 ((:sort sort0) nil)
+                                 ((:locked locked0) nil)
+                                 (documentation nil documentation-supplied)
+                                 (author nil author-supplied)
+                                 (source nil source-supplied)
+                                 (complement nil complement-supplied)
+                                 (magic t magic-supplied)
+                                 (skolem-p nil skolem-p-supplied)
+                                 (created-p nil created-p-supplied)
+                                 ((:constructor constructor0) nil constructor0-supplied)
+                                 ((:allowed-in-answer allowed-in-answer0) nil allowed-in-answer0-supplied)
+                                 ((:kbo-weight kbo-weight0) nil kbo-weight0-supplied)
+                                 ((:weight weight0) nil weight0-supplied)
+                                 (do-not-resolve nil do-not-resolve-supplied)
+                                 )
+  ;; doesn't do anything if no keywords are supplied
+  (when constructor0-supplied
+    (cl:assert (implies (constant-builtin-p symbol) constructor0) () "Builtin constant ~S cannot be a nonconstructor." symbol))
+  (when alias
+    (create-aliases-for-symbol symbol alias))
+  (when sort0
+    (declare-constant-sort symbol sort0))
+  (when locked0
+    (setf (constant-locked0 symbol) locked0))		;stays locked
+  (set-slot-if-supplied constant documentation)
+  (set-slot-if-supplied constant author)
+  (set-slot-if-supplied constant source)
+  (set-slot-if-supplied constant complement)
+  (set-slot-if-supplied constant magic)
+  (set-slot-if-supplied constant skolem-p)
+  (set-slot-if-supplied constant created-p)
+  (set-slot-if-supplied constant constructor0)
+  (set-slot-if-supplied constant allowed-in-answer0)
+  (set-slot-if-supplied constant kbo-weight0)
+  (set-slot-if-supplied constant weight0)
+  (set-slot-if-supplied constant do-not-resolve)
+  symbol)
+
+(defun changeable-keys-and-values0 (keys-and-values changeable)
+  (let ((keys-and-values1 nil) keys-and-values1-last
+        (keys-and-values2 nil) keys-and-values2-last)
+    (loop
+      (cond
+       ((endp keys-and-values)
+        (return (values keys-and-values1 keys-and-values2)))
+       ((member (first keys-and-values) changeable)
+        (collect (pop keys-and-values) keys-and-values1)
+        (collect (pop keys-and-values) keys-and-values1))
+       (t
+        (collect (pop keys-and-values) keys-and-values2)
+        (collect (pop keys-and-values) keys-and-values2))))))
+
+(defun changeable-keys-and-values (symbol keys-and-values changeable)
+  (let (keys-and-values2)
+    (setf (values keys-and-values keys-and-values2) (changeable-keys-and-values0 keys-and-values changeable))
+    (when keys-and-values2
+      (warn "Ignoring declaration of locked symbol ~S with arguments~{ ~S~}." symbol keys-and-values2))
+    keys-and-values))
+
+(defun declare-constant-symbol1 (symbol keys-and-values)
+  (cond
+   ((null keys-and-values)
+    symbol)
+   (t
+    (apply 'declare-constant-symbol0
+           symbol
+           (cond
+            ((and (constant-locked symbol) (eq none (getf keys-and-values :locked none)))
+             (changeable-keys-and-values
+              symbol
+              keys-and-values
+              (if (constant-builtin-p symbol) '(:alias :sort) (changeable-properties-of-locked-constant?))))
+            (t
+             keys-and-values))))))
+
+(defun declare-constant (name &rest keys-and-values)
+  (declare (dynamic-extent keys-and-values))
+  (declare-constant-symbol1 (input-constant-symbol name) keys-and-values))
+
+(defun declare-proposition (name &rest keys-and-values)
+  (declare (dynamic-extent keys-and-values))
+  (declare-constant-symbol1 (input-proposition-symbol name) keys-and-values))
+
+;;; constants.lisp EOF

snark-20120808r02/src/constraints.lisp

@@ -0,0 +1,335 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: constraints.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(declaim (special *processing-row*))
+
+(defgeneric checkpoint-theory (theory)
+  ;; create checkpoint
+  (:method (theory)
+    (error "No checkpoint method for theory ~S." theory)))
+
+(defgeneric uncheckpoint-theory (theory)
+  ;; eliminate checkpoint, keeping changes since then
+  (:method (theory)
+    (error "No uncheckpoint method for theory ~S." theory)))
+
+(defgeneric restore-theory (theory)
+  ;; undo changes since checkpoint, keeping checkpoint
+  (:method (theory)
+    (error "No restore method for theory ~S." theory)))
+
+(defgeneric theory-closure (theory)
+  ;; returns non-NIL value if theory is inconsistent
+  (:method (theory)
+    (error "No closure method for theory ~S." theory)))
+
+(defgeneric theory-assert (atom theory)
+  (:method (atom theory)
+    (declare (ignorable atom))
+    (error "No assert method for theory ~S." theory)))
+
+(defgeneric theory-deny (atom theory)
+  (:method (atom theory)
+    (declare (ignorable atom))
+    (error "No deny method for theory ~S." theory)))
+
+(defgeneric theory-simplify (wff theory)
+  ;; wff is disjunction of literals
+  (:method (wff theory)
+    (let ((row *processing-row*))
+      (cond
+       ((or (eq true wff) (eq false wff))
+        wff)
+       ((and row
+             (eq false (row-wff row))
+             (not (row-nonassertion-p row))
+             (eq theory (row-unit-constraint row))
+             (ground-p wff))
+        (mvlet (((values atom polarity) (literal-p wff)))
+          (if (eq :pos polarity)
+              (theory-assert2 atom theory)
+              (theory-deny2 atom theory)))
+        false)
+       (t
+        (checkpoint-theory theory)
+        (let ((wff* (prog->
+                      (map-atoms-in-wff-and-compose-result wff ->* atom polarity)
+                      (cond
+                       ((if (eq :pos polarity)
+                            (theory-falsep atom theory)
+                            (theory-truep atom theory))
+;;                      (when row
+;;                        (pushnew theory (row-rewrites-used row)))
+                        (if (eq :pos polarity) false true))
+                       ((progn
+                          (if (eq :pos polarity)
+                              (theory-deny atom theory)
+                              (theory-assert atom theory))
+                          (theory-closure theory))
+                        (restore-theory theory)
+                        (uncheckpoint-theory theory)
+                        (return-from theory-simplify false))
+                       (t
+                        atom)))))
+          (restore-theory theory)
+          (uncheckpoint-theory theory)
+          wff*)))))
+  (:method (wff (theory (eql 'assumption)))
+    (let ((row-wff (row-wff *processing-row*)))
+      (cond
+       ((and (clause-p row-wff) (clause-p wff nil nil t))
+        (prog->
+          (map-atoms-in-wff-and-compose-result wff ->* atom polarity)
+          (or (prog->
+                (map-atoms-in-wff row-wff ->* atom2 polarity2)
+                (when (and (eq polarity polarity2) (equal-p atom atom2))
+                  (return-from prog-> (if (eq :pos polarity) true false))))
+              atom)))
+       (t
+        wff)))))
+           
+(defgeneric theory-rewrite (wff theory)
+  (:method (wff theory)
+    (declare (ignorable theory))
+    (rewriter wff nil))
+  (:method (wff (theory (eql 'assumption)))
+    wff))
+
+(defun theory-assert2 (atom theory)
+  (checkpoint-theory theory)
+  (theory-assert atom theory)
+  (when (theory-closure theory)					;inconsistent?
+    (cerror "Continue without asserting it."
+            "Asserting ~A leads to a contradiction."
+            atom)
+    (restore-theory theory))
+  (uncheckpoint-theory theory))
+
+(defun theory-deny2 (atom theory)
+  (checkpoint-theory theory)
+  (theory-deny atom theory)
+  (when (theory-closure theory)					;inconsistent?
+    (cerror "Continue without denying it."
+            "Denying ~A leads to a contradiction."
+            atom)
+    (restore-theory theory))
+  (uncheckpoint-theory theory))
+
+(defun theory-truep (atom theory)
+  (let (inconsistent)
+    (checkpoint-theory theory)
+    (theory-deny atom theory)
+    (setf inconsistent (theory-closure theory))
+    (restore-theory theory)
+    (uncheckpoint-theory theory)
+    inconsistent))
+
+(defun theory-falsep (atom theory)
+  (let (inconsistent)
+    (checkpoint-theory theory)
+    (theory-assert atom theory)
+    (setf inconsistent (theory-closure theory))
+    (restore-theory theory)
+    (uncheckpoint-theory theory)
+    inconsistent))
+
+(defun simplify-constraint-alist (alist)
+  (and alist
+       (let* ((x (first alist))
+              (x* (lcons (car x) (theory-simplify (cdr x) (car x)) x)))
+         (cond
+          ((eq false (cdr x*))
+           (simplify-constraint-alist (rest alist)))
+          (t
+           (lcons x* (simplify-constraint-alist (rest alist)) alist))))))
+
+(defun rewrite-constraint-alist (alist)
+  (and alist
+       (let* ((x (first alist))
+              (x* (lcons (car x) (theory-rewrite (cdr x) (car x)) x)))
+         (cond
+          ((eq false (cdr x*))
+           (rewrite-constraint-alist (rest alist)))
+          (t
+           (lcons x* (rewrite-constraint-alist (rest alist)) alist))))))
+
+(defun assumptive-constraint-theory-p (theory)
+  ;; assumptive constraint theories can simply be assumed
+  ;; they don't require row coverage
+  (eq 'assumption theory))
+
+(defun row-constrained-p (row)
+  (dolist (x (row-constraints row) nil)
+    (unless (eq false (cdr x))
+      (return t))))
+
+(defun row-constrained-p2 (row)
+  (dolist (x (row-constraints row) nil)
+    (unless (or (eq false (cdr x))
+                (assumptive-constraint-theory-p (car x)))
+      (return t))))
+
+(defun row-unit-constraint (row)
+  (let ((v nil))
+    (dolist (x (row-constraints row))
+      (cond
+       ((eq false (cdr x))
+        )
+       (v
+        (setf v nil)
+        (return))
+       ((assumptive-constraint-theory-p (car x))
+        (return))
+       (t
+        (setf v x))))
+    (when v
+      (mvlet* (((list* theory wff) v)
+               ((values atom polarity) (literal-p wff)))
+        (when atom
+          (values theory atom polarity))))))
+
+(defun row-constraint-coverage (rows)
+  ;; returns t if row-constraint coverage is complete
+  ;; by doing matings search over constraint wffs
+  ;; but with NO INSTANTIATION
+  ;; cf. Bjorner, Stickel, Uribe CADE-14 paper
+  (let ((theories nil) (new-rows nil) new-rows-last)
+    (dolist (row rows)
+      (dolist (x (row-constraints row))
+        (mvlet (((list* theory wff) x))
+          (cl:assert (neq false wff))
+          (unless (or (eq true wff)
+                      (member theory theories)
+                      (assumptive-constraint-theory-p theory)
+                      (theory-closure theory))
+            (checkpoint-theory theory)
+            (push theory theories)))))
+    (dolist (row rows)
+      (mvlet (((values theory atom polarity) (row-unit-constraint row)))
+        (cond
+         ((and theory (member theory theories))
+          (if (eq :pos polarity)
+              (theory-assert atom theory)
+              (theory-deny atom theory)))
+         (t
+          (collect row new-rows)))))
+    (prog1
+      (dolist (theory theories t)
+        (unless (theory-closure theory)
+          (return (row-constraint-coverage* new-rows theories))))
+      (dolist (theory theories)
+        (restore-theory theory)
+        (uncheckpoint-theory theory)))))
+
+(defun row-constraint-coverage* (rows theories)
+  (and rows
+       (dolist (x (row-constraints (first rows)) t)	;return t if all paths closed
+         (mvlet (((list* theory wff) x))	;constraint wff is conjunction of literals
+           (unless (or (eq true wff)
+                       (not (member theory theories))
+                       (theory-closure theory))
+             (prog->
+               (map-atoms-in-wff wff ->* atom polarity)
+               (cond
+                ((prog2
+                  (checkpoint-theory theory)
+                  (progn
+                    (if (eq :pos polarity)			;trial value
+                        (theory-assert atom theory)
+                        (theory-deny atom theory))
+                    (or (theory-closure theory)		;inconsistent now?
+                        (row-constraint-coverage* (rest rows) theories)))	;all paths closed?
+                  (restore-theory theory)
+                  (uncheckpoint-theory theory))
+                 #+ignore
+                 (if (eq :pos polarity)			;assert negation and continue
+                     (theory-deny atom theory)
+                     (theory-assert atom theory)))
+                (t
+                 (return-from row-constraint-coverage* nil)))))))))	;return nil if unclosed path
+
+(defmethod checkpoint-theory ((theory (eql 'equality)))
+  nil)
+
+(defmethod uncheckpoint-theory ((theory (eql 'equality)))
+  nil)
+
+(defmethod restore-theory ((theory (eql 'equality)))
+  nil)
+
+(defmethod theory-closure ((theory (eql 'equality)))
+  nil)
+
+(defmethod theory-assert (atom (theory (eql 'equality)))
+  (declare (ignorable atom))
+  nil)
+
+(defmethod theory-deny (atom (theory (eql 'equality)))
+  (declare (ignorable atom))
+  nil)
+
+(defmethod theory-simplify (wff (theory (eql 'equality)))
+  wff)
+
+(defmethod checkpoint-theory ((theory (eql 'test)))
+  nil)
+
+(defmethod uncheckpoint-theory ((theory (eql 'test)))
+  nil)
+
+(defmethod restore-theory ((theory (eql 'test)))
+  nil)
+
+(defmethod theory-closure ((theory (eql 'test)))
+  nil)
+
+(defmethod theory-assert (atom (theory (eql 'test)))
+  (declare (ignorable atom))
+  nil)
+
+(defmethod theory-deny (atom (theory (eql 'test)))
+  (declare (ignorable atom))
+  nil)
+
+(defmethod theory-simplify (wff (theory (eql 'test)))
+  wff)
+
+(defun assumption-test1 ()
+  ;; answer 1 with assumption (b 1)
+  ;; answer 2 with assumption (a 2)
+  ;; answer ?x with assumption (and (a ?x) (b ?x))
+  (initialize)
+  (use-resolution)
+  (use-subsumption-by-false)
+  (assert '(a 1))
+  (assert '(b 2))
+  (assert '(a ?x) :constraints '((assumption (a ?x))))
+  (assert '(b ?x) :constraints '((assumption (b ?x))))
+  (prove '(and (a ?x) (b ?x)) :answer '(values ?x)))
+
+(defun assumption-test2 ()
+  (initialize)
+  (use-resolution)
+  (assert '(implies (bird ?x) (flies ?x)) :constraints '((assumption (normal-wrt-flies ?x))))
+  (assert '(bird tweety))
+  (prove '(flies tweety)))
+
+;;; constraints.lisp EOF

snark-20120808r02/src/counters.lisp

@@ -0,0 +1,90 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-lisp -*-
+;;; File: counters.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark-lisp)
+
+(defstruct (counter
+            (:constructor make-counter (&optional (increments 0)))
+            (:copier nil))
+  (increments 0 :type integer)
+  (decrements 0 :type integer)
+  (previous-peak-value 0 :type integer))
+
+(defun increment-counter (counter &optional (n 1))
+  (declare (type integer n))
+;;(cl:assert (<= 0 n))
+  (incf (counter-increments counter) n)
+  nil)
+
+(defun decrement-counter (counter &optional (n 1))
+  (declare (type integer n))
+;;(cl:assert (<= 0 n))
+  (let* ((d (counter-decrements counter))
+         (v (- (counter-increments counter) d)))
+    (when (> v (counter-previous-peak-value counter))
+      (setf (counter-previous-peak-value counter) v))
+    (setf (counter-decrements counter) (+ d n))
+    nil))
+
+(defun counter-value (counter)
+  (- (counter-increments counter) (counter-decrements counter)))
+
+(defun counter-values (counter)
+  ;; returns 4 values: current value, peak value, #increments, #decrements
+  (let* ((i (counter-increments counter))
+         (d (counter-decrements counter))
+         (v (- i d)))
+  (values v (max v (counter-previous-peak-value counter)) i d)))
+
+(definline show-count-p (n)
+  (dolist (v '(1000000 100000 10000 1000 100 10) t)
+    (when (>= n v)
+      (return (eql 0 (rem n v))))))
+
+(defun show-count (n)
+  (princ #\Space)
+  (let (q r)
+    (cond
+     ((eql 0 n)
+      (princ 0))
+     ((progn (setf (values q r) (truncate n 1000000)) (eql 0 r))
+      (princ q) (princ #\M))
+     ((progn (setf (values q r) (truncate n 1000)) (eql 0 r))
+      (princ q) (princ #\K))
+     (t
+      (princ n))))
+  (princ #\Space)
+  (force-output)
+  n)
+
+(defun show-count0 (n)
+  (if (and (neql 0 n) (show-count-p n)) n (show-count n)))
+
+(defun show-count1 (n)
+  (if (show-count-p n) (show-count n) n))
+
+(defmacro princf (place &optional (delta 1))
+  ;; increment counter and maybe print it
+  ;; if delta is 0, print the counter unless the previous increment did
+  (cl:assert (member delta '(0 1)))
+  (if (eql 0 delta)
+      `(show-count0 ,place)
+      `(show-count1 (incf ,place))))
+
+;;; counters.lisp EOF

snark-20120808r02/src/date-reasoning2.lisp

@@ -0,0 +1,347 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: date-reasoning2.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+;;; $$date-point and $$date-interval are external (solely for user convenience) function symbols
+;;; for date points and intervals; they are replaced by $$utime-point and $$utime-interval when
+;;; formulas are input
+;;;
+;;; $$utime-point and $$utime-interval are internal function symbols for dates
+;;; they use Lisp universal time representation (which counts seconds since 1900-01-01T00:00:00)
+;;;
+;;; $$date-point and $$date-interval use 1 to 6 integer arguments
+;;;   year, month, day, hour, minute, second
+;;; to specify dates
+;;;
+;;; examples of SNARK dates and their translations:
+;;; ($$date-point 2002 4 1 16 27 20)                       -> ($$utime-point 3226667240)
+;;; ($$date-interval 2002 4 1 16 34)                       -> ($$utime-interval 3226667640 3226667700)
+;;; ($$date-interval 2002 4 1 16 34 :until 2002 4 1 16 35) -> ($$utime-interval 3226667640 3226667700)
+;;; ($$date-interval 2002 4 1 16 34 :until 2002 4 1 17)    -> ($$utime-interval 3226667640 3226669200)
+;;;
+;;; 20071215: avoid use of $$date-interval (and $$utime-interval)
+;;; reasoning is more complete and effective if just $$date-point (and $$utime-point) are used
+
+(defvar *date-point*)
+(defvar *utime-point*)
+(defvar *date-interval*)
+(defvar *utime-interval*)
+
+(defun declare-code-for-dates ()
+  ;; declare symbols without some properties here
+  ;; defer full definition until declare-time-relations is called
+  (setf *date-point* (declare-function1 '$$date-point :any :macro t :input-code 'input-date-point))
+  (setf *utime-point* (declare-function
+                       '$$utime-point 1
+                       :constructor t
+;;                     :index-type :hash-but-dont-index
+                       :to-lisp-code 'utime-point-term-to-lisp))
+  (setf *date-interval* (declare-function1 '$$date-interval :any :macro t :input-code 'input-date-interval))
+  (setf *utime-interval* (declare-function
+                          '$$utime-interval 2
+                          :constructor t
+;;                        :index-type :hash-but-dont-index
+                          :to-lisp-code 'utime-interval-term-to-lisp))
+  nil)
+
+(defun can-be-date-p (list &optional action)
+  ;; a proper date is a list of 1 to 6 integers with appropriate values
+  ;; interpreted as year, month, day, hour, minute, and second
+  (or (let* ((list list)
+             (year (pop list)))
+        (and (integerp year)
+             (<= 1900 year)
+             (implies
+              list
+              (let ((month (pop list)))
+                (and (integerp month)
+                     (<= 1 month 12)
+                     (implies
+                      list
+                      (let ((day (pop list)))
+                        (and (integerp day)
+                             (<= 1 day (days-per-month month year))
+                             (implies
+                              list
+                              (let ((hour (pop list)))
+                                (and (integerp hour)
+                                     (<= 0 hour 23)
+                                     (implies
+                                      list
+                                      (let ((minute (pop list)))
+                                        (and (integerp minute)
+                                             (<= 0 minute 59)
+                                             (implies
+                                              list
+                                              (let ((second (pop list)))
+                                                (and (integerp second)
+                                                     (<= 0 second 59)	;no leap seconds!
+                                                     (null list))))))))))))))))))
+      (and action (funcall action "~A cannot be a date." list))))
+
+(defun encode-universal-time-point (year &optional month day hour minute second)
+  (can-be-date-p (list year (or month 1) (or day 1) (or hour 0) (or minute 0) (or second 0)) 'error)
+  (encode-universal-time
+   (or second 0)
+   (or minute 0)
+   (or hour 0)
+   (or day 1)
+   (or month 1)
+   year
+   0))
+
+(defun decode-universal-time-point (universal-time-point)
+  (mvlet (((values second minute hour day month year)
+           (decode-universal-time universal-time-point 0)))
+    (cond
+     ((/= 0 second)
+      (list year month day hour minute second))
+     ((/= 0 minute)
+      (list year month day hour minute))
+     ((/= 0 hour)
+      (list year month day hour))
+     ((/= 1 day)
+      (list year month day))
+     ((/= 1 month)
+      (list year month))
+     (t
+      (list year)))))
+
+(defun encode-universal-time-interval (year &optional month day hour minute second)
+  (let ((v (encode-universal-time-point year month day hour minute second)))
+    (list v
+          (+ v (or (and second 1)					;1 second long interval
+                   (and minute 60)					;1 minute long interval
+                   (and hour 3600)					;1 hour long interval
+                   (and day 86400)					;1 day long interval
+                   (and month (* (days-per-month month year) 86400))	;1 month long interval
+                   (* (if (leap-year-p year) 366 365) 86400))))))	;1 year long interval
+
+(defun decode-universal-time-interval (universal-time-interval)
+  (mvlet (((list start finish) universal-time-interval))
+    (values (decode-universal-time-point start) (decode-universal-time-point finish))))
+
+(defun pp-compare-universal-times (point1 point2)
+  (cond
+   ((< point1 point2)
+    'p<p)
+   ((> point1 point2)
+    'p>p)
+   (t
+    'p=p)))
+
+(defun ii-compare-universal-times (interval1 interval2)
+  (mvlet (((list start1 finish1) interval1)
+          ((list start2 finish2) interval2))
+    (cond
+     ((= start1 start2)
+      (if (< finish1 finish2) 's (if (> finish1 finish2) 'si '=)))
+     ((= finish1 finish2)
+      (if (> start1 start2) 'f 'fi))
+     ((<= finish1 start2)
+      (if (= finish1 start2) 'm '<))
+     ((>= start1 finish2)
+      (if (= start1 finish2) 'mi '>))
+     ((< start1 start2)
+      (if (> finish1 finish2) 'di 'o))
+     (t
+      (if (< finish1 finish2) 'd 'oi)))))
+
+(defun pi-compare-universal-times (point interval)
+  (mvlet (((list start finish) interval))
+    (cond
+     ((<= point start)
+      (if (= point start) 'p_s_i 'p<i))
+     ((>= point finish)
+      (if (= point finish) 'p_f_i 'p>i))
+     (t
+      'p_d_i))))
+
+(defun declare-date-functions (&key intervals points)
+  (when points
+    (declare-function1 '$$utime-point 1 :sort (list (time-point-sort-name?))))
+  (when intervals
+    (declare-function1 '$$utime-interval 2 :sort (list (time-interval-sort-name?))))
+  (when points
+    (declare-relation1 '$$time-pp 3 :locked nil :rewrite-code 'time-pp-atom-rewriter-for-dates)
+    (declare-utime-pp-composition))
+  (when intervals
+    (declare-relation1 '$$time-ii 3 :locked nil :rewrite-code 'time-ii-atom-rewriter-for-dates))
+  (when (and points intervals)
+    (declare-relation1 '$$time-pi 3 :locked nil :rewrite-code 'time-pi-atom-rewriter-for-dates)
+    (declare-utime-pi-composition))
+  nil)
+  
+(defun input-date-point (head args polarity)
+  (declare (ignore head polarity))
+  (make-compound *utime-point* (declare-constant (apply 'encode-universal-time-point args))))
+
+(defun input-date-interval (head args polarity)
+  (declare (ignore head polarity))
+  (let (v start finish)
+    (cond
+     ((setf v (member :until args))
+      (setf start (apply 'encode-universal-time-point (ldiff args v)))
+      (setf finish (apply 'encode-universal-time-point (rest v)))
+      (cl:assert (< start finish)))
+     (t
+      (setf v (apply 'encode-universal-time-interval args))
+      (setf start (first v))
+      (setf finish (second v))))
+    (declare-constant start)
+    (declare-constant finish)
+    (make-compound *utime-interval* start finish)))
+
+(defun utime-point-term-to-lisp (head args subst)
+  (declare (ignore head))
+  (or (let ((arg1 (first args)))
+        (and (dereference arg1 subst :if-constant (integerp arg1))
+             (cons (function-name *date-point*)
+                   (decode-universal-time-point arg1))))
+      none))
+
+(defun utime-interval-term-to-lisp (head args subst)
+  (declare (ignore head))
+  (or (let ((arg1 (first args))
+            (arg2 (second args)))
+        (and (dereference arg1 subst :if-constant (integerp arg1))
+             (dereference arg2 subst :if-constant (integerp arg2))
+             (cons (function-name *date-interval*)
+                   (append (decode-universal-time-point arg1)
+                           (cons :until (decode-universal-time-point arg2))))))
+      none))
+
+(defun utime-point-term-p (term subst)
+  (dereference
+   term subst
+   :if-compound-appl (and (eq *utime-point* (heada term))
+                          (let* ((args (argsa term))
+                                 (arg1 (first args)))
+                            (and (dereference arg1 subst :if-constant (integerp arg1))
+                                 arg1)))))
+
+(defun utime-interval-term-p (term subst)
+  (dereference
+   term subst
+   :if-compound-appl (and (eq *utime-interval* (heada term))
+                          (let* ((args (argsa term))
+                                 (arg1 (first args))
+                                 (arg2 (second args)))
+                            (and (dereference arg1 subst :if-constant (integerp arg1))
+                                 (dereference arg2 subst :if-constant (integerp arg2))
+                                 (if (and (eql arg1 (first args))
+                                          (eql arg2 (second args)))
+                                     args
+                                     (list arg1 arg2)))))))
+
+(defun time-ii-atom-rewriter-for-dates (term subst)
+  (let ((args (args term)) m n v)
+    (cond
+     ((and (setf m (utime-interval-term-p (first args) subst))
+           (setf n (utime-interval-term-p (second args) subst))
+           (progn (setf v (third args)) (dereference v subst :if-compound-cons t)))
+      (setf v (nth (jepd-relation-code (ii-compare-universal-times m n) $time-ii-relation-code) v))
+      (if (dereference v subst :if-variable t) false true))
+     (t
+      none))))
+
+(defun time-pp-atom-rewriter-for-dates (term subst)
+  (let ((args (args term)) m n v)
+    (cond
+     ((and (setf m (utime-point-term-p (first args) subst))
+           (setf n (utime-point-term-p (second args) subst))
+           (progn (setf v (third args)) (dereference v subst :if-compound-cons t)))
+      (setf v (nth (jepd-relation-code (pp-compare-universal-times m n) $time-pp-relation-code) v))
+      (if (dereference v subst :if-variable t) false true))
+     (t
+      none))))
+
+(defun time-pi-atom-rewriter-for-dates (term subst)
+  (let ((args (args term)) m n v)
+    (cond
+     ((and (setf m (utime-point-term-p (first args) subst))
+           (setf n (utime-interval-term-p (second args) subst))
+           (progn (setf v (third args)) (dereference v subst :if-compound-cons t)))
+      (setf v (nth (jepd-relation-code (pi-compare-universal-times m n) $time-pi-relation-code) v))
+      (if (dereference v subst :if-variable t) false true))
+     (t
+      none))))
+
+(defun declare-utime-pp-composition ()
+  ;; use relations between x&z and z&y to constrain relation between x&y where x and z are utimes and y is a point
+  (declare-relation1
+   '$$utime-pp-composition
+   5
+   :rewrite-code
+   (list
+    (lambda (atom subst)
+      (let ((args (args atom)) m n)
+        (or (and (setf m (utime-point-term-p (third args) subst))
+                 (setf n (utime-point-term-p (fifth args) subst))
+                 (if (/= m n)
+                     (make-compound
+                      (input-relation-symbol '$$time-pp-composition 5)
+                      (if (< m n)
+                          (list 1 (make-and-freeze-variable) (make-and-freeze-variable))
+                          (list (make-and-freeze-variable) (make-and-freeze-variable) 1))
+                      (second (args atom))
+                      (third (args atom))
+                      (fifth (args atom))
+                      (fourth (args atom)))
+                     true))
+            none)))))
+  (assert `(forall (?x (?y :sort ,(time-point-sort-name?)) ?z ?l1 ?l2)
+                   (implies (and ($$time-pp ($$utime-point ?x) ?y ?l1)
+                                 ($$time-pp ($$utime-point ?z) ?y ?l2))
+                            ($$utime-pp-composition ?l1 ?l2 ($$utime-point ?x) ?y ($$utime-point ?z))))
+          :name :$$utime-pp-composition
+          :supported nil))
+
+(defun declare-utime-pi-composition ()
+  ;; use relations between x&z and z&y to constrain relation between x&y where x and z are utimes and y is an interval
+  (declare-relation1
+   '$$utime-pi-composition
+   5
+   :rewrite-code
+   (list
+    (lambda (atom subst)
+      (let ((args (args atom)) m n)
+        (or (and (setf m (utime-point-term-p (third args) subst))
+                 (setf n (utime-point-term-p (fifth args) subst))
+                 (if (/= m n)
+                     (make-compound
+                      (input-relation-symbol '$$time-pi-pp-composition 5)
+                      (if (< m n)
+                          (list 1 (make-and-freeze-variable) (make-and-freeze-variable))
+                          (list (make-and-freeze-variable) (make-and-freeze-variable) 1))
+                      (second (args atom))
+                      (third (args atom))
+                      (fifth (args atom))
+                      (fourth (args atom)))
+                     true))
+            none)))))
+  (assert `(forall (?x (?y :sort ,(time-interval-sort-name?)) ?z ?l1 ?l2)
+                   (implies (and ($$time-pi ($$utime-point ?x) ?y ?l1)
+                                 ($$time-pi ($$utime-point ?z) ?y ?l2))
+                            ($$utime-pi-composition ?l1 ?l2 ($$utime-point ?x) ?y ($$utime-point ?z))))
+          :name :$$utime-pi-composition
+          :supported nil))
+
+;;; date-reasoning2.lisp EOF

snark-20120808r02/src/deque-system.lisp

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

snark-20120808r02/src/deque2.lisp

@@ -0,0 +1,228 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-deque -*-
+;;; File: deque2.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark-deque)
+
+(defstruct (deque
+            (:predicate deque?))
+  (front nil :type list)
+  (last-of-front nil)
+  (rear nil :type list)
+  (last-of-rear nil))
+
+(defun deque-empty? (deque)
+  (and (null (deque-front deque)) (null (deque-rear deque))))
+
+(defun deque-first (deque)
+  ;; returns first item in deque, nil if deque is empty
+  (let ((front (deque-front deque)))
+    (if front (first front) (deque-last-of-rear deque))))
+
+(defun deque-last (deque)
+  ;; returns last item in deque, nil if deque is empty
+  (let ((rear (deque-rear deque)))
+    (if rear (first rear) (deque-last-of-front deque))))
+
+(defun deque-rest (deque)
+  ;; returns new deque with first item removed, deque if it is empty
+  (let ((front (deque-front deque))
+        (rear (deque-rear deque)))
+    (cond
+     (front
+      (let ((front* (rest front)))
+        (make-deque
+         :front front*
+         :last-of-front (if front* (deque-last-of-front deque) nil)
+         :rear rear
+         :last-of-rear (deque-last-of-rear deque))))
+     (rear
+      (let ((front* (rest (reverse rear))))
+        (make-deque
+         :front front*
+         :last-of-front (if front* (first rear) nil)
+         :rear nil
+         :last-of-rear nil)))
+     (t
+      deque))))
+
+(defun deque-butlast (deque)
+  ;; returns new deque with last item removed, deque if it is empty
+  (let ((front (deque-front deque))
+        (rear (deque-rear deque)))
+    (cond
+     (rear
+      (let ((rear* (rest rear)))
+        (make-deque
+         :rear rear*
+         :last-of-rear (if rear* (deque-last-of-rear deque) nil)
+         :front front
+         :last-of-front (deque-last-of-front deque))))
+     (front
+      (let ((rear* (rest (reverse front))))
+        (make-deque
+         :rear rear*
+         :last-of-rear (if rear* (first front) nil)
+         :front nil
+         :last-of-front nil)))
+     (t
+      deque))))
+
+(defun deque-pop-first (deque)
+  ;; like deque-rest, but return first item and destructively remove it from deque
+  (let ((front (deque-front deque))
+        (rear (deque-rear deque)))
+    (cond
+     (front
+      (let ((front* (rest front)))
+        (setf (deque-front deque) front*)
+        (when (null front*)
+          (setf (deque-last-of-front deque) nil))
+        (first front)))
+     (rear
+      (let ((item (deque-last-of-rear deque))
+            (front* (rest (reverse rear))))
+        (setf (deque-front deque) front*)
+        (setf (deque-last-of-front deque) (if front* (first rear) nil))
+        (setf (deque-rear deque) nil)
+        (setf (deque-last-of-rear deque) nil)
+        item))
+     (t
+      nil))))
+
+(defun deque-pop-last (deque)
+  ;; like deque-butlast, but return last item and destructively remove it from deque
+  (let ((front (deque-front deque))
+        (rear (deque-rear deque)))
+    (cond
+     (rear
+      (let ((rear* (rest rear)))
+        (setf (deque-rear deque) rear*)
+        (when (null rear*)
+          (setf (deque-last-of-rear deque) nil))
+        (first rear)))
+     (front
+      (let ((item (deque-last-of-front deque))
+            (rear* (rest (reverse front))))
+        (setf (deque-rear deque) rear*)
+        (setf (deque-last-of-rear deque) (if rear* (first front) nil))
+        (setf (deque-front deque) nil)
+        (setf (deque-last-of-front deque) nil)
+        item))
+     (t
+      nil))))
+
+(defun deque-add-first (deque item)
+  ;; returns new deque with new first item added
+  (let ((front (deque-front deque)))
+    (make-deque
+     :front (cons item front)
+     :last-of-front (if front (deque-last-of-front deque) item)
+     :rear (deque-rear deque)
+     :last-of-rear (deque-last-of-rear deque))))
+
+(defun deque-add-last (deque item)
+  ;; returns new deque with new last item added
+  (let ((rear (deque-rear deque)))
+    (make-deque
+     :rear (cons item rear)
+     :last-of-rear (if rear (deque-last-of-rear deque) item)
+     :front (deque-front deque)
+     :last-of-front (deque-last-of-front deque))))
+
+(defun deque-push-first (deque item)
+  ;; like deque-add-first, but returns same deque with new first item added destructively
+  (let ((front (deque-front deque)))
+    (setf (deque-front deque) (cons item front))
+    (when (null front)
+      (setf (deque-last-of-front deque) item))
+    deque))
+
+(defun deque-push-last (deque item)
+  ;; like deque-add-last, but returns same deque with new last item added destructively
+  (let ((rear (deque-rear deque)))
+    (setf (deque-rear deque) (cons item rear))
+    (when (null rear)
+      (setf (deque-last-of-rear deque) item))
+    deque))
+
+(defun deque-length (deque)
+  (+ (length (deque-front deque)) (length (deque-rear deque))))
+
+(defun deque-delete (deque item)
+  ;; ad hoc function to delete single occurrence of item from deque destructively
+  (let ((front (deque-front deque))
+        (rear (deque-rear deque)))
+    (cond
+     ((and front (eql item (first front)))
+      (when (null (setf (deque-front deque) (rest front)))
+        (setf (deque-last-of-front deque) nil))
+      t)
+     ((and rear (eql item (first rear)))
+      (when (null (setf (deque-rear deque) (rest rear)))
+        (setf (deque-last-of-rear deque) nil))
+      t)
+     ((dotails (l front nil)
+        (when (and (rest l) (eql item (second l)))
+          (when (null (setf (rest l) (rrest l)))
+            (setf (deque-last-of-front deque) (first l)))
+          (return t))))
+     ((dotails (l rear nil)
+        (when (and (rest l) (eql item (second l)))
+          (when (null (setf (rest l) (rrest l)))
+            (setf (deque-last-of-rear deque) (first l)))
+          (return t))))
+     (t
+      nil))))
+
+(defun deque-delete-if (function deque)
+  ;; ad hoc function to delete items from deque destructively
+  (let* ((deleted nil)
+         (front* (prog->
+                   (delete-if (deque-front deque) ->* item)
+                   (when (funcall function item)
+                     (setf deleted t)))))
+    (when deleted
+      (setf (deque-front deque) front*)
+      (setf (deque-last-of-front deque) (first (last front*)))))
+  (let* ((deleted nil)
+         (rear* (prog->
+                  (delete-if (deque-rear deque) :from-end t ->* item)
+                  (when (funcall function item)
+                    (setf deleted t)))))
+    (when deleted
+      (setf (deque-rear deque) rear*)
+      (setf (deque-last-of-rear deque) (first (last rear*)))))
+  deque)
+
+(defun mapnconc-deque (function deque &key reverse)
+  ;; ad hoc function to nconc results of applying function to items in deque
+  (let ((front (deque-front deque))
+        (rear (deque-rear deque))
+        (result nil) result-last)
+    (dolist (item (if reverse rear front))
+      (if (or (null function) (eq 'list function) (eq #'list function))
+          (collect item result)
+          (ncollect (funcall function item) result)))
+    (dolist (item (if reverse (reverse front) (reverse rear)))
+      (if (or (null function) (eq 'list function) (eq #'list function))
+          (collect item result)
+          (ncollect (funcall function item) result)))
+    result))
+
+;;; deque2.lisp EOF

snark-20120808r02/src/dp-refute.lisp

@@ -0,0 +1,250 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: dp-refute.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(declaim (special map-atoms-first *subsuming* *frozen-variables*))
+
+(defstruct (context
+	     (:constructor make-context (formula &optional assignment substitution))
+	     (:print-function print-context))
+  formula
+  (substitution nil)
+  (assignment nil))
+
+(defun make-context2 (formula assignment substitution)
+  (make-context
+   (simplify-formula formula assignment substitution)	;should be incremental for efficiency
+   assignment
+   substitution))
+
+(defun dp-refute-p (formula)
+  (prog->
+    (dp-refute (make-context formula) ->* substitution)
+    (return-from dp-refute-p (or substitution t))))
+
+(defun dp-refute (cc context)
+  (when (trace-dp-refute?)
+    (dp-refute-trace context))
+  (cond
+    ((eq true (context-formula context))
+     )						;don't do anything if formula is not falsifiable (return failed context?)
+    ((eq false (context-formula context))
+     (funcall cc (context-substitution context)))	;succeeded
+    (t
+     (prog->
+       (refute-methods context ->* x)
+       (ecase (first x)
+
+	 (instantiate				;extend substitution
+	   (second x -> substitution)
+;;         (cl:assert (and (neq (context-substitution context) substitution)
+;;			   (tailp (context-substitution context) substitution)))
+	   (dp-refute
+	     (make-context2
+	       (context-formula context)
+	       (context-assignment context)
+	       substitution)
+	     ->* substitution)
+	   (funcall cc substitution))
+
+	 (split
+	   (second x -> atom)
+	   (third x -> value)			;refute atom-value branch first
+	   (if (eq true value) false true -> not-value)
+	   (when (trace-dp-refute?)
+	     (dp-refute-trace context atom value))
+	   (dp-refute
+	     (make-context2
+	       (context-formula context)
+	       (cons (list atom value) (context-assignment context))
+	       (context-substitution context))
+	     ->* substitution)
+	   (when (trace-dp-refute?)
+	     (dp-refute-trace context atom not-value))
+	   (dp-refute
+	     (make-context2
+	       (context-formula context)
+	       (cons (list atom not-value) (context-assignment context))
+	       substitution)
+	     ->* substitution)
+	   (funcall cc substitution))
+
+	 (close-branch-and-refute-other-branch
+	   (second x -> atom)
+	   (third x -> value)
+	   (fourth x -> substitution)
+	   (if (eq true value) false true -> not-value)
+;;	   (cl:assert (and (neq (context-substitution context) substitution)
+;;			   (tailp (context-substitution context) substitution)))
+	   (dp-refute
+	     (make-context2
+	       (context-formula context)
+	       (cons (list atom not-value) (context-assignment context))
+	       substitution)
+	     ->* substitution)
+	   (funcall cc substitution))))))
+  nil)
+
+(defun dp-refute-trace (context &optional atom value)
+  (terpri)
+  (dolist (x (context-assignment context))
+    (declare (ignorable x))
+    (princ "  "))
+  (cond
+    ((null atom)
+     (princ "REFUTE: ")
+     (print-context context))
+    (t
+     (princ "  ")
+     (prin1 atom)
+     (princ " <- ")
+     (prin1 value))))
+
+;;; simple versions of choose-atom, refute-methods, and simplify-formula
+;;; that are suitable for SNARK are given
+;;; STeP will require much more sophisticated versions
+
+(defun choose-atom (cc context)
+  ;; pick any atom not already assigned a value
+  ;; better heuristic selection is called for
+  (prog->
+    (context-substitution context -> substitution)
+    (identity map-atoms-first -> maf)
+    (quote t -> map-atoms-first)
+    (map-atoms-in-wff (context-formula context) ->* atom polarity)
+    (declare (ignore polarity))
+    (identity maf -> map-atoms-first)
+    (unless (member atom (context-assignment context) :key #'car :test (lambda (x y) (equal-p x y substitution)))
+      (funcall cc atom)
+      ;; quit after finding first one
+      ;; STeP may require additional choices, if falsifiability depends on order in which branches are explored
+      (return-from choose-atom atom))))
+
+(defun refute-methods (cc context)
+  ;; pick an atom to assign
+  ;; attempt to refute it by unification with a complementary assignment
+  ;; there will be more ways to refute atoms when theories are interpreted
+  (let ((assignment (context-assignment context))
+	(substitution (context-substitution context)))
+    (prog->
+      (choose-atom context ->* atom)
+      (quote nil -> empty-substitution-works)
+      (prog-> 
+	(dolist assignment ->* x)
+	(first x -> atom2)
+	(second x -> value2)
+	(if (eq true value2) false true -> value)
+	(unify atom atom2 substitution ->* substitution2)
+	(when (eq substitution2 substitution)
+	  (setf empty-substitution-works t))
+	(funcall cc `(close-branch-and-refute-other-branch ,atom ,value ,substitution2)))
+      (unless empty-substitution-works
+	(funcall cc `(split ,atom ,true))))))
+
+(defun simplify-formula (formula assignment substitution)
+  (prog-> 
+    (map-atoms-in-wff-and-compose-result formula ->* atom polarity)
+    (declare (ignore polarity))
+    (or (second (assoc-p atom assignment substitution))
+        (instantiate atom substitution))))
+
+(defun print-context (context &optional (stream *standard-output*) depth)
+  (declare (ignore depth))
+  (format stream "#<context formula: ")
+  (prin1 (context-formula context) stream)
+  (format stream "; assignment: ")
+  (prin1 (context-assignment context) stream)
+  (format stream "; substitution: ")
+  (prin1 (context-substitution context) stream)
+  (format stream ">")
+  context)
+
+(defun dp-subsume* (cc wff1 wff2 subst neg)
+  (cond
+    ((if neg
+	 (or (eq false wff2) (eq true wff1))
+	 (or (eq true wff2) (eq false wff1)))
+     (funcall cc subst))
+    ((if neg
+	 (or (eq true wff2) (eq false wff1))
+	 (or (eq false wff2) (eq true wff1)))
+     )
+    (t
+     (prog->
+       (if neg
+	   (maximum-and-minimum-clause-lengths-neg wff1 subst)
+	   (maximum-and-minimum-clause-lengths wff1 subst)
+	   -> max1 min1)
+       (declare (ignore min1))
+       (if neg
+	   (maximum-and-minimum-clause-lengths-neg wff2 subst)
+	   (maximum-and-minimum-clause-lengths wff2 subst)
+	   -> max2 min2)
+       (declare (ignore max2))
+       (when (> max1 min2)
+	 (return-from dp-subsume*)))
+     (dp-refute
+      cc
+      (make-context2
+       (if neg (conjoin wff2 (negate wff1)) (conjoin (negate wff2) wff1))
+       nil
+       subst)))))
+
+(defun dp-subsume-constraint-alists* (cc constraint-alist1 constraint-alist2 subst)
+  (cond
+   ((null constraint-alist1)
+    (funcall cc subst))
+   (t
+    (prog->
+      (first constraint-alist1 -> x)
+      (dp-subsume* (cdr x) (or (cdr (assoc (car x) constraint-alist2)) false) subst nil ->* subst)
+      (dp-subsume-constraint-alists* (rest constraint-alist1) constraint-alist2 subst ->* subst)
+      (funcall cc subst))))
+  nil)
+
+(defun dp-subsume (cc wff1 wff2 subst neg)
+  (prog->
+    (identity *subsuming* -> sb)
+    (quote t -> *subsuming*)
+    (identity *frozen-variables* -> fv)		;save list of frozen variables
+    (variables wff2 subst fv -> *frozen-variables*)	;add wff2's variables to frozen variables
+    (dp-subsume* wff1 wff2 subst neg ->* subst)
+    (identity sb -> *subsuming*)
+    (identity fv -> *frozen-variables*)		;restore list of frozen variables
+    (funcall cc subst)))
+
+(defun dp-subsume+ (row1 row2)
+  (prog->
+    (row-wff row1 -> wff1)
+    (row-wff row2 -> wff2)
+    (row-constraints row1 -> constraint-alist1)
+    (row-constraints row2 -> constraint-alist2)
+    (row-answer row1 -> answer1)
+    (row-answer row2 -> answer2)
+
+    (row-variables row2 *frozen-variables* -> *frozen-variables*)
+
+    (dp-subsume* wff1 wff2 nil nil ->* subst)
+    (dp-subsume-constraint-alists* constraint-alist1 constraint-alist2 subst ->* subst)
+    (dp-subsume* answer1 answer2 subst nil ->* subst)
+    (declare (ignore subst))
+    (return-from dp-subsume+ t)))
+
+;;; dp-refute.lisp EOF

snark-20120808r02/src/dpll-system.lisp

@@ -0,0 +1,46 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
+;;; File: dpll-system.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :common-lisp-user)
+
+(defpackage :snark-dpll
+  (:use :common-lisp :snark-lisp)
+  (:export
+   #:dp-prover #:dp-version
+   #:dp-tracing #:dp-tracing-state #:dp-tracing-models #:dp-tracing-choices
+   #:dp-satisfiable-p #:dp-satisfiable-file-p #:make-dp-clause-set
+   #:dp-insert #:dp-insert-sorted #:dp-insert-wff #:dp-insert-file
+   #:dp-count #:dp-clauses #:dp-output-clauses-to-file #:wff-clauses
+   #:dp-horn-clause-set-p
+   #:checkpoint-dp-clause-set #:restore-dp-clause-set #:uncheckpoint-dp-clause-set
+   #:choose-an-atom-of-a-shortest-clause
+   #:choose-an-atom-of-a-shortest-clause-randomly
+   #:choose-an-atom-of-a-shortest-clause-with-most-occurrences
+   #:choose-an-atom-of-a-shortest-clause-with-most-occurrences-randomly
+   #:choose-an-atom-of-a-shortest-positive-clause
+   #:choose-an-atom-of-a-shortest-positive-clause-randomly
+   #:choose-an-atom-of-a-shortest-positive-clause-with-most-occurrences
+   #:choose-an-atom-of-a-shortest-positive-clause-with-most-occurrences-randomly
+   #:lookahead-true #:lookahead-false
+   #:lookahead-true-false #:lookahead-false-true
+   ))
+
+(loads "davis-putnam3")
+
+;;; dpll-system.lisp EOF

snark-20120808r02/src/equal.lisp

@@ -0,0 +1,115 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: equal.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2010.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+;;; EQ suffices to compare function, relation, and variable symbols
+;;; EQL suffices to compare constant symbols
+;;;  string constants must be term-hashed to be EQ
+
+(defun equal-p (x y &optional subst)
+  (or (eql x y)
+      (dereference
+       x subst
+       :if-variable (dereference y subst :if-variable (eq x y))
+       :if-constant (dereference y subst :if-constant (eql x y))
+       :if-compound-cons (dereference
+                          y subst
+                          :if-compound-cons (and (equal-p (carc x) (carc y) subst)
+                                                 (equal-p (cdrc x) (cdrc y) subst)))
+       :if-compound-appl (dereference
+                          y subst
+                          :if-compound-appl
+                          (or (eq x y)
+                              (let ((head (heada x)))
+                                (cond
+                                 ((neq head (heada y))
+                                  nil)
+                                 (t
+                                  (dolist (fun (function-equal-code head) (equal-p (argsa x) (argsa y) subst))
+                                    (let ((v (funcall fun x y subst)))
+                                      (unless (eq none v)
+                                        (return v))))))))))))
+
+(defun ac-equal-p (x y subst)
+  (let ((fn (head x))
+        (terms1 (args x))
+        (terms2 (args y)))
+    (and (similar-argument-list-ac1-p fn terms1 terms2 subst)
+         (progn
+           (setf terms2 (cons nil (copy-list (argument-list-a1 fn terms2 subst))))
+           (loop for term1 in (argument-list-a1 fn terms1 subst)
+                 always (loop for y1 = terms2 then y2
+                              for y2 on (cdr terms2)
+                              thereis (if (equal-p term1 (car y2) subst)
+                                          (rplacd y1 (cdr y2))	;non-nil
+                                          nil)))))))
+
+(defun commutative-equal-p (x y subst)
+  (mvlet (((list* x y z) (args x))
+          ((list* u v w) (args y)))
+    (and (or (eq z w) (equal-p z w subst))
+         (cond
+          ((equal-p x u subst)
+           (equal-p y v subst))
+          ((equal-p x v subst)
+           (equal-p y u subst))
+          (t
+           nil)))))
+
+(defun associative-equal-p (x y subst)
+  (let ((fn (head x))
+        (terms1 (args x))
+        (terms2 (args y)))
+    (and (eql (argument-count-a1 fn terms1 subst)
+              (argument-count-a1 fn terms2 subst))
+         (let (x y)
+           (loop
+             (cond
+              ((null terms1)
+               (return (null terms2)))
+              ((null terms2)
+               (return nil))
+              (t
+               (setf (values x terms1) (first-and-rest-of-vector terms1 subst fn none))
+               (setf (values y terms2) (first-and-rest-of-vector terms2 subst fn none))
+               (unless (equal-p x y subst)
+                 (return nil)))))))))
+
+(defun member-p (item list &optional subst)
+  (or (member item list)
+      (dotails (l list nil)
+        (when (equal-p item (first l) subst)
+          (return l)))))
+
+(defun assoc-p (item alist &optional subst)
+  (or (assoc item alist)
+      (dolist (pair alist nil)
+        (when (equal-p item (car pair) subst)
+          (return pair)))))
+
+(defun literal-member-p (atom polarity list)
+  (or (dolist (x list nil)
+        (when (and (eq atom (first x)) (eq polarity (second x)))
+          (return x)))
+      (dolist (x list nil)
+        (when (and (eq polarity (second x)) (equal-p atom (first x)))
+          (return x)))))
+
+;;; equal.lisp EOF

snark-20120808r02/src/eval.lisp

@@ -0,0 +1,350 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: eval.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defvar *polarity*)
+
+(defun fifo (row)
+  (declare (ignore row))
+  (values 0 nil))
+
+(defun lifo (row)
+  (declare (ignore row))
+  (values 0 t))
+
+(defun row-depth (row)
+  (if (row-embedding-p row)
+      (row-depth (row-parent row))
+      (wff-depth (row-wff row))))
+
+(defun row-size (row)
+  (if (row-embedding-p row)
+      (row-size (row-parent row))
+      (wff-size (row-wff row))))
+
+(defun row-weight (row)
+  (if (row-embedding-p row)
+      (row-weight (row-parent row))
+      (wff-weight (row-wff row))))
+
+(defun row-size+depth (row)
+  (if (row-embedding-p row)
+      (row-size+depth (row-parent row))
+      (wff-size+depth (row-wff row))))
+
+(defun row-weight+depth (row)
+  (if (row-embedding-p row)
+      (row-weight+depth (row-parent row))
+      (wff-weight+depth (row-wff row))))
+
+(defun row-size+depth+level (row)
+  (if (row-embedding-p row)
+      (row-size+depth+level (row-parent row))
+      (+ (wff-size+depth (row-wff row)) (row-level row))))
+
+(defun row-weight+depth+level (row)
+  (if (row-embedding-p row)
+      (row-weight+depth+level (row-parent row))
+      (+ (wff-weight+depth (row-wff row)) (row-level row))))
+
+(defun row-priority (row)
+  (if (row-embedding-p row)
+      (row-priority (row-parent row))
+      (+ (let ((f (row-priority-size-factor?)))
+           (if (= 0 f) 0 (* f (wff-size (row-wff row)))))
+         (let ((f (row-priority-weight-factor?)))
+           (if (= 0 f) 0 (* f (wff-weight (row-wff row)))))
+         (let ((f (row-priority-depth-factor?)))
+           (if (= 0 f) 0 (* f (wff-depth (row-wff row)))))
+         (let ((f (row-priority-level-factor?)))
+           (if (= 0 f) 0 (* f (row-level row)))))))
+
+(defun row-wff&answer-weight+depth (row)
+  (if (row-embedding-p row)
+      (row-wff&answer-weight+depth (row-parent row))
+      (+ (wff-weight+depth (row-wff row)) (wff-weight+depth (row-answer row)))))
+
+(defun row-neg (row)
+  (if (row-embedding-p row)
+      (row-neg (row-parent row))
+      (wff-neg (row-wff row))))
+
+(defun row-neg-size+depth (row)
+  (if (row-embedding-p row)
+      (row-neg-size+depth (row-parent row))
+      (list (wff-neg (row-wff row)) (wff-size+depth (row-wff row)))))
+
+(defun row-answer-weight (row)
+  (weight (row-answer row)))
+
+(defun wff-depth (wff &optional subst &key (polarity :pos))
+  (prog->
+    (wff-size* wff subst polarity ->* atom subst)
+    (depth atom subst)))
+
+(defun wff-size (wff &optional subst &key (polarity :pos))
+  (prog->
+    (wff-size* wff subst polarity ->* atom subst)
+    (size atom subst)))
+
+(defun wff-weight (wff &optional subst &key (polarity :pos))
+  (prog->
+    (wff-size* wff subst polarity ->* atom subst)
+    (weight atom subst)))
+
+(defun wff-size+depth (wff &optional subst &key (polarity :pos))
+  (prog->
+    (wff-size* wff subst polarity ->* atom subst)
+    (+ (size atom subst) (depth atom subst))))
+
+(defun wff-weight+depth (wff &optional subst &key (polarity :pos))
+  (prog->
+    (wff-size* wff subst polarity ->* atom subst)
+    (+ (weight atom subst) (depth atom subst))))
+
+(defun wff-length (wff &optional subst &key (polarity :pos))
+  (prog->
+    (wff-size* wff subst polarity ->* atom subst)
+    (declare (ignore atom subst))
+    1))
+
+(defun wff-size* (atom-size-fun wff subst *polarity*)
+  (dereference
+    wff subst
+    :if-variable (funcall atom-size-fun wff subst)
+    :if-constant (cond
+	          ((eq true wff)
+		   (if (eq :pos *polarity*) 1000000 0))
+	          ((eq false wff)
+		   (if (eq :pos *polarity*) 0 1000000))
+	          (t
+		   (funcall atom-size-fun wff subst)))
+    :if-compound (let* ((head (head wff))
+		    (kind (function-logical-symbol-p head))
+		    (args (args wff)))
+	       (ecase kind
+		 (not
+		   (wff-size* atom-size-fun (first args) subst (opposite-polarity *polarity*)))
+		 ((and or)
+		  (if (if (eq 'and kind)
+			  (eq :pos *polarity*)
+			  (eq :neg *polarity*))
+		      (let ((n 1000000))
+			(dolist (arg args)
+			  (let ((m (wff-size* atom-size-fun arg subst *polarity*)))
+			    (when (< m n)
+			      (setf n m))))
+			n)
+		      (let ((n 0))
+			(dolist (arg args)
+			  (incf n (wff-size* atom-size-fun arg subst *polarity*)))
+			n)))
+		 (implies
+		   (if (eq :pos *polarity*)
+		       (+ (wff-size* atom-size-fun (first args) subst :neg)
+			  (wff-size* atom-size-fun (second args) subst :pos))
+		       (min (wff-size* atom-size-fun (first args) subst :pos)
+			    (wff-size* atom-size-fun (second args) subst :neg))))
+		 (implied-by
+		   (if (eq :pos *polarity*)
+		       (+ (wff-size* atom-size-fun (second args) subst :neg)
+			  (wff-size* atom-size-fun (first args) subst :pos))
+		       (min (wff-size* atom-size-fun (second args) subst :pos)
+			    (wff-size* atom-size-fun (first args) subst :neg))))
+		 ((iff xor)
+		  (let ((y (if (null (cddr args))
+			       (second args)
+			       (make-compound head (rest args)))))
+		    (if (if (eq 'iff kind)
+			    (eq :pos *polarity*)
+			    (eq :neg *polarity*))
+			(min (+ (wff-size* atom-size-fun (first args) subst :pos)
+				(wff-size* atom-size-fun y subst :neg))
+			     (+ (wff-size* atom-size-fun (first args) subst :neg)
+				(wff-size* atom-size-fun y subst :pos)))
+			(min (+ (wff-size* atom-size-fun (first args) subst :pos)
+				(wff-size* atom-size-fun y subst :pos))
+			     (+ (wff-size* atom-size-fun (first args) subst :neg)
+				(wff-size* atom-size-fun y subst :neg))))))
+		 ((if answer-if)
+		   (if (eq :pos *polarity*)
+		       (min (+ (wff-size* atom-size-fun (first args) subst :neg)
+			       (wff-size* atom-size-fun (second args) subst :pos))
+			    (+ (wff-size* atom-size-fun (first args) subst :pos)
+			       (wff-size* atom-size-fun (third args) subst :pos)))
+		       (min (+ (wff-size* atom-size-fun (first args) subst :neg)
+			       (wff-size* atom-size-fun (second args) subst :neg))
+			    (+ (wff-size* atom-size-fun (first args) subst :pos)
+			       (wff-size* atom-size-fun (third args) subst :neg)))))
+		 ((nil)				;atomic
+		  (funcall atom-size-fun wff subst))))))
+
+(defun wff-neg (wff &optional subst)
+  (dereference 
+    wff subst
+    :if-constant 1
+    :if-variable 1
+    :if-compound (case (function-logical-symbol-p (head wff))
+		   ((not implies implied-by iff xor if) 
+		    0)
+		   ((and or)
+		    (dolist (arg (args wff) 1)
+		      (when (eql 0 (wff-neg arg subst))
+			(return 0))))
+		   (otherwise
+		     1))))
+
+(defun row-argument-count-limit-exceeded (row)
+  (prog->
+    (row-argument-count-limit? ->nonnil lim)
+    (quote nil -> arguments)
+    (map-terms-in-wff (row-wff row) ->* term polarity)
+    (declare (ignore polarity))
+    (cond
+     ((member-p term arguments)
+      )
+     ((eql 0 lim)
+      (return-from prog-> t))
+     (t
+      (decf lim)
+      (push term arguments)))))
+
+(defun row-weight-limit-exceeded (row)
+  (let ((lim (row-weight-limit?)))
+    (and lim
+         (not (row-input-p row))
+         (not (row-embedding-p row))
+         (< lim (row-weight row)))))
+
+(defun row-weight-before-simplification-limit-exceeded (row)
+  (let ((lim (row-weight-before-simplification-limit?)))
+    (and lim
+         (not (row-input-p row))
+         (not (row-embedding-p row))
+         (< lim (row-weight row)))))
+
+(defun row-proof-length-limit-exceeded (row lim)
+  (cond
+   ((member (row-reason row) '(assertion assumption negated_conjecture))
+    nil)
+   (t
+    (let ((lim-1 (- lim 1))
+          (row-numbers (make-sparse-vector :boolean t)))
+      (labels
+        ((row-proof-length-limit-exceeded* (row)
+           (unless (or (member (row-reason row) '(assertion assumption negated_conjecture))
+                       (sparef row-numbers (row-number row)))
+             (cond
+              ((= lim-1 (sparse-vector-count row-numbers))
+               (return-from row-proof-length-limit-exceeded t))
+              (t
+               (setf (sparef row-numbers (row-number row)) t)
+               (map-rows-in-reason #'row-proof-length-limit-exceeded* (row-reason row)))))))
+        (map-rows-in-reason #'row-proof-length-limit-exceeded* (row-reason row)))))))
+
+(defun maximum-and-minimum-clause-lengths (wff subst)
+  ;; return maximum and minimum lengths of clauses in cnf expansion of wff
+  (dereference
+    wff subst
+    :if-variable (values 1 1)
+    :if-constant (values 1 1)			;special case for true and false?
+    :if-compound (let* ((head (head wff))
+			(kind (function-logical-symbol-p head)))
+		   (ecase kind
+		     (not
+		       (maximum-and-minimum-clause-lengths-neg (arg1 wff) subst))
+		     (and
+		       (let ((max 0) (min 1000000))
+			 (prog->
+			   (dolist (args wff) ->* arg)
+			   (maximum-and-minimum-clause-lengths arg subst -> max1 min1)
+			   (setf max (max max max1))
+			   (setf min (min min min1)))
+			 (values max min)))
+		     (or
+		       (let ((max 0) (min 0))
+			 (prog->
+			   (dolist (args wff) ->* arg)
+			   (maximum-and-minimum-clause-lengths arg subst -> max1 min1)
+			   (setf max (+ max max1))
+			   (setf min (+ min min1)))
+			 (values max min)))
+		     (implies
+		       (prog->
+                         (args wff -> args)
+			 (maximum-and-minimum-clause-lengths-neg (first args) subst -> max1 min1)
+			 (maximum-and-minimum-clause-lengths (second args) subst -> max2 min2)
+			 (values (+ max1 max2) (+ min1 min2))))
+		     (implied-by
+		       (prog->
+                         (args wff -> args)
+			 (maximum-and-minimum-clause-lengths-neg (second args) subst -> max1 min1)
+			 (maximum-and-minimum-clause-lengths (first args) subst -> max2 min2)
+			 (values (+ max1 max2) (+ min1 min2))))
+		     ((iff xor if answer-if)
+		      (unimplemented))
+		     ((nil)
+		      (values 1 1))))))
+
+(defun maximum-and-minimum-clause-lengths-neg (wff subst)
+  ;; return maximum and minimum lengths of clauses in cnf expansion of wff
+  (dereference
+    wff subst
+    :if-variable (values 1 1)
+    :if-constant (values 1 1)			;special case for true and false?
+    :if-compound (let* ((head (head wff))
+			(kind (function-logical-symbol-p head)))
+		   (ecase kind
+		     (not
+		       (maximum-and-minimum-clause-lengths (arg1 wff) subst))
+		     (and
+		       (let ((max 0) (min 0))
+			 (prog->
+			   (dolist (args wff) ->* arg)
+			   (maximum-and-minimum-clause-lengths-neg arg subst -> max1 min1)
+			   (setf max (+ max max1))
+			   (setf min (+ min min1)))
+			 (values max min)))
+		     (or
+		       (let ((max 0) (min 1000000))
+			 (prog->
+			   (dolist (args wff) ->* arg)
+			   (maximum-and-minimum-clause-lengths-neg arg subst -> max1 min1)
+			   (setf max (max max max1))
+			   (setf min (min min min1)))
+			 (values max min)))
+		     (implies
+		       (prog->
+                         (args wff -> args)
+			 (maximum-and-minimum-clause-lengths (first args) subst -> max1 min1)
+			 (maximum-and-minimum-clause-lengths-neg (second args) subst -> max2 min2)
+			 (values (max max1 max2) (min min1 min2))))
+		     (implied-by
+		       (prog->
+                         (args wff -> args)
+			 (maximum-and-minimum-clause-lengths (second args) subst -> max1 min1)
+			 (maximum-and-minimum-clause-lengths-neg (first args) subst -> max2 min2)
+			 (values (max max1 max2) (min min1 min2))))
+		     ((iff xor if answer-if)
+		      (unimplemented))
+		     ((nil)
+		      (values 1 1))))))
+
+;;; eval.lisp EOF

snark-20120808r02/src/feature-system.lisp

@@ -0,0 +1,37 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: common-lisp-user -*-
+;;; File: feature-system.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2005.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :common-lisp-user)
+
+(defpackage :snark-feature
+  (:use :common-lisp :snark-lisp)
+  (:export
+   #:initialize-features
+   #:make-feature #:declare-feature
+   #:declare-features-incompatible
+   #:feature? #:feature-parent
+   #:the-feature
+   #:delete-feature #:feature-live?
+   #:feature-union #:feature-subsumes?
+   #:print-feature-tree
+   ))
+
+(loads "feature")
+
+;;; feature-system.lisp EOF

snark-20120808r02/src/feature-vector-index.lisp

@@ -0,0 +1,157 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: feature-vector-index.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defvar *feature-vector-row-index*)
+(defvar *feature-vector-term-index*)
+
+(defstruct (feature-vector-index
+            (:include trie)
+            (:constructor make-feature-vector-index0)
+            (:copier nil))
+  (entry-counter (make-counter) :read-only t)
+  (retrieve-generalization-calls 0 :type integer)	;forward subsumption
+  (retrieve-generalization-count 0 :type integer)
+  (retrieve-instance-calls 0 :type integer)		;backward subsumption
+  (retrieve-instance-count 0 :type integer))
+
+(defun make-feature-vector-row-index ()
+  (setf *feature-vector-row-index* (make-feature-vector-index0)))
+
+(defun make-feature-vector-term-index ()
+  (setf *feature-vector-term-index* (make-feature-vector-index0)))
+
+(defun feature-vector-index-entry-number (entry)
+  (cond
+   ((row-p entry)
+    (row-number entry))
+   (t
+    (tme-number entry))))
+
+(defun feature-vector-index-entry-keys (entry)
+  (cond
+   ((row-p entry)
+    (clause-feature-vector (row-wff entry)))
+   (t
+    (atom-or-term-feature-vector (index-entry-term entry)))))
+
+(defun feature-vector-index-insert (entry index)
+  (let* ((entry# (feature-vector-index-entry-number entry))
+         (keys (feature-vector-index-entry-keys entry))
+         (entries (trieref index keys)))
+    (cond
+     ((null entries)
+      (setf (sparef (setf (trieref index keys) (make-sparse-vector)) entry#) entry)
+      (increment-counter (feature-vector-index-entry-counter index)))
+     (t
+      (let ((c (sparse-vector-count entries)))
+        (setf (sparef entries entry#) entry)
+        (let ((c* (sparse-vector-count entries)))
+          (when (< c c*)
+            (increment-counter (feature-vector-index-entry-counter index)))))))
+    nil))
+
+(defun feature-vector-index-delete (entry index)
+  (let* ((entry# (feature-vector-index-entry-number entry))
+         (keys (feature-vector-index-entry-keys entry))
+         (entries (trieref index keys)))
+    (unless (null entries)
+      (let ((c (sparse-vector-count entries)))
+        (setf (sparef entries entry#) nil)
+        (let ((c* (sparse-vector-count entries)))
+          (when (> c c*)
+            (decrement-counter (feature-vector-index-entry-counter index))
+            (when (= 0 c*)
+              (setf (trieref index keys) nil))))))
+    nil))
+
+(defun map-feature-vector-row-index-forward-subsumption-candidates (function row)
+  (prog->
+    (identity *feature-vector-row-index* -> index)
+    (incf (feature-vector-index-retrieve-generalization-calls index))
+    (map-fv-trie<= index (clause-feature-vector (row-wff row)) ->* entries)
+    (incf (feature-vector-index-retrieve-generalization-count index) (sparse-vector-count entries))
+    (map-sparse-vector function entries)))
+
+(defun map-feature-vector-row-index-backward-subsumption-candidates (function row)
+  (prog->
+    (identity *feature-vector-row-index* -> index)
+    (incf (feature-vector-index-retrieve-instance-calls index))
+    (map-fv-trie>= index (clause-feature-vector (row-wff row)) ->* entries)
+    (incf (feature-vector-index-retrieve-instance-count index) (sparse-vector-count entries))
+    (map-sparse-vector function entries)))
+
+(defun map-feature-vector-term-index-generalizations (function term &optional subst)
+  (prog->
+    (dereference term subst :if-variable none :if-constant term :if-compound (head term) -> head)
+    (identity *feature-vector-term-index* -> index)
+    (incf (feature-vector-index-retrieve-generalization-calls index))
+    (map-fv-trie<= index (atom-or-term-feature-vector term subst) ->* entries)
+    (map-sparse-vector entries ->* entry)
+    (index-entry-term entry -> term2)
+    (dereference term2 nil :if-variable head :if-constant term2 :if-compound (head term2) -> head2)
+    (when (eql head head2)
+      (incf (feature-vector-index-retrieve-generalization-count index))
+      (funcall function entry))))
+
+(defun map-feature-vector-term-index-instances (function term &optional subst)
+  (prog->
+    (dereference term subst :if-variable none :if-constant term :if-compound (head term) -> head)
+    (identity *feature-vector-term-index* -> index)
+    (incf (feature-vector-index-retrieve-instance-calls index))
+    (map-fv-trie>= index (atom-or-term-feature-vector term subst) ->* entries)
+    (map-sparse-vector entries ->* entry)
+    (index-entry-term entry -> term2)
+    (dereference term2 nil :if-variable none :if-constant term2 :if-compound (head term2) -> head2)
+    (when (or (eq none head) (eql head head2))
+      (incf (feature-vector-index-retrieve-instance-count index))
+      (funcall function entry))))
+
+(defun print-feature-vector-index1 (index format1 format2 format3 format4)
+  (let ((entries-count 0))
+    (prog->
+      (map-trie index ->* entries)
+      (setf entries-count (+ entries-count (sparse-vector-count entries))))
+    (mvlet (((:values current peak added deleted) (counter-values (feature-vector-index-entry-counter index))))
+      (format t format1 current peak added deleted))
+    (mvlet (((:values current peak added deleted) (counter-values (feature-vector-index-node-counter index))))
+      (format t format2 current peak added deleted))
+    (unless (eql 0 (feature-vector-index-retrieve-generalization-calls index))
+      (format t format3 (feature-vector-index-retrieve-generalization-count index) (feature-vector-index-retrieve-generalization-calls index)))
+    (unless (eql 0 (feature-vector-index-retrieve-instance-calls index))
+      (format t format4 (feature-vector-index-retrieve-instance-count index) (feature-vector-index-retrieve-instance-calls index)))))
+  
+(defun print-feature-vector-row-index ()
+  (print-feature-vector-index1
+   *feature-vector-row-index*
+   "~%; Feature-vector-row-index has ~:D entr~:@P (~:D at peak, ~:D added, ~:D deleted)."
+   "~%; Feature-vector-row-index has ~:D node~:P (~:D at peak, ~:D added, ~:D deleted)."
+   "~%;  Retrieved ~:D possibly forward subsuming row~:P in ~:D call~:P."
+   "~%;  Retrieved ~:D possibly backward subsumed row~:P in ~:D call~:P."))
+
+(defun print-feature-vector-term-index ()
+  (print-feature-vector-index1
+   *feature-vector-term-index*
+   "~%; Feature-vector-term-index has ~:D entr~:@P (~:D at peak, ~:D added, ~:D deleted)."
+   "~%; Feature-vector-term-index has ~:D node~:P (~:D at peak, ~:D added, ~:D deleted)."
+   "~%;  Retrieved ~:D possibly generalization term~:P in ~:D call~:P."
+   "~%;  Retrieved ~:D possibly instance term~:P in ~:D call~:P."))
+
+;;; feature-vector-index.lisp EOF

snark-20120808r02/src/feature-vector-trie.lisp

@@ -0,0 +1,76 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: feature-vector-trie.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+;;; feature vector tries are indexed by keys in ascending value
+;;; where each key combines a feature number and its value
+
+(definline fv-trie-key (feature-number feature-value)
+  (+ (* (+ $fv-maximum-feature-value 1) feature-number) feature-value))
+
+(definline fv-trie-key-feature (key)
+  (nth-value 0 (floor key (+ $fv-maximum-feature-value 1))))
+
+(definline fv-trie-key-value (key)
+  (mod key (+ $fv-maximum-feature-value 1)))
+
+(defun map-fv-trie<= (function trie keys)
+  (labels
+    ((mfvt (node keys done)
+       (unless done
+         (let ((d (trie-node-data node)))
+           (when d
+             (funcall function d))))
+       (when keys
+         (prog->
+           (rest keys -> r)
+           (mfvt node r t)
+           (trie-node-branches node ->nonnil b)
+           (first keys -> key)
+           ;; map over subtries for key-feature = 1 ... key-feature = key-value
+           (+ key (- 1 (fv-trie-key-value key)) -> key1)
+           (cond
+            ((= key1 key)
+             (sparef b key ->nonnil node)
+             (mfvt node r nil))
+            (t
+             (map-sparse-vector b :min key1 :max key ->* node)
+             (mfvt node r nil)))))))
+    (mfvt (trie-top-node trie) keys nil)))
+
+(defun map-fv-trie>= (function trie keys)
+  (labels
+    ((mfvt (node keys)
+       (if (null keys)
+           (map-trie function node)
+           (prog->
+             (trie-node-branches node ->nonnil b)
+             (rest keys -> r)
+             (first keys -> key)
+             (- key (fv-trie-key-value key) -> key0)
+             (map-sparse-vector-with-indexes b :max (+ key0 $fv-maximum-feature-value) ->* node k)
+             (cond
+              ((< k key0)
+               (mfvt node keys))
+              ((>= k key)
+               (mfvt node r)))))))
+    (mfvt (trie-top-node trie) keys)))
+
+;;; feature-vector-trie.lisp EOF

snark-20120808r02/src/feature-vector.lisp

@@ -0,0 +1,153 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: feature-vector.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defconstant $fv-maximum-feature-value 999)
+(defconstant $fv-features-per-symbol 10)
+(defconstant $fv-offset-pos-count 0)		;number of occurrences in positive literals
+(defconstant $fv-offset-neg-count 1)		;number of occurrences in negative literals
+(defconstant $fv-offset-pos-max-depth 2)	;maximum depth of occurrences in positive literals
+(defconstant $fv-offset-neg-max-depth 3)	;maximum depth of occurrences in negative literals
+(defconstant $fv-offset-pos-min-depth 4)	;minimum depth of occurrences in positive literals (negated)
+(defconstant $fv-offset-neg-min-depth 5)	;minimum depth of occurrences in negative literals (negated)
+(defconstant $fv-number-ground 0)		;pseudo symbol-number for ground literal counts, doesn't match any actual symbol-number
+
+(declare-snark-option feature-vector-symbol-number-folding 10 10)
+
+(defun new-feature-vector ()
+  (make-sparse-vector :default-value 0))
+
+(defun feature-vector-list (fv)
+  ;; convert to list form suitable for input to trie.lisp operations
+  (let ((fv* nil))
+    (prog->
+      (map-sparse-vector-with-indexes fv :reverse t ->* v k)
+      (cl:assert (< 0 v))
+      (setf fv* (list* (fv-trie-key k v) fv*)))
+    fv*))
+
+(defun update-feature-vector (symbol-number relation-symbol? arity polarity count depth fv)
+  (let* ((symbol-number* (let ((n (feature-vector-symbol-number-folding?)))
+                           (if n
+                               (+ (mod symbol-number n)
+                                  (if relation-symbol?	;fold relations and functions separately
+                                      (+ 1 (case arity (0 (* 1 n)) (1 (* 2 n)) (2 (* 3 n)) (otherwise (* 4 n))))
+                                      (+ 1 (case arity (0 (* 5 n)) (1 (* 6 n)) (2 (* 7 n)) (otherwise (* 8 n))))))
+                               symbol-number)))
+         (base (* $fv-features-per-symbol symbol-number*))
+         (pos (ecase polarity (:pos t) (:neg nil))))
+    (cl:assert (and (<= 1 count) (<= 0 depth)))
+    (cond
+     (relation-symbol?
+      (let* ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count)))
+             (v (sparef fv count-index))
+             (v* (min $fv-maximum-feature-value (+ v count))))
+        (unless (= v v*)
+          (setf (sparef fv count-index) v*))))
+     (t
+      (let* ((max-depth-index (+ base (if pos $fv-offset-pos-max-depth $fv-offset-neg-max-depth)))
+             (v (sparef fv max-depth-index))
+             (v* (min $fv-maximum-feature-value (max v depth))))
+        (unless (= v v*)
+          (setf (sparef fv max-depth-index) v*)))
+      (cond
+       ((test-option49?)
+        (let* ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count)))
+               (v (sparef fv count-index))
+               (v* (min $fv-maximum-feature-value (+ v count))))
+          (unless (= v v*)
+            (setf (sparef fv count-index) v*))))
+       (t
+        (let* ((min-depth-index (+ base (if pos $fv-offset-pos-min-depth $fv-offset-neg-min-depth)))
+               (v (sparef fv min-depth-index))	;translate lower depths to higher feature values
+               (v* (max 1 (max v (- $fv-maximum-feature-value depth)))))
+          (unless (= v v*)
+            (setf (sparef fv min-depth-index) v*))
+          (cond
+           ((and (= 0 v) (< 1 count))
+            (let ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count))))
+              (setf (sparef fv count-index) (min $fv-maximum-feature-value count))))
+           ((< 0 v)				;don't store count for single occurrence
+            (let* ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count)))
+                   (v (sparef fv count-index))
+                   (v* (min $fv-maximum-feature-value (if (= 0 v) (+ 1 count) (+ v count)))))
+              (unless (= v v*)
+                (setf (sparef fv count-index) v*))))))))))
+    fv))
+
+(defun clause-feature-vector (clause &optional subst (convert-to-list? t))
+  (let ((fv (new-feature-vector)))
+    (prog->
+      (map-atoms-in-clause clause ->* atom polarity)
+      (atom-feature-vector atom subst polarity fv)
+      (unless (test-option50?)
+        (when (ground-p atom subst)
+          (incf (sparef fv (+ $fv-number-ground (if (eq :pos polarity) $fv-offset-pos-count $fv-offset-neg-count)))))))
+    (if convert-to-list? (feature-vector-list fv) fv)))
+
+(defun atom-or-term-feature-vector (x &optional subst (convert-to-list? t))
+  (let ((fv (new-feature-vector)))
+    (if (dereference
+         x subst
+         :if-constant (constant-boolean-valued-p x)
+         :if-compound-appl (function-boolean-valued-p (heada x)))
+        (atom-feature-vector x subst :pos fv)
+        (term-feature-vector x subst :pos 0 fv))
+    (if convert-to-list? (feature-vector-list fv) fv)))
+
+(defun atom-feature-vector (atom &optional subst (polarity :pos) (fv (new-feature-vector)))
+  (dereference
+   atom subst
+   :if-constant (update-feature-vector (constant-number atom) t 0 polarity 1 0 fv)
+   :if-compound (progn
+                  (update-feature-vector (function-number (head atom)) t (function-arity (head atom)) polarity 1 0 fv)
+                  (mapc #'(lambda (arg) (term-feature-vector arg subst polarity 0 fv)) (args atom))))
+  fv)
+
+(defun term-feature-vector (term &optional subst (polarity :pos) (depth 0) (fv (new-feature-vector)))
+  ;; in (p a (f b)), depth(p)=depth(a)=depth(f)=0, depth(b)=1
+  ;; compute count of associative function symbols as if term is in unflattened form
+  ;; count(f)=2 for f(a,b,c)
+  ;; compute depth of terms with associatve function symbols as if term is in flattened form
+  ;; depth(a)=1 for f(f(a,b),c)
+  (labels
+    ((tfv (term depth)
+       (dereference
+        term subst
+        :if-constant (update-feature-vector (constant-number term) nil 0 polarity 1 depth fv)
+        :if-compound (prog->
+                       (head term -> head)
+                       (args term -> args)
+                       (if (function-associative head) head nil -> head-if-associative)
+                       (if head-if-associative
+                           (update-feature-vector (function-number head) nil (function-arity head) polarity (max (- (length args) 1) 1) depth fv)
+                           (update-feature-vector (function-number head) nil (function-arity head) polarity 1 depth fv))
+                       (mapc #'(lambda (arg)
+                                 (if (and head-if-associative
+                                          (dereference
+                                           arg subst
+                                           :if-compound (and head-if-associative (eq head-if-associative (head arg)))))
+                                     (tfv arg depth)
+                                     (tfv arg (+ depth 1))))
+                             args)))))
+    (tfv term depth))
+  fv)
+
+;;; feature-vector.lisp EOF

snark-20120808r02/src/feature.lisp

@@ -0,0 +1,831 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-feature -*-
+;;; File: feature.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark-feature)
+
+;;; a tree of features
+;;;
+;;; in the tree of features, if s2 is a descendant of s1,
+;;; then s1 is less deep than s2 on same branch (feature< s1 s2)
+;;; and s2 is more specific than s1 (feature> s2 s1)
+;;;
+;;; feature expressions are single features or length>1 lists of features
+;;; feature expressions are maximally specific and nonredundant;
+;;; in a list of features, no feature is >= another
+;;; lists of features are ordered by feature-preorder-min
+;;;
+;;; when combining features, the union is formed of feature expressions
+;;;
+;;; children of a feature can be declared to be incompatible
+;;; they and their descendants cannot be used together
+;;; their union is nil (bottom value denoting incompatible features)
+;;;
+;;; features can be deleted rendering feature expressions that contain them "not live"
+;;; deleting a feature also causes deletion of its descendant (more specific) features
+;;;
+;;; initialize-features - creates tree of features *feature-tree* with an undeletable root feature
+;;; make-feature        - creates a feature, can specify name and parent and children-incompatible=t/nil
+;;; declare-feature     - returns or creates a feature or associates a name with a conjunction of features
+;;; declare-features-incompatible - declares a pair (or larger set) of features to be incompatible
+;;; feature?            - returns t for single feature, nil otherwise
+;;; feature-parent      - returns parent of feature, nil if root
+;;; the-feature         - coerces name to feature, nil, warn, or error if doesn't exist or deleted
+;;; delete-feature      - deletes feature from tree of features
+;;; feature-live?       - returns feature expression arg if its features are undeleted, nil otherwise
+;;; feature-union       - returns union of two feature expressions, nil if incompatible
+;;; feature-subsumes?   - returns t if 2nd arg is more specific feature or list of features than 1st, nil otherwise
+;;; print-feature-tree  - prints feature tree
+;;;
+;;; features can be declared only once
+;;; features must be declared before they are used
+;;; feature incompatibilities must be declared before incompatible features are used
+
+(defvar *feature-tree*)
+
+(defstruct (feature-tree
+            (:copier nil))
+  (root nil :read-only t)
+  (name-table (make-hash-table) :read-only t)
+  (canonical-lists (make-hash-table :test #'equal)))
+
+(defstruct (feature
+            (:constructor make-feature0 (name parent children-incompatible depth))
+            (:print-function print-feature3)
+            (:predicate feature?)
+            (:copier nil))
+  (name nil)
+  (parent nil)
+  (children-incompatible nil)
+  (depth 0 :read-only t)
+  (type nil)				;nil, :deleted, or (:characteristic-feature ...)
+  (preorder-min 0)			;feature number
+  (preorder-max 0)			;subfeature numbers in [preorder-min+1,preorder-max]
+  (children nil)
+  (incompatible-features nil)		;(N incompat1 ... incompatN) for 2-ary nogoods
+  (users-in-name-table nil)
+  (users-in-canonical-lists nil)
+  (nogoods nil)
+  (code nil))
+
+(defstruct (feature-combo
+            (:constructor make-feature-combo (list))
+            (:print-function print-feature-combo3)
+            (:predicate feature-combo?)
+            (:copier nil))
+  (name nil)
+  (list nil :read-only t))
+
+(defun initialize-features ()
+  (let ((root (make-feature0 'top nil nil 0)))
+    (setf *feature-tree* (make-feature-tree :root root))
+    (setf (gethash 'top (feature-tree-name-table *feature-tree*)) root)
+    (declare-feature 'characteristic-feature)
+    root))
+
+(defun make-feature1 (name parent children-incompatible)
+  (let* ((tree *feature-tree*)
+         (root (feature-tree-root tree)))
+    (unless parent
+      (setf parent root))
+    (let ((new-node (make-feature0 name parent children-incompatible (+ (feature-depth parent) 1))))
+      (when name
+        (setf (gethash name (feature-tree-name-table tree)) new-node))
+      (let ((children (feature-children parent)) (n (feature-preorder-max parent)) m)
+        (cond
+         (children
+          (let ((last (last children)))
+            (setf m (+ (feature-preorder-max (first last)) 1))
+            (setf (cdr last) (list new-node))))
+         (t
+          (setf m (+ (feature-preorder-min parent) 1))
+          (setf (feature-children parent) (list new-node))))
+        (cond
+         ((<= m n)
+          (setf (feature-preorder-min new-node) m)
+          (setf (feature-preorder-max new-node) (floor (+ m n) 2)))
+         (t
+          (feature-tree-preorder-labeling root -1))))
+      new-node)))
+
+(defun make-feature (&key name parent children-incompatible)
+  ;; always makes a new feature even if one by this name already exists
+  (when parent
+    (unless (feature? parent)
+      (let ((parent* (and (can-be-feature-name parent nil) (the-feature parent nil))))
+        (if (feature? parent*)
+            (setf parent parent*)
+            (error "There is no feature ~S." parent)))))
+  (when name
+    (if (can-be-feature-name name 'error)
+        (delete-feature-name name)
+        (setf name nil)))
+  (make-feature1 name parent children-incompatible))
+
+(defun declare-feature (name &key parent children-incompatible iff implies new-name alias)
+  ;; does not make a new feature if one by this name already exists
+  ;; should check that parent, children-incompatible, iff definition are compatible
+  (can-be-feature-name name 'error)
+  (declare-feature-aliases
+   (or (and new-name (not (eq name new-name)) (rename-feature name new-name))
+       (lookup-feature-name name)
+       (cond
+        ((or implies iff)
+         (cl:assert (not (and iff children-incompatible)))
+         (cl:assert (null parent))
+         (let ((cf nil))
+           (when implies
+             (cl:assert (null iff))
+             (setf implies (the-feature implies 'error 'error :dont-canonize))
+             ;; use implies as parent if possible
+             (when (feature? implies)
+               (return-from declare-feature
+                 (make-feature :name name :parent implies :children-incompatible children-incompatible)))
+             (setf iff (cons (setf cf (make-feature :parent (or (extract-a-characteristic-feature implies) 'characteristic-feature)
+                                                    :children-incompatible children-incompatible))
+                             (mklist implies))))
+           ;; make name designate the iff feature expression (a feature or list of features)
+           (let ((v (the-feature iff 'error)))
+             (setf (gethash name (feature-tree-name-table *feature-tree*)) v)
+             (cond
+              ((feature-combo? v)
+               (unless (eq v (lookup-feature-name (feature-combo-name v)))
+                 (setf (feature-combo-name v) name))
+               (dolist (v (feature-combo-list v))
+                 (push name (feature-users-in-name-table v))))
+              (t
+               (push name (feature-users-in-name-table v))))
+             (when cf
+               (setf (feature-name cf) (make-symbol (to-string "*" name "*")))
+               (setf (feature-type cf) (list :characteristic-feature v)))
+             v)))
+        (t
+         (make-feature :name name :parent parent :children-incompatible children-incompatible))))
+   alias))
+
+(defun declare-feature-aliases (n alias)
+  (mapc #'(lambda (alias) (declare-feature alias :iff n)) (mklist alias))
+  n)
+
+(defun characteristic-feature-type (n)
+  (let ((type (feature-type n)))
+    (and (consp type) (eq :characteristic-feature (first type)) type)))
+
+(defun extract-a-characteristic-feature (x)
+  (let ((l (characteristic-feature-restriction (feature-combo-list x))))
+    (cond
+     ((null (rest l))
+      (if (characteristic-feature-type (first l)) (first l) nil))
+     (t
+      (dolist (x l nil)
+        (when (and (characteristic-feature-type x) (not (feature-children-incompatible x)))
+          (return x)))))))        
+
+(defun rename-feature (name new-name)
+  (can-be-feature-name new-name 'error)
+  (when (lookup-feature-name new-name)
+    (error "Feature name ~S is already in use." new-name))
+  (let ((v (lookup-feature-name name 'error))
+        (name-table (feature-tree-name-table *feature-tree*)))
+    (remhash name name-table)
+    (setf (gethash new-name name-table) v)
+    (cond
+     ((eq name (feature-name v))
+      (when (feature-combo? v)
+        (dolist (x (feature-combo-list v))
+          (setf (feature-users-in-name-table x) (nsubstitute new-name name (feature-users-in-name-table x)))))
+      (setf (feature-name v) new-name))
+     (t
+      (setf (feature-users-in-name-table v) (nsubstitute new-name name (feature-users-in-name-table v)))))
+    v))
+
+(defun delete-feature (n1)
+  (let* ((tree *feature-tree*)
+         (name-table (feature-tree-name-table tree)))
+    (labels
+      ((delete-feature1 (n)
+         (setf (feature-type n) :deleted)
+         (setf (feature-parent n) nil)
+         ;; delete this feature from the name table
+         (let ((name (feature-name n)))
+           (when name
+             (remhash name name-table)
+             (setf (feature-name n) nil)))
+         (let ((names (feature-users-in-name-table n)))
+           (when names
+             (dolist (name names)
+               (remhash name name-table))
+             (setf (feature-users-in-name-table n) nil)))
+         ;; delete every canonical list that contains this feature
+         ;; also delete references to deleted canonical lists from this and other features
+         (let ((cls (feature-users-in-canonical-lists n)))
+           (when cls
+             (let ((canonical-lists (feature-tree-canonical-lists tree)))
+               (dolist (cl cls)
+                 (multiple-value-bind (v found) (gethash (feature-canonical-list-key cl) canonical-lists)
+                   (cl:assert found)
+                   (dolist (n2 cl)
+                     (unless (eq n n2)
+                       (setf (feature-users-in-canonical-lists n2) (delete cl (feature-users-in-canonical-lists n2) :count 1))
+                       (when (null v)
+                         (setf (feature-nogoods n2) (delete cl (feature-nogoods n2) :count 1)))))
+                   (remhash cl canonical-lists))))
+             (setf (feature-users-in-canonical-lists n) nil)
+             (setf (feature-nogoods n) nil)))
+         ;; update information about incompatible pair of features
+         (let ((incompat (feature-incompatible-features n)))
+           (when incompat
+             (dolist (n2 (rest incompat))
+               (let* ((incompat2 (feature-incompatible-features n2))
+                      (c (- (first incompat2) 1)))
+                 (if (eql 0 c)
+                     (setf (feature-incompatible-features n2) nil)
+                     (let ((l (rest incompat2)))
+                       (setf (rest incompat2) (if (eq n (first l)) (rest l) (delete n l :count 1))
+                             (first incompat2) c)))))
+             (setf (feature-incompatible-features n) nil)))
+         (let ((children (feature-children n)))
+           (when children
+             (dolist (child children)
+               (delete-feature1 child))
+             (setf (feature-children n) nil)))))
+      (cl:assert (or (feature? n1) (can-be-feature-name n1 nil)))
+      (let ((n (the-feature n1 nil)))
+        (when n
+          (cond
+           ((feature-combo? n)
+            (delete-feature-name n1)			;delete the name of a list of features
+            (dolist (x (feature-combo-list n))		;delete its characteristic feature if there is one
+              (let ((v (characteristic-feature-type x)))
+                (when (and v (eq n (second v)))
+                  (delete-feature x)
+                  (return)))))
+           (t
+            (let ((parent (feature-parent n)))
+              (cl:assert parent)			;can't delete root node
+              ;; detach this feature from the tree of features
+              (let ((l (feature-children parent)))
+                (setf (feature-children parent) (if (eq n (first l)) (rest l) (delete n l :count 1))))
+              ;; mark this feature and all its descendants as deleted
+              (delete-feature1 n))))
+          t)))))
+
+(definline feature-deleted? (node)
+  (eq :deleted (feature-type node)))
+
+(defun can-be-feature-name (x &optional action)
+  (or (and x (symbolp x) (not (eq 'and x)) (not (eq 'or x)) (not (eq 'not x)))
+      (and action (funcall action "~S cannot be the name of a feature." x))))
+
+(defun lookup-feature-name (name &optional action)
+  (or (gethash name (feature-tree-name-table *feature-tree*))
+      (and action (funcall action "There is no feature named ~S." name))))
+
+(defun delete-feature-name (name)
+  (let* ((name-table (feature-tree-name-table *feature-tree*))
+         (v (gethash name name-table)))
+    (when v
+      (cond
+       ((feature-combo? v)
+        (when (eq name (feature-combo-name v))
+          (setf (feature-combo-name v) nil))
+        (dolist (x (feature-combo-list v))
+          (setf (feature-users-in-name-table x) (delete name (feature-users-in-name-table x) :count 1))))
+       (t
+        (when (eq name (feature-name v))
+          (setf (feature-name v) nil))
+        (setf (feature-users-in-name-table v) (delete name (feature-users-in-name-table v) :count 1))))
+      (remhash name name-table))))
+
+(defun the-feature (x &optional (action 'error) (action2 action) canonize-option)
+  ;; returns
+  ;;   feature from its name
+  ;;   or conjunction of features from list of names
+  ;; feature or feature-combo structures can be used in place of names
+  (flet ((the-feature0 (x)
+           (if (or (feature? x) (feature-combo? x))
+               (feature-live? x action)
+               (lookup-feature-name x action))))
+    (cond
+     ((atom x)
+      (the-feature0 x))
+     (t
+      (when (eq 'and (first x))
+        (setf x (rest x)))
+      (let ((l (the-feature (first x) action action2 :dont-canonize)))
+        (cond
+         ((null l)
+          (return-from the-feature nil))
+         (t
+          (dolist (x1 (rest x))
+            (let ((x1* (the-feature x1 action action2 :dont-canonize)))
+              (if (null x1*)
+                  (return-from the-feature nil)
+                  (setf l (feature-union x1* l nil)))))))
+        (or (feature-canonize l canonize-option)
+            (and action2 (funcall action2 "The conjunction of ~A~{ and ~A~} are incompatible." (first x) (rest x)))))))))
+
+(defun feature-tree-preorder-labeling (node n)
+  (setf (feature-preorder-min node) (incf n))
+  (dolist (c (feature-children node))
+    (setf n (feature-tree-preorder-labeling c n)))
+  (setf (feature-preorder-max node) (+ n 999)))
+
+(definline feature> (n1 n2)
+  ;; is n1 a descendant of n2?
+  (and (not (eq n1 n2))
+       (>= (feature-preorder-max n2)
+           (feature-preorder-min n1)
+           (feature-preorder-min n2))))
+
+(definline feature>= (n1 n2)
+  (or (eq n1 n2)
+      (>= (feature-preorder-max n2)
+          (feature-preorder-min n1)
+          (feature-preorder-min n2))))
+
+(definline feature< (n1 n2)
+  (feature> n2 n1))
+
+(definline feature<= (n1 n2)
+  (feature>= n2 n1))
+
+(defun feature-ancestor (node &optional (n 1))
+;;(cl:assert (<= 0 n (feature-depth node)))
+  (dotimes (i n)
+    (declare (ignorable i))
+    (setf node (feature-parent node)))
+  node)
+
+(definline nearest-common-feature-ancestor (node1 node2)
+  ;; returns the nearest common ancestor of node1 and node2
+  ;; also returns the counts of declared-incompatible-features along each path
+  (let ((d1 (feature-depth node1))
+        (d2 (feature-depth node2))
+        (nincompat1 0)
+        (nincompat2 0))
+    (cond
+     ((> d1 d2)
+      (dotimes (i (- d1 d2))
+        (declare (ignorable i))
+        (let ((incompat (feature-incompatible-features node1)))
+          (when incompat
+            (incf nincompat1 (first incompat))))
+        (setf node1 (feature-parent node1))))
+     ((< d1 d2)
+      (dotimes (i (- d2 d1))
+        (declare (ignorable i))
+        (let ((incompat (feature-incompatible-features node2)))
+          (when incompat
+            (incf nincompat2 (first incompat))))
+        (setf node2 (feature-parent node2)))))
+    (loop
+      (if (eq node1 node2)
+          (return (values node1 nincompat1 nincompat2))
+          (progn
+            (let ((incompat (feature-incompatible-features node1)))
+              (when incompat
+                (incf nincompat1 (first incompat))))
+            (let ((incompat (feature-incompatible-features node2)))
+              (when incompat
+                (incf nincompat2 (first incompat))))
+            (setf node1 (feature-parent node1)
+                  node2 (feature-parent node2)))))))
+
+(defun feature-incompatible0 (s1 s2)
+  ;; s1 and s2 are single features
+  (and (not (eq s1 s2))
+       (multiple-value-bind (s nincompat1 nincompat2) (nearest-common-feature-ancestor s1 s2)
+         (and (not (eq s s1))
+              (not (eq s s2))
+              (or (feature-children-incompatible s)
+                  (and (not (eql 0 nincompat1))
+                       (not (eql 0 nincompat2))
+                       (progn
+                         (when (> nincompat1 nincompat2)
+                           (psetf s1 s2 s2 s1))
+                         (loop				;is s2 a descendant of any feature in incompat1?
+                           (cond
+                            ((let ((incompat (feature-incompatible-features s1)))
+                               (and incompat
+                                    (dolist (y (rest incompat) nil)
+                                      (when (feature<= y s2)
+                                        (return t)))))
+                             (return t))
+                            ((eq s (setf s1 (feature-parent s1)))
+                             (return nil)))))))))))
+
+(definline feature-incompatible1 (s1 s2)
+  ;; s1 is single feature, s2 is nonempty list of features
+  (dolist (s2 s2 nil)
+    (when (feature-incompatible0 s1 s2)
+      (return t))))
+
+(definline feature-incompatible2 (s1 s2)
+  ;; s1 and s2 are nonempty lists of features
+  (dolist (s1 s1 nil)
+    (when (feature-incompatible1 s1 s2)
+      (return t))))
+
+(defun feature-merge1 (s1 s2 &optional (n1 (feature-preorder-min s1)))
+  ;; s1 is single feature, s2 is nonempty list of features that does not contain s1
+  (if (< n1 (feature-preorder-min (first s2)))
+      (cons s1 s2)
+      (cons (pop s2) (if (null s2) (list s1) (feature-merge1 s1 s2 n1)))))
+
+(defun feature-merge2 (s1 s2 &optional (n1 (feature-preorder-min (first s1))) (n2 (feature-preorder-min (first s2))))
+  ;; s1 and s2 are nonempty lists of features with no common elements
+   (if (< n1 n2)
+       (cons (pop s1) (if (null s1) s2 (feature-merge2 s2 s1 n2)))
+       (cons (pop s2) (if (null s2) s1 (feature-merge2 s1 s2 n1)))))
+  
+(defun feature-set-difference (s1 s2 test)
+  ;; need something like this because set-difference is not guaranteed to preserve order (and doesn't in MCL)
+;;(cl:assert (not (null s1)))
+  (labels
+    ((fsd (s1)
+       (let ((x (first s1))
+             (l (rest s1)))
+         (if (member x s2 :test test)
+             (if (null l)
+                 nil
+                 (fsd l))
+             (if (null l)
+                 s1
+                 (let ((l* (fsd l)))
+                   (if (eq l l*)
+                       s1
+                       (cons x l*))))))))
+    (fsd s1)))
+
+(definline feature-subsumes1 (s1 s2)
+  (let ((s1min (feature-preorder-min s1))
+        (s1max (feature-preorder-max s1)))
+    (dotails (l s2 nil)					;(some (lambda (s2) (feature<= s1 s2)) s2)
+      (let ((s2 (first l)) s2min)
+        (cond
+         ((eq s1 s2)
+          (return l))
+         ((not (<= (setf s2min (feature-preorder-min s2)) s1max))
+          (return nil))
+         ((<= s1min s2min)
+          (return l)))))))
+
+(definline feature-subsumes2 (s1 s2)
+  ;; s1 and s2 are nonempty lists of features
+  (and (length<= s1 s2)
+       (dolist (s1 s1 t)				;(subsetp s1 s2 :test #'feature<=)))
+         (if (or (null s2) (null (setf s2 (feature-subsumes1 s1 s2))))
+             (return nil)
+             (setf s2 (rest s2))))))
+
+(defun feature-subsumes? (s1 s2)
+  ;; s1 and s2 are features or lists of features
+  ;; handle bottom value too: return nil if s1 or s2 is nil
+  (and s1
+       s2
+       (if (feature-combo? s1)
+           (if (feature-combo? s2)
+               (feature-subsumes2 (feature-combo-list s1) (feature-combo-list s2))
+               nil)					;(every (lambda (s1) (feature<= s1 s2)) s1), can't happen if s1 is nonredundant
+       (if (feature-combo? s2)
+           (and (feature-subsumes1 s1 (feature-combo-list s2)) t)
+           (feature<= s1 s2)))))
+
+(defun feature-canonical-list-key (s)
+  (cons (let ((n 0))
+          (dolist (s s)
+            (setf n (logxor n (or (feature-code s) (setf (feature-code s) (random most-positive-fixnum))))))
+          n)
+        s))
+
+(defun feature-canonical-list-unkey (k)
+  (rest k))
+
+(defun feature-canonize (s &optional option)
+  ;; returns nil, a feature struct, or a canonical-list-indexed feature-combo struct
+  (when (and (eq :incompatible option) (consp s) (rest s))
+    (setf s (characteristic-feature-restriction s)))
+  (cond
+   ((null s)
+    nil)
+   ((feature? s)
+    (if (eq :incompatible option) (error "Cannot declare single feature ~A to be incompatible." s) s))
+   ((feature-combo? s)
+    (if (eq :incompatible option) (error "Incompatible features already used together.") s))
+   ((null (rest s))
+    (if (eq :incompatible option) (error "Cannot declare single feature ~A to be incompatible." (first s)) (first s)))
+   ((eq :dont-canonize option)
+    s)
+   (t
+    (let ((table (feature-tree-canonical-lists *feature-tree*))
+          (k (feature-canonical-list-key s)))
+      (multiple-value-bind (v found) (gethash k table)
+        (cond
+         (found
+          (if (and v (eq :incompatible option)) (error "Incompatible features already used together.") v))
+         ;; lists of features created by feature-union are certain to be pairwise compatible
+         ;; check them for n-ary incompatibility
+         ;; inefficient test of s being subsumed by >=3-ary incompatiblity constraint
+         ((and (rrest s)
+               (let ((s* nil) (x nil))
+                 (and (let ((len 0) (n 0))
+                        (dolist (s1 s (<= 3 len))		;find at least 3 features relevant to nogoods
+                          (let ((y s1) (m 0))
+                            (loop
+                              (let ((ngs (feature-nogoods y)))
+                                (when ngs
+                                  (incf m (if (null (rest ngs)) 1 (length ngs)))))
+                              (when (null (setf y (feature-parent y)))
+                                (unless (eql 0 m)
+                                  (push s1 s*)
+                                  (incf len)
+                                  (when (or (null x) (> n m))
+                                    (setf x s1 n m)))
+                                (return))))))
+                      (let ((y x))				;x in s* has fewest nogoods; test s* against them
+                        (loop
+                          (when (dolist (ng (feature-nogoods y) nil)
+                                  (when (feature-subsumes2 ng (nreverse s*))
+                                    (return t)))
+                            (return t))
+                          (when (null (setf y (feature-parent y)))
+                            (return nil)))))))
+          nil)
+         ((eq :incompatible option)
+          (cond
+           ((null (rrest s))
+            ;; add 2-ary incompatibility constraint
+            (let* ((n1 (first s))
+                   (n2 (second s))
+                   (incompat1 (feature-incompatible-features n1))
+                   (incompat2 (feature-incompatible-features n2)))
+              (if incompat1
+                  (setf (first incompat1) (+ (first incompat1) 1) (rest incompat1) (cons n2 (rest incompat1)))
+                  (setf (feature-incompatible-features n1) (list 1 n2)))
+              (if incompat2
+                  (setf (first incompat2) (+ (first incompat2) 1) (rest incompat2) (cons n1 (rest incompat2)))
+                  (setf (feature-incompatible-features n2) (list 1 n1))))
+            nil)
+           (t
+            ;; add n-ary incompatibility constraint
+            (dolist (x s)
+              (push s (feature-nogoods x))
+              (push s (feature-users-in-canonical-lists x)))
+            (setf (gethash k table) nil))))
+         (t
+          (dolist (x s)
+            (push s (feature-users-in-canonical-lists x)))
+          (setf (gethash k table) (make-feature-combo s)))))))))
+
+(defun characteristic-feature-restriction (l)
+  ;; removes other features from feature list for which there are characteristic features
+  ;; so that restricted list can be used as shorter nogood
+  (remove-if (lambda (n1)
+               (some (lambda (n2)
+                       (and (not (eq n1 n2))
+                            (let ((v (characteristic-feature-type n2)))
+                              (and v (member n1 (feature-combo-list (second v)))))))
+                     l))
+             l))
+
+(definline feature-union0 (s1 s2)
+  ;; s1 and s2 are single features
+  (cond
+   ((eq s1 s2)
+    s1)
+   (t
+    (let ((mins1 (feature-preorder-min s1))
+          (mins2 (feature-preorder-min s2)))
+      (cond
+       ((< mins1 mins2)
+        (cond
+         ((<= mins2 (feature-preorder-max s1))		;(feature> s2 s1)
+          s2)
+         ((feature-incompatible0 s1 s2)
+          nil)
+         (t
+          (list s1 s2))))
+       (t ;(> mins2 mins1)
+        (cond
+         ((<= mins1 (feature-preorder-max s2))		;(feature> s1 s2)
+          s1)
+         ((feature-incompatible0 s1 s2)
+          nil)
+         (t
+          (list s2 s1)))))))))
+
+(definline feature-union1 (s1 s2)
+  ;; s1 is single feature, s2 is nonempty list of features
+  (cond
+   ((feature-subsumes1 s1 s2)
+    s2)
+   ((null (setf s2 (remove s1 s2 :test #'feature>)))
+    s1)
+   ((feature-incompatible1 s1 s2)
+    nil)
+   (t
+    (feature-merge1 s1 s2))))
+
+(definline feature-union2 (s1 s2)
+  ;; s1 and s2 are nonempty lists of features
+  (cond
+   ((null (setf s1 (feature-set-difference s1 s2 #'feature<=)))
+    s2)
+   ((null (setf s2 (feature-set-difference s2 s1 #'feature<)))
+    s1)
+   ((feature-incompatible2 s1 s2)
+    nil)
+   (t
+    (feature-merge2 s1 s2))))
+
+(defun feature-union (s1 s2 &optional (canonize t))
+  ;; s1 and s2 are features or lists of compatible features sorted by feature-preorder-min
+  ;; return their nonredundant union sorted by feature-preorder-min if compatible, nil if incompatible
+  ;; handle bottom value too: return nil if s1 or s2 is nil
+  (and s1
+       s2
+       (let ((v (if (or (consp s1) (feature-combo? s1))
+                    (if (or (consp s2) (feature-combo? s2))
+                        (feature-union2 (if (consp s1) s1 (feature-combo-list s1)) (if (consp s2) s2 (feature-combo-list s2)))
+                        (feature-union1 s2 (if (consp s1) s1 (feature-combo-list s1))))
+                    (if (or (consp s2) (feature-combo? s2))
+                        (feature-union1 s1 (if (consp s2) s2 (feature-combo-list s2)))
+                        (feature-union0 s1 s2)))))
+         (cond
+          ((atom v)
+           v)
+          ((null (rest v))
+           (first v))
+          ((and (feature-combo? s1) (eq (feature-combo-list s1) v))
+           s1)
+          ((and (feature-combo? s2) (eq (feature-combo-list s2) v))
+           s2)
+          ((not canonize)
+           v)
+          (t
+           (feature-canonize v))))))
+
+(defun feature-live? (s &optional action)
+  ;; returns s if s is undeleted feature or list of undeleted features, nil otherwise
+  (and s
+       (if (feature-combo? s)
+           (dolist (s (feature-combo-list s) t)
+             (when (feature-deleted? s)
+               (return (and action (funcall action "Feature ~A has been deleted." s)))))
+           (or (not (feature-deleted? s))
+               (and action (funcall action "Feature ~A has been deleted." s))))
+       s))
+
+(defun declare-features-incompatible (n1 n2 &rest more)
+  (the-feature (list* n1 n2 more) 'error nil :incompatible))
+
+(defun unthe-feature (x)
+  ;; inverse of the-feature:
+  ;; if x is composed of named features,
+  ;; creates an expression such that (the-feature expr) = x
+  (cond
+   ((feature? x)
+    (feature-name x))
+   ((feature-combo? x)
+    (or (let ((name (feature-combo-name x)))
+          (and name (symbol-package name) name))	;don't return uninterned symbols created by feature-sym
+        (let ((l nil))
+          (dolist (x (characteristic-feature-restriction (feature-combo-list x)) (if (null (rest l)) (first l) (cons 'and (nreverse l))))
+            (let ((v (characteristic-feature-type x)))
+              (if (setf v (if v (feature-combo-name (second v)) (feature-name x)))
+                  (setf l (cons v l))
+                  (return nil)))))))
+   (t
+    nil)))
+
+(defun feature-sym (x)
+  (cond
+   ((feature? x)
+    (feature-name x))
+   ((feature-combo? x)
+    (or (feature-combo-name x)
+        (let ((expr (unthe-feature x)))
+          (if (atom expr) expr (setf (feature-combo-name x) (make-symbol (apply 'to-string (second expr) (mapcan #'(lambda (x) (list "&" x)) (rrest expr)))))))))
+   (t
+    nil)))
+
+(defun print-feature3 (node stream depth)
+  (declare (ignore depth))
+  (let ((n node) (l nil))
+    (loop
+      (cond
+       ((null n)
+        (print-unreadable-object (node stream :type t :identity nil)
+          (format stream "~S~{ ~S~}" (first l) (rest l)))
+        (return))
+       ((feature-name n)
+        (if (null l)
+            (format stream "~A" (feature-name n))
+            (print-unreadable-object (node stream :type t :identity nil)
+              (format stream "~S~{ ~S~}" (feature-name n) l)))
+        (return))
+       (t
+        (push (feature-preorder-min n) l)
+        (setf n (feature-parent n)))))))
+
+(defun print-feature-combo3 (x stream depth)
+  (declare (ignore depth))
+  (let ((name (feature-sym x)))
+    (if name
+        (princ name stream)
+        (print-unreadable-object (x stream :type t :identity nil)
+          (format stream "~S~{ ~S~}" (first (feature-combo-list x)) (rest (feature-combo-list x)))))))
+
+(defun print-feature (n)
+  (prin1 (or (feature-name n) (feature-preorder-min n)))
+  n)
+
+(defun print-feature-list (l)
+  (print-feature (first l))
+  (dolist (x (rest l))
+    (princ " and ")
+    (print-feature x))
+  l)
+
+(defun print-feature-tree (&key node numbers)
+  (labels
+    ((print-node (n)
+       (terpri)
+       (when numbers
+         (format t "[~9D,~9D] " (feature-preorder-min n) (feature-preorder-max n)))
+       (let ((depth (if node (- (feature-depth n) (feature-depth node)) (feature-depth n))))
+         (unless (eql 0 depth)
+           (dotimes (i depth)
+             (princ (if (eql 0 (mod i 5)) (if (eql 0 i) "   " "|  ") ":  ")))))
+       (print-feature n)
+       (when (feature-children-incompatible n)
+         (princ ", with incompatible children"))
+       (let ((incompat (feature-incompatible-features n)))
+         (when (and incompat (< 0 (first incompat)))
+           (princ ", incompatible with ")
+           (print-feature-list (rest incompat))))         
+       (dolist (child (feature-children n))
+         (print-node child)))
+     (print-defn (name defn)
+       (terpri)
+       (prin1 name)
+       (princ " is defined as ")
+       (cond
+        ((feature-combo? defn)
+         (princ "the conjunction of ")
+         (print-feature-list (feature-combo-list defn)))
+        (t
+         (print-feature defn)))
+       (princ ".")))
+    (let ((tree *feature-tree*))
+      (unless (or (null node) (feature? node))
+        (let ((node* (and (can-be-feature-name node 'warn) (the-feature node 'warn))))
+          (cond
+           ((feature-combo? node*)
+            (print-defn node node*)
+            (return-from print-feature-tree))
+           (t
+            (setf node node*)))))
+      (print-node (or node (feature-tree-root tree)))
+      (let ((l nil))
+        (maphash (lambda (k v)
+                   (let ((s (feature-canonical-list-unkey k)))
+                     (when (and (null v) (implies node (some (lambda (x) (feature<= node x)) s)))
+                       (push s l))))
+                 (feature-tree-canonical-lists tree))
+        (when l
+          (terpri)
+          (dolist (k l)
+            (terpri)
+            (princ "The conjunction of ")
+            (print-feature-list k)
+            (princ " is incompatible."))))
+      (let ((l nil))
+        (maphash (lambda (name v)
+                   (when (if (feature-combo? v)
+                             (implies node (some (lambda (x) (feature<= node x)) (feature-combo-list v)))
+                             (and (not (eq name (feature-name v))) (implies node (feature<= node v))))
+                     (push (cons name v) l)))
+                 (feature-tree-name-table tree))
+        (when l
+          (terpri)
+          (dolist (v (sort l #'string< :key #'car))
+            (print-defn (car v) (cdr v))))))))
+
+;;; feature.lisp EOF

snark-20120808r02/src/functions.lisp

@@ -0,0 +1,414 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: functions.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(declaim (special *subsuming*))
+
+(defvar *name*)
+
+(defstruct (function-symbol
+            (:constructor make-function-symbol0 (name arity))
+            (:copier nil)
+            (:print-function print-function-symbol)
+            (:conc-name :function-))
+  (name nil)
+  (arity nil :read-only t)
+  (number nil)
+  (hash-code (make-atom-hash-code) :read-only t)
+  (boolean-valued-p nil)
+  (constructor nil)
+  (injective nil)
+  (magic t)					;nil means don't make magic-set goal for this relation
+  (allowed-in-answer t)
+  (kbo-weight 1)
+  (weight 1)
+  (constraint-theory nil)
+  (sort (top-sort))
+  (argument-sort-alist nil)
+  (logical-symbol-p nil)
+  (logical-symbol-dual nil)
+  (polarity-map nil) 				;list of unary functions to compute polarity of arguments
+  (ordering-status nil)				;:left-to-right, :right-to-left, :multiset, or :ac comparison of argument lists
+  (make-compound*-function nil)
+  (input-code nil)
+  (weight-code nil)
+  (satisfy-code nil)				;Lisp functions for making atoms headed by this relation true
+  (falsify-code nil)				;Lisp functions for making atoms headed by this relation false
+  (paramodulate-code nil)			;Lisp functions for paramodulating terms headed by this function
+  (rewrite-code nil)				;Lisp functions for rewriting terms headed by this function
+  (equality-rewrite-code nil)			;Lisp functions for rewriting equality of two terms headed by this function
+  (arithmetic-relation-rewrite-code nil)	;Lisp functions for rewriting equality of a number and an arithmetic term
+  (sort-code nil)				;Lisp functions for computing sort of a term
+  (equal-code nil)
+  (variant-code nil)
+  (unify-code nil)
+  (associative nil)
+  (commutative nil)
+;;(idempotent nil)				;unifiable terms may have different heads
+;;(inverse nil)					;unifiable terms may have different heads
+  (identity none)				;unifiable terms may have different heads (none means no identity)
+  (index-type nil)
+  (rewritable-p nil) 				;if nil, no rewrite rule exists with this symbol as lhs head
+  #+ignore (canonical-variants (make-sparse-vector))	;for instance-graphs
+  #+ignore (instance-graph				;for instance-graphs
+            (make-instance-graph
+             :name (to-string "for " *name*)))
+  #+ignore (term-memory-entries (make-sparse-vector))	;for instance-graphs
+  (plist nil))					;property list for more properties
+
+(define-plist-slot-accessor function :locked)
+(define-plist-slot-accessor function :documentation)
+(define-plist-slot-accessor function :author)
+(define-plist-slot-accessor function :source)
+(define-plist-slot-accessor function :code-name0)
+(define-plist-slot-accessor function :macro)
+(define-plist-slot-accessor function :complement)	;complement of the symbol P is the symbol ~P
+(define-plist-slot-accessor function :skolem-p)
+(define-plist-slot-accessor function :created-p)
+(define-plist-slot-accessor function :to-lisp-code)
+(define-plist-slot-accessor function :rewrites)
+(define-plist-slot-accessor function :injective-supplied)
+(define-plist-slot-accessor function :do-not-resolve)
+(define-plist-slot-accessor function :do-not-factor)
+(define-plist-slot-accessor function :do-not-paramodulate)
+(define-plist-slot-accessor function :keep-head)	;keep (fn) and (fn arg) instead of identity and arg respectively
+
+(definline function-rpo-status (fn)
+  (or (function-ordering-status fn) (rpo-status?)))
+
+(definline function-kbo-status (fn)
+  (or (function-ordering-status fn) (kbo-status?)))
+
+(defun make-function-symbol (name arity)
+  (let* ((*name* name)
+         (fn (make-function-symbol0 name arity)))
+    (setf (function-number fn) (funcall *standard-eql-numbering* :lookup fn))
+    fn))
+
+(defun function-kind (fn)
+  (cond
+   ((function-logical-symbol-p fn)
+    :logical-symbol)
+   ((function-boolean-valued-p fn)
+    :relation)
+   (t
+    :function)))
+
+(defun function-has-arity-p (fn arity)
+  (let ((a (function-arity fn)))
+    (or (eql arity a) (eq :any a) (function-associative fn))))
+
+(defun function-identity2 (fn)
+  (if (and *subsuming* (not (test-option45?))) none (function-identity fn)))
+
+(defun function-name-lessp (x y)
+  (string< x y))
+
+(defun function-name-arity-lessp (fn1 fn2)
+  (let ((name1 (function-name fn1))
+        (name2 (function-name fn2)))
+    (and (string<= name1 name2)
+         (implies (string= name1 name2)
+                  (let ((arity1 (function-arity fn1)))
+                    (and (numberp arity1)
+                         (let ((arity2 (function-arity fn2)))
+                           (and (numberp arity2) (< arity1 arity2)))))))))
+
+#+ignore
+(defun right-identity-e-term-rewriter (term subst)
+  ;; function-rewrite-code example
+  ;; (fn x e) -> x
+  (mvlet (((list x y) (args term)))
+    (if (equal-p y 'e subst) x none)))		;return value or none
+
+#+ignore
+(defun right-identity-e-term-paramodulater (cc term subst)
+  ;; function-paramodulate-code example
+  ;; (fn x y) -> x after unifying y with e
+  (prog->
+    (args term -> (list x y))
+    (unify y 'e subst ->* subst)
+    (funcall cc x subst)))		;call cc with value and substitution
+
+(defmacro set-function-code (code)
+  (let ((code-supplied (intern (to-string code :-supplied) :snark))
+        (function-code (intern (to-string :function- code) :snark)))
+    `(when ,code-supplied
+       (setf (,function-code symbol)
+             (if (listp ,code)
+                 (remove-duplicates ,code :from-end t)				;replace
+                 (cons ,code (remove ,code (,function-code symbol))))))))	;add
+
+(defun declare-function-symbol0 (symbol
+                                 &key
+                                 new-name
+                                 alias
+                                 sort
+                                 locked
+                                 (documentation nil documentation-supplied)
+                                 (author nil author-supplied)
+                                 (source nil source-supplied)
+                                 (macro nil macro-supplied)
+                                 (weight nil weight-supplied)
+                                 (allowed-in-answer nil allowed-in-answer-supplied)
+                                 (ordering-status nil ordering-status-supplied)
+                                 (constructor nil constructor-supplied)
+                                 (injective nil injective-supplied)
+                                 (skolem-p nil skolem-p-supplied)
+                                 (created-p nil created-p-supplied)
+                                 (kbo-weight nil kbo-weight-supplied)
+                                 (complement nil complement-supplied)
+                                 (magic t magic-supplied)
+                                 (constraint-theory nil constraint-theory-supplied)
+                                 (polarity-map nil polarity-map-supplied)
+                                 (make-compound*-function nil make-compound*-function-supplied)
+                                 (input-code nil input-code-supplied)
+                                 (to-lisp-code nil to-lisp-code-supplied)
+                                 (weight-code nil weight-code-supplied)
+                                 (rewrite-code nil rewrite-code-supplied)
+                                 (equality-rewrite-code nil equality-rewrite-code-supplied)
+                                 (arithmetic-relation-rewrite-code nil arithmetic-relation-rewrite-code-supplied)
+                                 (sort-code nil sort-code-supplied)
+                                 (equal-code nil equal-code-supplied)
+                                 (variant-code nil variant-code-supplied)
+                                 (unify-code nil unify-code-supplied)
+                                 (paramodulate-code nil paramodulate-code-supplied)
+                                 (satisfy-code nil satisfy-code-supplied)
+                                 (falsify-code nil falsify-code-supplied)
+                                 (associative nil associative-supplied)
+                                 (commutative nil commutative-supplied)
+                                 (identity nil identity-supplied)
+                                 (index-type nil index-type-supplied)
+                                 (infix nil infix-supplied)
+                                 (do-not-resolve nil do-not-resolve-supplied)
+                                 (do-not-factor nil do-not-factor-supplied)
+                                 (do-not-paramodulate nil do-not-paramodulate-supplied)
+                                 (keep-head nil keep-head-supplied)
+                                 )
+  (cl:assert (implies satisfy-code-supplied (eq :relation (function-kind symbol))))
+  (cl:assert (implies falsify-code-supplied (eq :relation (function-kind symbol))))
+  (cl:assert (implies constructor-supplied (eq :function (function-kind symbol))))
+  (cl:assert (implies skolem-p-supplied (eq :function (function-kind symbol))))
+  (cl:assert (implies complement-supplied (eq :relation (function-kind symbol))))
+  (cl:assert (implies magic-supplied (eq :relation (function-kind symbol))))
+  (cl:assert (implies polarity-map-supplied (eq :logical-symbol (function-kind symbol))))
+  (cl:assert (implies constraint-theory-supplied (or (eq :function (function-kind symbol)) (eq :relation (function-kind symbol)))))
+  (cl:assert (implies associative-supplied (and (member (function-kind symbol) '(:function :logical-symbol))
+                                                (member (function-arity symbol) '(2 :any)))))
+  (cl:assert (implies identity-supplied (member (function-kind symbol) '(:function :logical-symbol))))
+  (cl:assert (implies (and kbo-weight-supplied (consp kbo-weight)) (eql (function-arity symbol) (length (rest kbo-weight)))))
+  ;; doesn't do anything if no keywords are supplied
+  (when new-name
+    (rename-function-symbol symbol new-name))
+  (when alias
+    (create-aliases-for-symbol symbol alias))
+  (when sort
+    (declare-function-sort symbol sort))
+  (when locked
+    (setf (function-locked symbol) locked))		;once locked, stays locked
+  (set-slot-if-supplied function documentation)
+  (set-slot-if-supplied function author)
+  (set-slot-if-supplied function source)
+  (set-slot-if-supplied function macro)
+  (set-slot-if-supplied function weight)
+  (set-slot-if-supplied function allowed-in-answer)
+  (set-slot-if-supplied function ordering-status)
+  (set-slot-if-supplied function constructor)
+  (cond
+   (injective-supplied
+    (setf (function-injective symbol) injective)
+    (setf (function-injective-supplied symbol) t))
+   ((and constructor (not (function-injective-supplied symbol)))
+    (setf (function-injective symbol) t)))		;declare constructors to be injective unless explicitly declared otherwise
+  (set-slot-if-supplied function skolem-p)
+  (set-slot-if-supplied function created-p)
+  (set-slot-if-supplied function kbo-weight)
+  (set-slot-if-supplied function complement)
+  (set-slot-if-supplied function magic)
+  (set-slot-if-supplied function constraint-theory)
+  (set-slot-if-supplied function polarity-map)
+  (set-slot-if-supplied function make-compound*-function)
+  (set-function-code input-code)			;first non-none result of function call is returned
+  (set-function-code to-lisp-code)			;first non-none result of function call is returned
+  (set-function-code weight-code)			;first non-none result of function call is returned
+  (set-function-code rewrite-code)			;first non-none result of function call is returned
+  (set-function-code equality-rewrite-code)		;first non-none result of function call is returned
+  (set-function-code arithmetic-relation-rewrite-code)	;first non-none result of function call is returned
+  (set-function-code sort-code)				;first non-none result of function call is returned
+  (when associative-supplied
+    (when associative					;can't undeclare it
+      (declare-function-associative symbol)))
+  (when commutative-supplied
+    (when commutative					;can't undeclare it
+      (declare-function-commutative symbol)))
+  (set-function-code equal-code)			;first non-none result of function call is returned
+  (set-function-code variant-code)			;all functions called with continuation
+  (set-function-code unify-code)			;all functions called with continuation
+  (set-function-code paramodulate-code)			;all functions called with continuation
+  (set-function-code satisfy-code)			;all functions called with continuation
+  (set-function-code falsify-code)			;all functions called with continuation
+  (when identity-supplied
+    (unless (eq none identity)
+      (cond
+       ((equal '(function) identity)			;e.g., use (bag-union) as identity for bag-union function
+        (setf identity (make-compound symbol)))
+       (t
+        (setf identity (declare-constant identity))))
+    (setf (function-identity symbol) identity)))
+  (set-slot-if-supplied function index-type)
+  (set-slot-if-supplied function do-not-resolve)
+  (set-slot-if-supplied function do-not-factor)
+  (set-slot-if-supplied function do-not-paramodulate)
+  (set-slot-if-supplied function keep-head)
+  (when (and (function-constructor symbol) (or (function-associative symbol) (function-commutative symbol)))
+    (setf (function-injective symbol) nil))
+  (when (and (neq none (function-identity symbol)) (function-associative symbol))
+    (let ((rewrite-code-supplied t)
+          (paramodulate-code-supplied t)
+          (rewrite-code 'associative-identity-rewriter)
+          (paramodulate-code 'associative-identity-paramodulater))
+      (set-function-code rewrite-code)
+      (set-function-code paramodulate-code)))
+  (cl:assert (implies (consp (function-kbo-weight symbol))
+                      (and (member (function-kbo-status symbol) '(:left-to-right :right-to-left))
+                           (not (function-associative symbol)))))
+  (when infix-supplied
+    (declare-operator-syntax (string (function-name symbol))
+                             (first infix)	;one of :xfx, :xfy, :yfx, :yfy, :fx, :fy, :xf, :yf
+                             (second infix)	;numerical precedence
+                             (function-name symbol)))
+  symbol)
+
+(defun declare-function-symbol1 (symbol keys-and-values)
+  (cond
+   ((null keys-and-values)
+    symbol)
+   (t
+    (apply 'declare-function-symbol0
+           symbol
+           (cond
+            ((and (function-locked symbol) (eq none (getf keys-and-values :locked none)))
+             (changeable-keys-and-values
+              symbol
+              keys-and-values
+              (if (function-logical-symbol-p symbol) '(:alias) (changeable-properties-of-locked-function?))))
+            (t
+             keys-and-values))))))
+
+(defun declare-function (name arity &rest keys-and-values)
+  (declare (dynamic-extent keys-and-values))
+  (declare-function-symbol1 (input-function-symbol name arity) keys-and-values))
+
+(defun declare-relation (name arity &rest keys-and-values)
+  (declare (dynamic-extent keys-and-values))
+  (declare-function-symbol1 (input-relation-symbol name arity) keys-and-values))
+
+(defun declare-logical-symbol (name &rest keys-and-values)
+  (declare-function-symbol1 (input-logical-symbol name t) `(,@keys-and-values :locked t)))
+
+(defun declare-function-associative (function)
+  (setf (function-associative function) t)
+;;(setf (function-input-code function) (cons (lambda (h a p) (require-n-or-more-arguments h a p 2)) (function-input-code function)))
+  (cond
+    ((function-commutative function)
+     (declare-function-symbol0
+      function
+      :ordering-status :ac
+      :equal-code (cons 'ac-equal-p (remove 'commutative-equal-p (function-equal-code function)))
+      :variant-code (cons 'variant-bag (remove 'variant-commute (function-variant-code function)))
+      :unify-code (cons 'ac-unify (remove 'commutative-unify (function-unify-code function)))
+      :index-type nil))
+    (t
+     (declare-function-symbol0
+      function
+;;    :ordering-status :ac
+      :equal-code 'associative-equal-p
+      :variant-code 'variant-vector
+      :unify-code 'associative-unify
+      :index-type nil)))
+;;(check-associative-function-sort function)
+  nil)
+
+(defun declare-function-commutative (function)
+  (setf (function-commutative function) t)
+  (cond
+    ((function-associative function)
+     (declare-function-symbol0
+      function
+      :ordering-status :ac
+      :equal-code (cons 'ac-equal-p (remove 'associative-equal-p (function-equal-code function)))
+      :variant-code (cons 'variant-bag (remove 'variant-vector (function-variant-code function)))
+      :unify-code (cons 'ac-unify (remove 'associative-unify (function-unify-code function)))
+      :index-type nil))
+    (t
+     (declare-function-symbol0
+      function
+      :ordering-status :commutative
+      :equal-code 'commutative-equal-p
+      :variant-code 'variant-commute
+      :unify-code 'commutative-unify
+      :index-type :commute)))
+  nil)
+
+(defun function-code-name (symbol)
+  (or (function-code-name0 symbol)
+      (setf (function-code-name0 symbol) (intern (to-string :code-for- (function-name symbol)) :keyword))))
+
+(defun function-resolve-code (fn v)
+  (cond
+   ((or (eq true v) (eq :neg v))
+    (function-satisfy-code fn))
+   (t
+    (cl:assert (or (eq false v) (eq :pos v)))
+    (function-falsify-code fn))))
+
+(defun declare-function1 (name arity &rest options)
+  (apply 'declare-function name arity
+         `(,@options
+           :locked t)))
+
+(defun declare-function2 (name arity &rest options)
+  (apply 'declare-function name arity
+         `(,@options
+           ;; :unify-code (dont-unify)	;omitted in 20120808r008
+           :do-not-paramodulate t
+           :locked t)))
+
+(defun declare-relation1 (name arity &rest options)
+  (apply 'declare-relation name arity
+         `(:sort nil		;ignore sort declarations
+           ,@options
+           :locked t
+           :magic nil)))
+
+(defun declare-relation2 (name arity &rest options)
+  (apply 'declare-relation name arity
+         `(,@options
+           :do-not-resolve t
+           :do-not-factor t
+           :locked t
+           :magic nil)))
+
+(defun declare-characteristic-relation (name pred sort &rest options)
+  (apply 'declare-relation2 name 1
+         `(,@options
+           :rewrite-code ,(make-characteristic-atom-rewriter pred sort))))
+
+;;; functions.lisp EOF

snark-20120808r02/src/globals.lisp

@@ -0,0 +1,352 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: globals.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defvar *snark-globals*
+  (nconc (mapcar 'first snark-lisp::*clocks*)
+         (mapcar 'second snark-lisp::*clocks*)
+	 '(
+	   snark-lisp::*clocks*
+	   snark-lisp::*excluded-clocks*
+           snark-lisp::*first-real-time-value*
+           snark-lisp::*first-run-time-value*
+	   snark-lisp::*last-run-time-value*
+           snark-lisp::*run-time-mark*
+           snark-lisp::*total-seconds*
+           snark-infix-reader::*infix-operators*
+           snark-infix-reader::*prefix-operators*
+           snark-infix-reader::*postfix-operators*
+           *nonce*
+	   *outputting-comment*
+	   snark-lisp::*running-clocks*
+           snark-feature::*feature-tree*
+           *standard-eql-numbering*
+           
+           *cons*
+           *singleton-bag*
+           *bag-union*
+	   *=*
+	   *not*
+	   *and*
+	   *or*
+	   *implies*
+	   *implied-by*
+	   *iff*
+	   *xor*
+	   *if*
+	   *forall*
+	   *exists*
+	   *answer-if*
+           *date-point*
+           *utime-point*
+           *date-interval*
+           *utime-interval*
+
+           *a-function-with-left-to-right-ordering-status*
+           *a-function-with-multiset-ordering-status*
+	   *agenda*
+	   *agenda-of-backward-simplifiable-rows-to-process*
+	   *agenda-of-false-rows-to-process*
+           *agenda-of-input-rows-to-give*
+	   *agenda-of-input-rows-to-process*
+	   *agenda-of-new-embeddings-to-process*
+           *agenda-of-rows-to-give*
+	   *agenda-of-rows-to-process*
+           *assert-rewrite-polarity*
+	   *assertion-analysis-function-info*
+	   *assertion-analysis-patterns*
+	   *assertion-analysis-relation-info*
+	   *atom-hash-code*
+	   *conditional-answer-connective*
+	   *constant-info-table*
+           *constraint-rows*
+           *current-row-context*
+           *cycl-data*
+           *cycl-read-action-table*
+           *cycl-read-actionn-table*
+           *date-interval-primitive-relations*
+           *date-day-function*
+           *date-hour-function*
+           *date-minute-function*
+           *date-month-function*
+           *date-scenario-constant*
+           *date-second-function*
+           *date-year-function*
+           *date-year-function2*
+           *default-hash-term-set-count-down-to-hashing*
+	   *dp-sort-intersections*
+           *dr-universal-time-function-symbol*
+	   *embedding-variables*
+	   *extended-variant*
+	   *false-rows*
+           *feature-vector-row-index*
+           *feature-vector-term-index*
+	   *find-else-substitution*
+           *finish-time-function-symbol*
+           *form-author*
+           *form-documentation*
+           *form-name*
+           *form-source*
+	   *frozen-variables*
+	   *gensym-variable-alist*
+           *hint-rows*
+           *hints-subsumed*
+           *input-proposition-variables*
+           *input-wff-substitution2*
+           *input-wff-new-antecedents*
+           *less*
+	   *manual-ordering-results*
+           *new-symbol-prefix*
+           *new-symbol-table*
+	   *next-variable-number*
+           *nonce*
+           *number-info-table*
+           *number-of-new-symbols*
+	   *path-index*
+	   *pp-margin*
+	   *pp?*
+           *print-pretty2*
+	   *processing-row*
+           *product*
+           *proof*
+           *propositional-abstraction-of-input-wffs*
+           *propositional-abstraction-term-to-lisp*
+           *reciprocal*
+           *renumber-by-sort*
+           *renumber-first-number*
+           *renumber-ignore-sort*
+	   *rewrite-count-warning*
+	   *rewrites-used*
+           *root-row-context*
+	   *row-count*
+           *row-names*
+           *rowsets*
+	   *rows*
+	   *skolem-function-alist*
+	   *snark-is-running*
+           *string-info-table*
+           *subsuming*
+           *sum*
+           *symbol-ordering*
+	   *symbol-table*
+           *szs-conjecture*
+           *szs-filespec*
+	   *term-by-hash-array*
+	   *term-memory*
+	   *terpri-indent*
+           *trie-index*
+	   *unify-special*
+	   *variables*
+	   *world-path-function-alist*
+	   clause-subsumption
+	   critique-options
+	   it
+           *last-row-number-before-interactive-operation*
+	   map-atoms-first
+	   modal-input-wff
+	   *number-of-agenda-full-deleted-rows*
+	   *number-of-backward-eliminated-rows*
+	   *number-of-given-rows*
+	   *number-of-rows*
+           *%checking-well-sorted-p%*
+           *%check-for-well-sorted-atom%*
+	   options-have-been-critiqued
+	   options-print-mode
+	   ordering-is-total
+	   recursive-unstore
+           *%rewrite-count%*
+	   rewrite-strategy
+	   rewrites-initialized
+           *simplification-ordering-compare-equality-arguments-hash-table* 
+	   subsumption-mark
+           *top-sort*
+           
+           
+	   ;LDPP'
+           dp-tracing
+           dp-tracing-choices
+           dp-tracing-models
+           dp-tracing-state
+           *assignment-count*
+           *default-atom-choice-function*
+           *default-atom-cost-function*
+           *default-branch-limit*
+           *default-convert-to-clauses*
+           *default-cost-bound*
+           *default-cost-bound-function*
+           *default-dependency-check*
+           *default-dimacs-cnf-format*
+           *default-find-all-models*
+           *default-minimal-models-only*
+           *default-minimal-models-suffice*
+           *default-model-test-function*
+           *default-more-units-function*
+           *default-print-summary*
+           *default-print-warnings*
+           *default-pure-literal-check*
+           *default-time-limit*
+	   *default-subsumption*
+           *dp-start-time*
+           *subsumption-show-count*
+           *verbose-lookahead*
+           *verbose-lookahead-show-count*
+           *verbose-subsumption*
+	   )))
+
+(defvar *snark-nonsave-globals*
+	'(
+	  *%assoc-cache-special-item%*
+	  *prog->-function-second-forms*
+	  *prog->-special-forms*
+
+          $number-of-variable-blocks
+          $number-of-variables-per-block
+	  $number-of-variables-in-blocks
+
+          $fv-features-per-symbol
+          $fv-maximum-feature-value
+          $fv-offset-neg-count
+          $fv-offset-neg-max-depth
+          $fv-offset-neg-min-depth
+          $fv-offset-pos-count
+          $fv-offset-pos-max-depth
+          $fv-offset-pos-min-depth
+          $fv-number-ground
+
+	  *all-both-polarity*
+	  *check-for-disallowed-answer*
+          *hash-dollar-package*
+          *hash-dollar-readtable*
+	  *hash-term-not-found-action*
+          *hash-term-only-computes-code*
+          *hash-term-uses-variable-numbers*
+          *input-wff*			;bound only by input-wff
+	  *printing-deleted-messages*
+          *redex-path*			;bound only by rewriter
+	  *resolve-functions-used*
+          *rewriting-row-context*	;bound only for rewriter
+          *rpo-cache*			;bound only by rpo-compare-terms-top
+          *rpo-cache-numbering*		;bound only by rpo-compare-terms-top
+          *ac-rpo-cache*		;bound only by rpo-compare-terms-top
+	  *snark-globals*
+	  *snark-nonsave-globals*
+	  *snark-options*
+          *tptp-environment-variable*
+          *tptp-format*
+          *tptp-input-directory*
+          *tptp-input-directory-has-domain-subdirectories*
+          *tptp-input-file-type*
+          *tptp-output-directory*
+          *tptp-output-directory-has-domain-subdirectories*
+          *tptp-output-file-type*
+
+          rcc8-jepd-relation-names
+          rcc8-more-relation-names
+          time-ip-jepd-relation-names
+          time-pp-jepd-relation-names
+          time-ii-jepd-relation-names
+          time-pi-jepd-relation-names
+          time-ip-more-relation-names
+          time-pp-more-relation-names
+          time-ii-more-relation-names
+          time-pi-more-relation-names
+
+          $rcc8-composition-table *rcc8-composition-table*
+          $time-iii-composition-table *time-iii-composition-table*
+          $time-iip-composition-table
+          $time-ipi-composition-table *time-ipi-composition-table*
+          $time-ipp-composition-table
+          $time-pii-composition-table *time-pii-composition-table*
+          $time-pip-composition-table *time-pip-composition-table*
+          $time-ppi-composition-table *time-ppi-composition-table*
+          $time-ppp-composition-table *time-ppp-composition-table*
+          $rcc8-relation-code
+          $time-ii-relation-code
+          $time-ip-relation-code
+          $time-pi-relation-code
+          $time-pp-relation-code
+
+          dp-prover
+          dp-version
+	  false
+	  float-internal-time-units-per-second
+	  initialization-functions
+          none
+	  true
+	  ))
+
+;;; more than one copy of SNARK can be run alternately
+;;; by using SUSPEND-SNARK and RESUME-SNARK
+;;;
+;;; SUSPEND-SNARK re-initializes SNARK so the run can be continued
+;;; only after RESUME-SNARK; a suspended SNARK can only be resumed once
+;;;
+;;; SUSPEND-SNARK saves the values of SNARK's global variables;
+;;; RESUME-SNARK restores them
+;;;
+;;; SUSPEND-AND-RESUME-SNARK suspends the current SNARK and resumes
+;;; another without unnecessarily re-initializing
+
+(defun suspend-snark* ()
+  (let ((state (gensym)))
+    (setf (symbol-value state)
+	  (mapcar (lambda (var)
+                    (cons var
+                          (if (boundp var)
+                              (symbol-value var)
+                              '%unbound%)))
+		  *snark-globals*))
+    state))
+
+(defun resume-snark (state)
+  (let ((l (and (boundp state) (symbol-value state))))
+    (cond
+      ((consp l)
+       (setf (symbol-value state) nil)
+       (mapc (lambda (x)
+               (if (eq '%unbound% (cdr x))
+                   (makunbound (car x))
+                   (setf (symbol-value (car x)) (cdr x))))
+	     l))
+      (t
+       (error "Cannot resume SNARK from state ~S." state)))
+    nil))
+
+(defun suspend-snark ()
+  (prog1
+    (suspend-snark*)
+    (initialize)))
+
+(defun suspend-and-resume-snark (state)
+  (prog1
+    (suspend-snark*)
+    (resume-snark state)))
+
+(defun audit-snark-globals ()
+  ;; used for suspend/resume to make sure all necessary values are saved;
+  ;; prints names of symbols that might have been overlooked
+  (dolist (package-name '(:snark-lisp :snark))
+    (let ((package (find-package package-name)))
+      (do-symbols (x package)
+	(when (and (boundp x) (eq package (symbol-package x)))
+	  (unless (or (member x *snark-globals*) (member x *snark-nonsave-globals*))
+	    (print x)))))))
+
+;;; globals.lisp EOF

snark-20120808r02/src/infix-operators.lisp

@@ -0,0 +1,105 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-infix-reader -*-
+;;; File: infix-operators.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark-infix-reader)
+
+(defvar *infix-operators* nil)
+(defvar *prefix-operators* nil)
+(defvar *postfix-operators* nil)
+
+(defparameter infix-types '(:xfx :xfy :yfx :yfy))
+(defparameter prefix-types '(:fx :fy))
+(defparameter postfix-types '(:xf :yf))
+
+(defstruct (operator
+            (:copier nil))
+  (input-string nil :read-only t)
+  (type nil :read-only t)
+  (precedence nil :read-only t)
+  (output-symbol nil :read-only t))
+
+(definline infix-operator-p (op)
+  (and (operator-p op) (member (operator-type op) infix-types)))
+
+(definline prefix-operator-p (op)
+  (and (operator-p op) (member (operator-type op) prefix-types)))
+
+(definline postfix-operator-p (op)
+  (and *postfix-operators* (operator-p op) (member (operator-type op) postfix-types)))
+
+(defun initialize-operator-syntax ()
+  (setf *infix-operators* nil)
+  (setf *prefix-operators* nil)
+  (setf *postfix-operators* nil))
+
+(definline operator-lookup0 (input-string list)
+  (dolist (op list nil)
+    (when (string= input-string (operator-input-string op))
+      (return op))))
+
+(definline infix-operator-lookup (input-string)
+  (operator-lookup0 input-string *infix-operators*))
+
+(definline prefix-operator-lookup (input-string)
+  (operator-lookup0 input-string *prefix-operators*))
+
+(definline postfix-operator-lookup (input-string)
+  (operator-lookup0 input-string *postfix-operators*))
+
+(defun update-operator-syntax (input-string op listname)
+  (let ((l (remove input-string (symbol-value listname) :key #'operator-input-string :test #'string=)))
+    (setf (symbol-value listname) (if op (cons op l) l))))
+
+(defun declare-operator-syntax (input-string type &optional (precedence nil precedence-supplied) (output-symbol input-string))
+  ;; (declare-operator-syntax "<=>" :xfy 505) declares <=> as a type xfy operator with precedence 505
+  ;; (declare-operator-syntax "<=>" :xfy nil) undeclares <=> as a type xfy operator
+  ;; (declare-operator-syntax "<=>" nil) undeclares <=> as any kind of operator
+  (if (null type)
+      (cl:assert (null precedence))
+      (progn
+        (cl:assert (or (member type infix-types) (member type prefix-types) (member type postfix-types)))
+        (cl:assert precedence-supplied)
+        (cl:assert (implies precedence (integerp precedence)))))
+  (unless (stringp input-string)
+    (setf input-string (string input-string)))
+  (unless (implies (and type precedence) (symbolp output-symbol))
+    (setf output-symbol (intern (string output-symbol))))
+  (let ((op (and type precedence (make-operator :input-string input-string :type type :precedence precedence :output-symbol output-symbol))))
+    (cond
+     ((member type infix-types)
+      (update-operator-syntax input-string op '*infix-operators*))
+     ((member type prefix-types)
+      (update-operator-syntax input-string op '*prefix-operators*))
+     ((member type postfix-types)
+      (update-operator-syntax input-string op '*postfix-operators*))
+     (t
+      (update-operator-syntax input-string op '*infix-operators*)
+      (update-operator-syntax input-string op '*prefix-operators*)
+      (update-operator-syntax input-string op '*postfix-operators*)))
+    op))
+
+(definline reduce-before? (op1 op2)
+  (let ((p1 (operator-precedence op1))
+        (p2 (operator-precedence op2)))
+    (or (< p1 p2)
+        (and (eql p1 p2)
+             (member (operator-type op2) '(:yfx :yfy :yf))
+             (member (operator-type op1) '(:xfx :yfx :fx))))))
+
+;;; infix-operators.lisp EOF

snark-20120808r02/src/infix-reader-system.lisp

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

snark-20120808r02/src/infix-reader.lisp

@@ -0,0 +1,441 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-infix-reader -*-
+;;; File: infix-reader.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark-infix-reader)
+
+;;; no operator should be declared to be both infix and postfix
+;;; to ease parsing as in ISO Prolog standard
+
+;;; <identifier> = <ordinary-char>+ (but first character cannot be a digit)
+;;; <number> = [<sign>] <digit>+ <decimal-point> <digit>+ for floats 
+;;;            [<sign>] <digit>+ <forward-slash> <digit>+ for ratios
+;;;            [<sign>] <digit>+                          for integers
+
+(definline ordinary-char-p (char)
+  (or (alpha-char-p char)
+      (digit-char-p char)
+      (eql #\_ char)
+      (eql #\? char)					;for SNARK variables
+      (eql #\$ char)))					;for builtins
+
+(definline separator-char-p (char)
+  (or (eql #\, char)					;comma is not an operator
+      (eql #\( char)
+      (eql #\) char)
+      (eql #\[ char)
+      (eql #\] char)
+      (eql #\. char)))					;dot is not an operator
+
+(definline whitespace-char-p (char)
+  (or (eql #\space char)
+      (eql #\tab char)
+      (eql #\newline char)
+      (eql #\return char)
+      (eql #\linefeed char)
+      (eql #\page char)))
+
+(definline quotation-char-p (char)
+  (or (eql #\" char)
+      (eql #\' char)))
+
+(definline comment-char-p (char)
+  (eql #\% char))
+
+(defun tokenize1 (stream &key (case :preserve) (upper-case-var-prefix #\?) rationalize)
+  (labels
+    ((tokenize-identifier (ch)
+       (let ((chars (list ch)))
+         (loop
+           (cond
+            ((eq :eof (setf ch (read-char stream nil :eof)))
+             (return))
+            ((ordinary-char-p ch)
+             (push ch chars))
+            (t
+             (unread-char ch stream)
+             (return))))
+         (setf chars (nreverse chars))
+         ;; so that variables can be distingished from nonvariables even after upcasing
+         ;; if upper-case-var-prefix is a character such as #\?
+         ;; tokenize adds it to the front of each identifier that starts with
+         ;; either an upper-case character
+         ;; or one or more of it followed by an alphabetic character
+         ;; (read-infix-term "r(x,?,?1,X,?X,??X)") -> (R X ? ?1 ?X ??X ???X)
+         (when (and upper-case-var-prefix
+                    (or (upper-case-p (first chars))
+                        (and (eql upper-case-var-prefix (first chars))
+                             (dolist (c (rest chars) nil)
+                               (cond
+                                ((alpha-char-p c)
+                                 (return t))
+                                ((not (eql upper-case-var-prefix c))
+                                 (return nil)))))))
+           (setf chars (cons upper-case-var-prefix chars)))
+         (operator-lookup
+          (ecase (if (and (eql #\$ (first chars)) (rest chars) (eql #\$ (second chars)))
+                     (readtable-case *readtable*)	; use Lisp reader case for $$ words so that $$sum is read as $$SUM if reader upcases
+                     case)
+            (:preserve (coerce chars 'string))
+            (:invert (if (iff (some #'upper-case-p chars) (some #'lower-case-p chars)) (coerce chars 'string) (map 'string #'char-invert-case chars)))
+            (:upcase (if (notany #'lower-case-p chars) (coerce chars 'string) (map 'string #'char-upcase chars)))
+            (:downcase (if (notany #'upper-case-p chars) (coerce chars 'string) (map 'string #'char-downcase chars)))))))
+     (tokenize-special (ch)
+       (let ((chars (list ch)))
+         (loop
+           (cond
+            ((eq :eof (setf ch (read-char stream nil :eof)))
+             (return))
+            ((and (not (ordinary-char-p ch))
+                  (not (separator-char-p ch))
+                  (not (whitespace-char-p ch))
+                  (not (quotation-char-p ch))
+                  (not (comment-char-p ch)))
+             (push ch chars))
+            (t
+             (unread-char ch stream)
+             (return))))
+         (operator-lookup (coerce (nreverse chars) 'string))))
+     (tokenize-number (ch)
+       (let ((num (digit-char-p ch)) (n 0) (d 1) cv float ratio (exponent nil))
+         (loop
+           (cond
+            ((eq :eof (setf ch (read-char stream nil :eof)))
+             (return))
+            ((setf cv (digit-char-p ch))
+             (cond
+              (float
+               (setf n (+ (* 10 n) cv) d (* 10 d)))
+              (ratio
+               (setf n (+ (* 10 n) cv)))
+              (t
+               (setf num (+ (* 10 num) cv)))))
+            ((and (not (or float ratio)) (eql #\. ch))
+             (setf float t))
+            ((and (not (or float ratio)) (eql #\/ ch))
+             (setf ratio t))
+            ((and (not ratio) (or (eql #\E ch) (eql #\e ch)))
+             (setf exponent (tokenize-exponent))
+             (return))
+            (t
+             (unread-char ch stream)
+             (return))))
+         (cond
+          (float
+           (setf num (+ num (/ n d))))
+          (ratio
+           (setf num (/ num n))))
+         (when exponent
+           (setf num (* num (expt 10 exponent))))
+         (when (and float (not rationalize))
+           (setf num (float num)))
+         num))
+     (tokenize-exponent ()
+       (let ((negative nil) (exponent 0) ch cv)
+         (cond
+          ((eq :eof (setf ch (read-char stream nil :eof)))
+           (return-from tokenize-exponent nil))
+          ((setf cv (digit-char-p ch))
+           (setf exponent cv))
+          ((eql #\- ch)
+           (setf negative t))
+          ((eql #\+ ch)
+           )
+          (t
+           (unread-char ch stream)
+           (return-from tokenize-exponent nil)))
+         (loop
+           (cond
+            ((eq :eof (setf ch (read-char stream nil :eof)))
+             (return))
+            ((setf cv (digit-char-p ch))
+             (setf exponent (+ (* 10 exponent) cv)))
+            (t
+             (unread-char ch stream)
+             (return))))
+         (if negative (- exponent) exponent)))
+     (tokenize-string (quotechar)
+       (let ((chars nil) ch)
+         (loop
+           (cond
+            ((eql quotechar (setf ch (read-char stream t)))
+             (setf chars (nreverse chars))
+             (return (ecase quotechar
+                       (#\"
+                        (coerce chars 'string))
+                       (#\'
+                        ;; any characters can be put into a symbol by using '...' quotation
+                        ;; this suppresses default case mangling, var-prefixing, and operator lookup
+                        ;; to disambiguate tokenization of ? and '?' etc.
+                        ;; '?...'  is tokenized as |^A?...| that is later replaced by ($$quote ?...)
+                        (cond
+                         ((and chars 
+                               (or (eql upper-case-var-prefix (first chars))
+                                   (eql (code-char 1) (first chars))))
+                          (make-symbol (coerce (cons (code-char 1) chars) 'string)))
+                         (t
+                          (intern (coerce chars 'string))))))))
+            ((eql #\\ ch)
+             (push (read-char stream t) chars))
+            (t
+             (push ch chars))))))
+     (operator-lookup (name)
+       ;; return an operator interpretation if there is one
+       ;; we can lookup the correct interpretation later
+       (or (infix-operator-lookup name)
+           (prefix-operator-lookup name)
+           (postfix-operator-lookup name)
+           (intern name))))
+    (let (ch)
+      (loop
+        (cond
+         ((eq :eof (setf ch (read-char stream nil :eof)))
+          (return-from tokenize1 none))
+         ((whitespace-char-p ch)
+          )
+         ((comment-char-p ch)
+          ;; comment from comment-char through end of line
+          (loop
+            (when (or (eql #\newline (setf ch (read-char stream t))) (eql #\return ch) (eql #\linefeed ch))
+              (return))))
+         ((and (eql #\/ ch) (eql #\* (peek-char nil stream nil :eof)))
+          ;; comment from /* through */
+          (read-char stream)
+          (loop
+            (when (eql #\* (read-char stream t))
+              (if (eql #\/ (setf ch (read-char stream t)))
+                  (return)
+                  (when (eql #\* ch)
+                    (unread-char ch stream))))))
+         ((separator-char-p ch)
+          (return ch))
+         ((digit-char-p ch)
+          (return (tokenize-number ch)))
+         ((ordinary-char-p ch)
+          (return (tokenize-identifier ch)))
+         ((quotation-char-p ch)
+          (return (tokenize-string ch)))
+         ((or (eql #\- ch) (eql #\+ ch))
+          (return (if (digit-char-p (peek-char nil stream nil #\a))
+                      (let ((v (tokenize-number (read-char stream))))
+                        (if (eql #\- ch) (- v) v))
+                      (tokenize-special ch))))
+         (t
+          (return (tokenize-special ch))))))))
+
+(defun tokenize (stream &key (case :preserve) (upper-case-var-prefix #\?) rationalize)
+  (let ((tokens nil))
+    (loop
+      (let ((token (tokenize1 stream :case case :upper-case-var-prefix upper-case-var-prefix :rationalize rationalize)))
+        (if (eq none token)
+            (return)
+            (push token tokens))))
+    (nreverse tokens)))
+
+;;; converts "p(a,b,c)" to (p a b c)
+;;; converts "[a,b,c]" to ($$list a b c)
+;;; converts "[a,b|c]" to ($$list* a b c)
+
+(defun tokens-to-lisp (tokens)
+  (let ((stack '(#\.))					;stack contains terms, operators, #\(s, #\.
+        token1)
+    (labels
+      ((tokens-to-lisp1 ()
+         (cond
+          ((or (eql #\( token1) (numberp token1) (stringp token1))
+           (cond
+            ((starting-term)
+             (push token1 stack))
+            (t
+             (syntax-error 1))))
+          ((symbolp token1)
+           (cond
+            ((starting-term)
+             (push (if (eql #\( (first tokens))
+                       (progn
+                         (setf tokens (rest tokens))
+                         (cons token1 (tokens-to-lisp2 '(#\)))))
+                       token1)
+                   stack))
+            (t
+             (syntax-error 2))))
+          ((eql #\[ token1)
+           (cond
+            ((starting-term)
+             (push (tokens-to-lisp2 '(#\])) stack))
+            (t
+             (syntax-error 3))))
+          ((eql #\) token1)
+           (cond
+            ((not (starting-term))
+             (reduce-all #\())
+            (t
+             (syntax-error 4))))
+          ((operator-p token1)
+           ;; is it the right kind of operator?
+           ;; if not, just use it as a symbol
+           (setf token1 (operator-input-string token1))
+           (cond
+            ((starting-term)
+             (cond
+              ((operator-p (setf token1 (or (prefix-operator-lookup token1) (intern token1))))
+               (push token1 stack))
+              (t
+               (tokens-to-lisp1))))
+            (t
+             (cond
+              ((operator-p (setf token1 (or (infix-operator-lookup token1) (postfix-operator-lookup token1) (intern token1))))
+               (reduce-before token1)
+               (push token1 stack))
+              (t
+               (tokens-to-lisp1))))))
+          (t
+           (syntax-error 5))))
+       (tokens-to-lisp2 (brackets)
+         ;; convert lists and argument lists
+         (let ((list* nil)
+               (args nil)
+               (l nil))
+           (loop
+             (cond
+              ((or (null tokens) (eql #\. (setf token1 (pop tokens))))
+               (syntax-error 6))
+              ((eql #\( token1)
+               (push #\) brackets)
+               (push token1 l))
+              ((eql #\[ token1)
+               (push #\] brackets)
+               (push token1 l))
+              ((or (eql #\) token1) (eql #\] token1))
+               (cond
+                ((not (eql token1 (pop brackets)))
+                 (syntax-error 7))
+                ((null brackets)
+                 (cond
+                  ((null l)
+                   (when args
+                     (syntax-error 8)))
+                  (t
+                   (push (tokens-to-lisp (nreverse l)) args)))
+                 (setf args (nreverse args))
+                 (return (if (eql #\] token1) (cons (if list* '$$list* '$$list) args) args)))
+                (t
+                 (push token1 l))))
+              ((and (null (rest brackets))
+                    (eql #\] (first brackets))
+                    ;; treat vertical bar as a separator only in lists
+                    (cond
+                     ((symbolp token1)
+                      (when (string= "|" (symbol-name token1))
+                        (setf token1 #\|))
+                      nil)
+                     ((operator-p token1)
+                      (when (string= "|" (operator-input-string token1))
+                        (setf token1 #\|))
+                      nil)
+                     (t
+                      nil)))
+               )
+              ((and (null (rest brackets)) (or (eql #\, token1) (and (eq #\| token1) (eql #\] (first brackets)))))
+               (cond
+                ((null l)
+                 (syntax-error 9))
+                (list*
+                 (syntax-error 10))
+                (t
+                 (push (tokens-to-lisp (nreverse l)) args)))
+               (setf l nil)
+               (setf list* (eq #\| token1)))
+              (t
+               (push token1 l))))))
+       (reduce-once ()
+         (let ((x (pop stack)) (y (pop stack)) z)
+           (cond
+            ((infix-operator-p y)
+             (if (and (operand-p (setf z (pop stack))) (operand-p x))
+                 (push (list (operator-output-symbol y) z x) stack)
+                 (syntax-error 11)))
+            ((prefix-operator-p y)
+             (if (operand-p x)
+                 (push (list (operator-output-symbol y) x) stack)
+                 (syntax-error 12)))
+            ((postfix-operator-p x)
+             (if (operand-p y)
+                 (push (list (operator-output-symbol x) y) stack)
+                 (syntax-error 13)))
+            (t
+             (syntax-error 14)))))
+       (reduce-before (op)
+         (loop
+           (if (cond
+                ((operator-p (first stack))
+                 (reduce-before? (first stack) op))
+                ((operator-p (second stack))
+                 (reduce-before? (second stack) op))
+                (t
+                 nil))
+               (reduce-once)
+               (return))))
+       (reduce-all (start)
+         (loop
+           (cond
+            ((and (operand-p (first stack)) (eql start (second stack)))
+             (setf stack (cons (first stack) (rrest stack)))
+             (return))
+            (t
+             (reduce-once)))))
+       (starting-term ()
+         (let ((top (first stack)))
+           (not (or (operand-p top) (postfix-operator-p top)))))
+       (operand-p (x)
+         (not (or (eql #\( x) (eql #\. x) (operator-p x))))
+       (syntax-error (name)
+         (error "Syntax error ~A at or before~{ ~S~}~% token1 = ~S~% stack =~{ ~S~}" name (firstn tokens 20) token1 stack)))
+      (loop
+        (cond
+         ((or (null tokens) (eql #\. (setf token1 (pop tokens))))
+          (reduce-all #\.)
+          (return))
+         (t
+          (tokens-to-lisp1))))
+      (values (if (null (rest stack)) (first stack) stack) tokens))))
+
+(defun read-infix-term (x &key (case :preserve) (upper-case-var-prefix #\?) rationalize)
+  ;; read one term from x and return it and list of leftover tokens
+  ;; if x is a string, tokenize it
+  ;; if x is a list, assume it is a tokenized string (with correct case and upper-case-var-prefix)
+  (when (stringp x)
+    (with-input-from-string (stream x)
+      (setf x (tokenize stream :case case :upper-case-var-prefix upper-case-var-prefix :rationalize rationalize))))
+  (cl:assert (consp x))
+  (tokens-to-lisp x))
+
+(defun read-infix-terms (x &key (case :preserve) (upper-case-var-prefix #\?) rationalize)
+  (when (string x)
+    (with-input-from-string (stream x)
+      (setf x (tokenize stream :case case :upper-case-var-prefix upper-case-var-prefix :rationalize rationalize))))
+  (let ((terms nil) terms-last term)
+    (loop
+      (cond
+       ((null x)
+        (return terms))
+       (t
+        (setf (values term x) (tokens-to-lisp x))
+        (collect term terms))))))
+
+;;; infix-reader.lisp EOF

snark-20120808r02/src/input.lisp

@@ -0,0 +1,984 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: input.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defvar *skolem-function-alist* nil)
+(defvar *input-wff* nil)
+(defvar *input-wff-substitution*)		;alist of (variable-name . variable) or (variable-name . skolem-term) pairs
+(defvar *input-wff-substitution2*)
+(defvar *input-wff-new-antecedents*)
+(defvar *input-wff-modal-prefix*)
+(defvar *input-proposition-variables* nil)	;for cnf and boolean ring rewrites
+
+(defun keyword-argument-list-p (x)
+  (or (null x)
+      (and (consp x)
+	   (keywordp (first x))
+	   (consp (rest x))
+	   (keyword-argument-list-p (rrest x)))))
+
+(defun can-be-name1 (x &optional ?ok)
+  (and (symbolp x)
+       (not (null x))
+       (neq none x)
+       (neq true x)
+       (neq false x)
+       (let ((s (symbol-name x)))
+         (and (<= 1 (length s))
+              (if ?ok t (not (variable-symbol-prefixed-p s)))))))
+
+(defun can-be-free-variable-name (x &optional action)
+  ;; a free variable in an input formula is represented
+  ;; by a symbol that starts with a variable-symbol-prefix
+  (or (and (can-be-name1 x t)
+           (variable-symbol-prefixed-p x))
+      (and action (funcall action "~S cannot be the name of a free variable." x))))
+
+(defun can-be-variable-name (x &optional action)
+  ;; a bound variable is represented like a free variable, or by an ordinary symbol
+  (or (can-be-name1 x t)
+      (and action (funcall action "~S cannot be the name of a variable." x))))
+
+(defun can-be-constant-name (x &optional action)
+  (or (can-be-name1 x)
+      (null x)
+      (builtin-constant-p x)
+      (and (symbolp x) (= 0 (length (symbol-name x))))
+      (and action (funcall action "~S cannot be the name of a constant." x))))
+
+(defun can-be-constant-alias (x &optional action)
+  (or (can-be-name1 x)
+      (and (symbolp x) (= 0 (length (symbol-name x))))
+      (and action (funcall action "~S cannot be the alias of a constant." x))))
+
+(defun can-be-proposition-name (x &optional action)
+  (or (or (eq true x)					;allow internal true and false values in input
+          (eq false x)			
+          (can-be-name1 x))
+      (and action (funcall action "~S cannot be the name of a proposition." x))))
+                    
+(defun can-be-function-name (x &optional action)
+  (or (can-be-name1 x)
+      (and action (funcall action "~S cannot be the name of a function." x))))
+
+(defun can-be-relation-name (x &optional action)
+  (or (and (can-be-name1 x)
+           (neq '$$quote x))
+      (and action (funcall action "~S cannot be the name of a relation." x))))
+
+(defun can-be-logical-symbol-name (x &optional action)
+  (or (can-be-name1 x)
+      (and action (funcall action "~S cannot be the name of a logical symbol." x))))
+
+(defun can-be-sort-name (x &optional action)
+  ;; disallow names with "&" to avoid confusion with SNARK created sorts
+  ;; disallow names with variable-sort-marker that is used to mark sorts in variable names
+  (or (top-sort-name? x)
+      (and (can-be-name1 x)
+           (not (eq 'and x))
+           (not (eq 'or x))
+           (not (eq 'not x))
+           (let ((s (symbol-name x)))
+             (and (not (find (variable-sort-marker?) s))
+                  (or (null (symbol-package x)) (not (find #\& s))))))
+      (and action (funcall action "~S cannot be the name of a sort." x))))
+
+(defun can-be-row-name (x &optional action)
+  (or (can-be-name1 x)
+      (and action (funcall action "~S cannot be the name of a row." x))))
+
+(defun can-be-constant-or-function-name (x &optional action)
+  (or (can-be-constant-name x)
+      (can-be-function-name x)
+      (and action (funcall action "~S cannot be the name of a constant or function." x))))
+
+(defun check-usable-head1 (head)
+  ;; some operations cannot deal with function/relation symbols
+  ;; with special input handling
+  (when (function-input-code head)
+    (with-standard-io-syntax2
+      (error "~S cannot be used as a ~A here." (function-name head) (function-kind head))))
+  head)
+
+(defun cerror1 (datum &rest args)
+  (apply #'cerror "Input it anyway, but this may result in additional errors." datum args))
+
+(defun cerror2 (datum &rest args)
+  (apply #'cerror "Ignore this sort declaration, but this may result in additional errors." datum args))
+
+(defun variable-symbol-prefixed-p (x &optional (prefixes (variable-symbol-prefixes?)))
+  ;; check whether symbol or string x begins with variable prefixes (like ?, _, @, or "...")
+  ;; if so, return the number of characters in the prefix
+  ;; otherwise return nil
+  (let* ((s (string x))
+         (len (length s))
+         (pos 0))
+    (loop
+      (dolist (prefix prefixes (return-from variable-symbol-prefixed-p (and (/= 0 pos) pos)))
+        (cond
+         ((characterp prefix)
+          (when (and (> len pos) (eql prefix (char s pos)))
+            (setf pos (+ pos 1))
+            (return)))
+         (t
+          (let* ((prefix (string prefix))
+                 (plen (length prefix)))
+            (when (and (>= len (+ pos plen)) (string= prefix s :start2 pos :end2 (+ pos plen)))
+              (setf pos (+ pos plen))
+              (return)))))))))
+
+(defun unsortable-variable-name (name)
+  ;; SNARK output uses ?, ?X, ?Y, ?Z, ?U, ?V, ?W, ?X1, ?Y1, ?Z1, ?U1, ?V1, ?W1, ...
+  ;; as unsorted variables; to enable SNARK to faithfully input its own output,
+  ;; don't allow these variables to be declared with a sort
+  (let* ((s (symbol-name name))
+         (v (variable-symbol-prefixed-p s (list (first (variable-symbol-prefixes?))))))
+    (and v
+         (let ((len (length s)))
+           (or (eql len v)
+               (and (member (char s v) '(#\X #\Y #\Z #\U #\V #\W #\x #\y #\z #\u #\v #\w))
+                    (or (eql (+ 1 v) len)
+                        (null (position-if-not #'digit-char-p s :start (+ 1 v))))))))))
+
+(defun sort-from-variable-name (name)
+  ;; ?name.sort is the preferred way to input sorted variables
+  ;; ?sort<digit>* works too with deprecated use-variable-name-sorts option (but not for sort names that end in digits or sorts named x,y,z,u,v,w)
+  (let* ((s (symbol-name name))
+         (p (position (variable-sort-marker?) s :from-end t)))
+    (cond
+     (p						;interpret variable names that end with #sort like ?i2#integer
+      (the-sort (intern (subseq s (+ p 1)) :snark-user)))
+     ((use-variable-name-sorts?)		;old style try to interpret as a sort the substring between ?* at start and digit* at end
+      (let ((m (or (variable-symbol-prefixed-p s) 0))
+            (n (position-if-not #'digit-char-p s :from-end t)))
+        (cond
+         ((> m n)
+          none)
+         ((and (= m n) (< 0 m) (member (char s m) '(#\X #\Y #\Z #\U #\V #\W #\x #\y #\z #\u #\v #\w)))
+          none)
+         (t
+          (mvlet (((values sym found) (find-symbol (subseq s m (+ n 1)) :snark-user)))
+            (if found (find-symbol-table-entry sym :sort) none))))))
+     (t
+      none))))
+
+(defun declare-variable (name &key (sort (top-sort-name) sort-supplied-p))
+  ;; return same variable every time for same input free variable
+  (can-be-variable-name name 'error)
+  (setf sort (the-sort sort))
+  (let* ((v (find-or-create-symbol-table-entry name :variable))
+         (vsort (variable-sort v)))
+    (when (eq none (variable-sort v))		;new variable
+      (unless (eq none (setf vsort (sort-from-variable-name name)))
+        (setf (variable-sort v) vsort)))
+    (cond
+     ((eq none vsort)
+      (cl:assert (not (and (not (top-sort? sort)) (unsortable-variable-name name)))
+                 ()
+                 "Cannot declare ~A as variable of sort ~A; ~A is unsorted."
+                 name (sort-name sort) name)
+      (setf (variable-sort v) sort))
+     (sort-supplied-p
+      (cl:assert (same-sort? sort vsort) ()
+                 "Cannot declare ~A as variable of sort ~A; ~A is of sort ~A."
+                 name (sort-name sort) name (sort-name vsort))))
+    v))
+
+;;; Convert Lisp S-expression for formula into correct internal form for theorem prover
+;;; Also eliminate quantifiers and modal operators
+
+;;; after input-wff, *input-wff-substitution2* contains the substitutions for all
+;;; bound variables in the wff; it will be misleading if bound variable names are
+;;; repeated or if variable names occur unbound as constants
+
+(defun input-wff (wff &key (polarity :pos) (clausify nil) (*input-wff-substitution* nil))
+  (when (stringp wff)
+    (setf wff (read-tptp-term wff :case (readtable-case *readtable*))))
+  (let ((*input-wff* wff)
+        (*input-wff-substitution2* nil)
+        (*input-wff-new-antecedents* true)
+	(*input-wff-modal-prefix* nil))
+    (let ((usr (use-sort-relativization?)))
+      (when usr
+	(let ((l nil))
+	  (dolist (x (input-variables-in-form wff nil nil))
+            (when (variable-p (cdr x))
+	      (let ((sort (variable-sort (cdr x))))
+                (unless (top-sort? sort)
+		  (push `(,(sort-name sort) ,(car x)) l)))))
+	  (when l
+	    (setf wff (list 'implies
+			    (if (null (rest l))
+				(first l)
+				(cons 'and (nreverse l)))
+			    wff))))))
+    (let ((wff* (input-wff1 wff polarity)))
+      (unless (eq true *input-wff-new-antecedents*)
+        (setf wff* (make-implication *input-wff-new-antecedents* wff*)))
+      (when clausify
+        (setf wff* (clausify wff*)))
+      (values wff* nil *input-wff* *input-wff-substitution2*))))
+
+(defun input-wff1 (wff polarity)
+  (when (stringp wff)
+    (setf wff (read-tptp-term wff :case (readtable-case *readtable*))))
+  (cond
+   ((atom wff)
+    (input-atom wff polarity))
+   (t
+    (let ((head (input-logical-symbol (first wff))))
+      (if (neq none head)
+          (dolist (fun (function-input-code head) (make-compound* head (input-wffs1 head (rest wff) polarity)))
+            (let ((v (funcall fun head (rest wff) polarity)))
+              (unless (eq none v)
+                (return v))))
+          (input-atom wff polarity))))))
+
+(defun input-wffs1 (head args polarity)
+  (input-wffs2 args polarity (function-polarity-map head)))
+
+(defun input-wffs2 (wffs polarity polarity-map)
+  (lcons (input-wff1 (first wffs) (map-polarity (first polarity-map) polarity))
+	 (input-wffs2 (rest wffs) polarity (rest polarity-map))
+	 wffs))
+
+(defun input-quoted-constant (head args polarity)
+  (require-n-arguments head args polarity 1)
+  (input-constant-symbol (cons '$$quote args)))
+
+(defun input-equality (head args polarity)
+  ;; see related code in input-function-as-relation
+  (require-n-arguments head args polarity 2)
+  (let (fn)
+    (cond
+     ((and (consp (first args))
+           (member 'input-function-as-relation
+                   (function-input-code (setf fn (input-function-symbol (first (first args)) (length (rest (first args))))))))
+      (input-atom `(,(function-name fn) ,@(rest (first args)) ,(second args)) polarity))
+     ((and (consp (second args))
+           (member 'input-function-as-relation
+                   (function-input-code (setf fn (input-function-symbol (first (second args)) (length (rest (second args))))))))
+      (input-atom `(,(function-name fn) ,@(rest (second args)) ,(first args)) polarity))
+     (t
+      (input-form* head args polarity)))))
+
+(defun input-disequality (head args polarity)
+  (declare (ignore head))
+  (make-compound *not* (input-equality *=* args (opposite-polarity polarity))))
+
+(defun input-negation (head args polarity)
+  (if (and (test-option6?) (use-clausification?))
+      (negate0 (input-wffs1 head args polarity))
+      (negate* (input-wffs1 head args polarity))))
+
+(defun input-conjunction (head args polarity)
+  (conjoin* (input-wffs1 head args polarity)))
+
+(defun input-disjunction (head args polarity)
+  (disjoin* (input-wffs1 head args polarity)))
+
+(defun input-implication (head args polarity)
+  (if (eql 2 (length args))
+      (make-implication* (input-wffs1 head args polarity))
+      (input-kif-forward-implication head args polarity t)))
+
+(defun input-reverse-implication (head args polarity)
+  (if (eql 2 (length args))
+      (make-reverse-implication* (input-wffs1 head args polarity))
+      (input-kif-backward-implication head args polarity t)))
+
+(defun input-kif-forward-implication (head args polarity &optional rep)
+  (require-n-or-more-arguments head args polarity 1)
+  (when rep
+    (report-not-2-arguments-implication head args))
+  (input-wff1
+   (cond
+    ((null (rest args))
+     (first args))
+    ((null (rrest args))
+     `(implies ,(first args) ,(second args)))
+    (t
+     `(implies (and ,@(butlast args)) ,(first (last args)))))
+   polarity))
+
+(defun input-kif-backward-implication (head args polarity &optional rep)
+  (require-n-or-more-arguments head args polarity 1)
+  (when rep
+    (report-not-2-arguments-implication head args))
+  (input-wff1
+   (cond
+    ((null (rest args))
+     (first args))
+    ((null (rrest args))
+     `(implied-by ,(first args) ,(second args)))
+    (t
+     `(implied-by ,(first args) (and ,@(rest args)))))
+   polarity))
+
+(defun input-nand (head args polarity)
+  (declare (ignore head))
+  (input-wff1 `(not (and ,@args)) polarity))
+
+(defun input-nor (head args polarity)
+  (declare (ignore head))
+  (input-wff1 `(not (or ,@args)) polarity))
+
+(defun input-lisp-list (head args polarity)
+  (declare (ignore head))
+  (input-terms args polarity))
+
+(defun input-lisp-list* (head args polarity)
+  (require-n-or-more-arguments head args polarity 1)
+  (nconc (input-terms (butlast args) polarity) (input-term1 (first (last args)) polarity)))
+
+(defun input-function-as-relation-result-sort2 (head args)
+  (let* ((arity (+ (length args) 1))
+         (rel (find-symbol-table-entry (function-name head) :relation arity)))
+    (if (eq none rel)
+        (top-sort)
+        (asa-arg-sort (function-argument-sort-alist rel) arity))))
+
+(defun input-function-as-relation-result-sort (head args)
+  (let ((resultsort (sort-intersection
+                     (function-sort head)
+                     (input-function-as-relation-result-sort2 head args))))
+    (cl:assert resultsort)
+    resultsort))
+
+(defun input-function-as-relation (head args polarity &optional (new-head-name (function-name head)))
+  ;; see related code in input-equality
+  (let* ((resultsort (input-function-as-relation-result-sort head args))
+         (resultvar (if (top-sort? resultsort)
+                        (make-symbol (to-string (first (variable-symbol-prefixes?)) (nonce)))
+                        (make-symbol (to-string (first (variable-symbol-prefixes?)) resultsort (nonce)))))
+         (antecedent (input-wff1 (cons new-head-name (append args (list resultvar))) :neg)))
+    (setf *input-wff-new-antecedents* (conjoin *input-wff-new-antecedents* antecedent))
+    (input-term1 resultvar polarity)))
+
+(defun input-float-function-as-relation (head args polarity)
+  (let* ((str (symbol-name (function-name head)))
+         (len (length str)))
+    (cl:assert (string-equal str "_float" :start1 (- len 6):end1 len))
+    (input-function-as-relation head args polarity (intern (subseq str 0 (- len 6)) :snark))))
+
+(defun input-relation-as-function (head args polarity)
+  (input-atom (list '= (cons (function-name head) (butlast args)) (first (last args))) polarity))
+
+(defun input-equivalence (head args polarity)
+  (cond
+    ((null args)
+     true)
+    ((null (rest args))
+     (input-wff1 (first args) polarity))
+    ((and (not (null (cddr args))) (eql 2 (function-arity head)))
+     (input-equivalence head (list (first args) (cons (function-name head) (rest args))) polarity))
+    ((eq :both polarity)
+     (make-equivalence* (input-wffs1 head args polarity)))
+    ((catch 'needs-strict-polarity
+       (make-equivalence* (input-wffs1 head args polarity)))
+     )
+    (t
+     (let ((x (first args))
+	   (y (if (null (cddr args)) (second args) (cons (function-name head) (rest args)))))
+       (input-wff1 (if (eq :neg polarity)
+                       `(or (and ,x ,y) (and (not ,x) (not ,y)))
+                       `(and (implies ,x ,y) (implied-by ,x ,y)))
+                   polarity)))))
+
+(defun input-exclusive-or (head args polarity)
+  (cond
+    ((null args)
+     false)
+    ((null (rest args))
+     (input-wff1 (first args) polarity))
+    ((and (not (null (cddr args))) (eql 2 (function-arity head)))
+     (input-exclusive-or
+       head (list (first args) (cons (function-name head) (rest args))) polarity))
+    ((eq :both polarity)
+     (make-exclusive-or* (input-wffs1 head args polarity)))
+    ((catch 'needs-strict-polarity
+       (make-exclusive-or* (input-wffs1 head args polarity)))
+     )
+    (t
+     (let ((x (first args))
+	   (y (if (null (cddr args)) (second args) (cons (function-name head) (rest args)))))
+       (input-wff1 (if (eq :neg polarity)
+                       `(or (and ,x (not ,y)) (and (not ,x) ,y))
+                       `(and (or ,x ,y) (or (not ,x) (not ,y))))
+                   polarity)))))
+
+(defun input-conditional (head args polarity)
+  (require-n-arguments head args polarity 3)
+  (cond
+    ((eq :both polarity)
+     (make-conditional
+      (input-wff1 (first args) :both)
+      (input-wff1 (second args) polarity)
+      (input-wff1 (third args) polarity)))
+    ((catch 'needs-strict-polarity
+       (make-conditional
+        (input-wff1 (first args) :both)
+        (input-wff1 (second args) polarity)
+        (input-wff1 (third args) polarity)))
+     )
+    (t
+     (input-wff1 (if (eq :neg polarity)
+                     `(or (and ,(first args) ,(second args))
+                          (and (not ,(first args)) ,(third args)))
+                     `(and (implies ,(first args) ,(second args))
+                           (implies (not ,(first args)) ,(third args))))
+                 polarity))))
+
+(defun input-conditional-answer (head args polarity)
+  (require-n-arguments head args polarity 3)
+  (make-conditional-answer
+     (input-wff1 (first args) :both)
+     (input-wff1 (second args) polarity)
+     (input-wff1 (third args) polarity)))
+
+(defun input-quantification (head args polarity)
+  (cond
+   ((eq :both polarity)
+    (throw 'needs-strict-polarity nil))
+   (t
+    (unless (eql 2 (length args))
+      ;; (forall (vars) form . forms) means (forall (vars) (implies (and . forms) form))
+      ;; (exists (vars) form . forms) means (exists (vars) (and form . forms))
+      (require-n-or-more-arguments head args polarity 2)
+      (report-not-2-arguments-quantification head args)
+      (setf args
+            (list (first args)
+                  (cond
+                   ((eq *forall* head)
+                    `(=> ,@(rest args)))
+                   ((eq *exists* head)
+                    `(and ,@(rest args)))))))
+    (let ((var-specs (input-quantifier-variables (first args)))
+          (form (second args))
+          (substitution *input-wff-substitution*)
+          *input-wff-substitution*)
+      (cond
+       ((or (and (eq :pos polarity) (eq *forall* head))
+            (and (eq :neg polarity) (eq *exists* head)))
+        ;; add (variable-name . variable) pairs to substitution
+        (dolist (var-spec var-specs)
+          (let ((var (first var-spec)))
+            (push (cons var (make-variable-from-var-spec var-spec)) substitution)
+            (push (car substitution) *input-wff-substitution2*)))
+        (setf *input-wff-substitution* substitution))
+       ((or (and (eq :pos polarity) (eq *exists* head))
+            (and (eq :neg polarity) (eq *forall* head)))
+        (let ((free-vars-in-form (input-variables-in-form form (mapcar #'first var-specs) substitution)))
+          ;; add (variable-name . skolem-term) pairs to substitution
+          (dolist (var-spec var-specs)
+            (let ((var (first var-spec)))
+              (push (cons var (if (use-quantifier-preservation?)
+                                  (make-variable-from-var-spec var-spec)
+                                  (create-skolem-term var-spec form free-vars-in-form polarity)))
+                    substitution)
+              (push (car substitution) *input-wff-substitution2*))))
+        (setf *input-wff-substitution* substitution))
+       (t
+        (unimplemented)))
+      (when (or (eq *forall* head)
+                (eq *exists* head))
+        (let ((usr (use-sort-relativization?))
+              (l nil))
+          (dolist (var-spec var-specs)
+            (let ((sort (getf (rest var-spec) :sort)))
+              (when (and (not (top-sort-name? sort))
+                         (or usr (getf (rest var-spec) :sort-unknown)))
+                (push `(,(sort-name sort) ,(first var-spec)) l))))
+          (when l
+            (setf form (list (if (eq *forall* head) 'implies 'and)
+                             (if (null (rest l)) (first l) (cons 'and (nreverse l)))
+                             form)))))
+      (cond
+       ((use-quantifier-preservation?)
+        (make-compound
+         head
+         (input-terms (mapcar #'first var-specs) polarity)
+         (input-wff1 form polarity)))
+       (t
+        (input-wff1 form polarity)))))))
+
+(defun input-quantifier-variable (var-spec)
+  ;; var-spec should be of form
+  ;;  variable-name
+  ;; or
+  ;;  (variable-name . keyword-argument-list)
+  ;; such as
+  ;;  (variable-name :sort sort-name)
+  ;; or
+  ;;  (variable-name restriction-name . keyword-argument-list)
+  ;; such as
+  ;;  (variable-name restriction-name) - KIF
+  ;; interpeted as
+  ;;  (variable-name :sort restriction-name . keyword-argument-list)
+  ;;
+  ;; output is always of form
+  ;;  (variable-name . keyword-argument-list)
+  (cond
+   ((atom var-spec)
+    (setf var-spec (list var-spec)))
+  ((and (evenp (length var-spec)) (top-sort-name? (second var-spec)))
+    ;; ignore top-sort restriction iff :sort is specified
+    (setf var-spec
+          (if (getf (cddr var-spec) :sort)
+              (list* (first var-spec) (cddr var-spec))
+              (list* (first var-spec) :sort (second var-spec) (cddr var-spec)))))
+   ((evenp (length var-spec))
+    ;; restriction-name is interpreted as sort (possibly unknown)
+    (cl:assert (equal (second var-spec) (getf (cddr var-spec) :sort (second var-spec))) ()
+               "In quantification, ~S has both a restriction and a sort." var-spec)
+    (setf var-spec
+          (cond
+           ((sort-name-expression? (second var-spec))
+            (list* (first var-spec) :sort (second var-spec) (cddr var-spec)))
+           (t
+            (list* (first var-spec) :sort (second var-spec) :sort-unknown t (cddr var-spec)))))))
+  (cl:assert (keyword-argument-list-p (rest var-spec)) ()
+	     "In quantification, ~S is not a keyword argument list." (rest var-spec))
+  (let ((var (first var-spec))
+        (sort (getf (rest var-spec) :sort none))
+        (sort-unknown (getf (rest var-spec) :sort-unknown)))
+    (cl:assert (can-be-variable-name var) () "In quantification, ~S is not a variable name." var)
+    (cond
+     ((neq none sort)
+      (cond
+       (sort-unknown
+        (declare-variable var))
+       (t
+        ;; sort must have been declared
+        (the-sort sort)
+        (declare-variable var)))
+      (append var-spec
+              '(:skolem-p t)
+              `(:allowed-in-answer ,(allow-skolem-symbols-in-answers?))))
+     (t
+      (append var-spec 
+              `(:sort ,(sort-name (variable-sort (declare-variable var))))
+              '(:skolem-p t)
+              `(:allowed-in-answer ,(allow-skolem-symbols-in-answers?)))))))
+
+(defun make-variable-from-var-spec (var-spec)
+  (if (getf (rest var-spec) :sort-unknown)
+      (make-variable)
+      (make-variable (the-sort (getf (rest var-spec) :sort)))))
+
+(defun input-quantifier-variables (var-specs)
+  ;; CycL requires single variable-name,
+  ;; KIF 3.0 allows it,
+  ;; KIF proposed ANSI standard disallows it
+  (unless (listp var-specs)
+    (setf var-specs (list var-specs)))
+  (cl:assert (and (listp var-specs) (not (keywordp (second var-specs)))) ()
+             "Quantifier requires a list of bound variables.")
+  (setf var-specs (mapcar #'input-quantifier-variable var-specs))
+  (setf var-specs (remove-duplicates
+                   var-specs
+                   :test (lambda (x y)
+                           (when (eq (first x) (first y))
+                             (funcall (if (equal (rest x) (rest y)) 'warn 'error)
+                                      "In quantification, variable ~A is being rebound."
+                                      (first x))
+                             t))))
+  (dolist (x var-specs)
+    (when (assoc (first x) *input-wff-substitution*)
+      (warn "In quantification, variable ~A is being rebound." (first x))))
+  var-specs)
+
+(defun input-variables-in-form (expr vars substitution &optional result)
+  ;; excluding vars
+  (cond
+    ((atom expr)
+     (let ((v nil))
+       (cond
+        ((member expr vars)
+         result)
+        ((setf v (assoc expr substitution))
+         (cond
+          ((variable-p (cdr v))
+           (if (rassoc (cdr v) result) result (nconc result (list v))))
+          ((compound-p (cdr v))
+           (dolist (x (args (cdr v)))
+             (unless (rassoc x result)
+               (setf result (nconc result (list (cons (car (rassoc x substitution)) x))))))
+           result)
+          (t
+           result)))
+        ((can-be-free-variable-name expr)
+         (setf v (declare-variable expr))
+         (if (rassoc v result) result (nconc result (list (cons expr v)))))
+        (t
+         result))))
+    ((eq 'quote (first expr))
+     result)
+    ((let ((v (input-logical-symbol (first expr))))
+       (or (eq *forall* v) (eq *exists* v)))
+     (dolist (var-spec (input-quantifier-variables (second expr)))
+       (pushnew (first var-spec) vars))
+     (input-variables-in-form
+      (third expr)
+      vars
+      substitution
+      result))
+    (t
+     (dolist (x (rest expr))
+       (setf result (input-variables-in-form x vars substitution result)))
+     result)))
+
+(defun create-skolem-term (var-spec form free-vars-in-form polarity)
+  (let ((sort (getf (rest var-spec) :sort))
+        (sort-unknown (getf (rest var-spec) :sort-unknown))
+	(newskfn (create-skolem-symbol var-spec form (mapcar #'car free-vars-in-form) polarity)))
+    (setf var-spec (copy-list var-spec))
+    (remf (rest var-spec) :sort)
+    (remf (rest var-spec) :sort-unknown)
+    (remf (rest var-spec) :conc-name)
+    (cond
+      ((null free-vars-in-form)
+       (setf newskfn (apply #'declare-constant newskfn (rest var-spec)))
+       (when (and (not (top-sort-name? sort)) (not sort-unknown))
+	 (declare-constant-sort newskfn sort))
+       newskfn)
+      (t
+       (setf newskfn (apply #'declare-function newskfn (length free-vars-in-form) (rest var-spec)))
+       (when (and (not (top-sort-name? sort)) (not sort-unknown))
+	 (declare-function-sort newskfn (cons sort (consn (top-sort-name) nil (length free-vars-in-form)))))
+       (make-compound* newskfn (mapcar #'cdr free-vars-in-form))))))
+
+(defun create-skolem-symbol (var-spec form free-vars-in-form polarity)
+  ;; this code for generating skolem function names and world path function names
+  ;; stores the generated name in an alist so that if the exact same wff is input
+  ;; again, the same names will be generated
+  ;; thus,
+  ;; (assert '(forall (x) (exists (y) (p x y))))
+  ;;  followed by
+  ;; (assert '(forall (x) (exists (y) (p x y))))
+  ;; will result in two occurrences of the same wff with the same skolem function
+  ;;
+  ;; this could be improved by checking for variants rather than equality so that
+  ;; (assert '(forall (u) (exists (v) (p u v))))
+  ;; would also produce the same wff with the same skolem function
+  (let ((key (list var-spec form free-vars-in-form polarity)))
+    (or (cdr (assoc key *skolem-function-alist* :test #'equal))
+	(let* (conc-name
+	       sort
+	       (x (cond
+                   ((setf conc-name (getf (rest var-spec) :conc-name))
+                    (newsym2 conc-name))
+                   ((and (not (getf (rest var-spec) :sort-unknown))
+                         (not (top-sort-name? (setf sort (getf (rest var-spec) :sort)))))
+                    (newsym :name :skolem :sort sort))
+                   (t
+                    (newsym :name :skolem)))))
+;;	  (push (cons key x) *skolem-function-alist*)	;skolem symbol reuse disabled pending fix
+	  x))))
+
+;;; *new-symbol-prefix* is included in created (including skolem) constant and function symbol names
+;;; to give them hopefully unambiguous internable names across SNARK runs
+;;; to allow import and export of created symbols without conflict
+
+(defvar *new-symbol-prefix*)			;set to "unique" value by (initialize)
+(defvar *number-of-new-symbols*)		;set to 0 by (initialize)
+(defvar *new-symbol-table*)			;set to hash table by (initialize)
+
+(defun newsym-prefix ()
+  (let ((alphabet (symbol-name :abcdefghijklmnopqrstuvwxyz))
+        (n (get-internal-run-time))
+        (l nil))
+    (dotimes (i 4)
+      (push (char alphabet (rem n 26)) l)
+      (setf n (floor n 26)))
+    (coerce l 'string)))
+
+(defun newsym (&key (name :newsym) sort)
+  (intern (if sort
+              (to-string name *new-symbol-prefix* (incf *number-of-new-symbols*) (variable-sort-marker?) sort)
+              (to-string name *new-symbol-prefix* (incf *number-of-new-symbols*)))
+          :snark-user))
+
+(defun newsym2 (conc-name)
+  (let ((n (gethash conc-name *new-symbol-table* 0)))
+    (cond
+     ((= 0 n)
+      (setf (gethash conc-name *new-symbol-table*) 1)
+      conc-name)
+     (t
+      (setf (gethash conc-name *new-symbol-table*) (+ 1 n))
+      (intern (to-string conc-name n) :snark-user)))))  
+
+(defun input-form* (head terms polarity)
+  (make-compound* head (input-terms terms polarity)))
+
+(defun input-form (head terms polarity)
+  (dolist (fun (function-input-code head) (input-form* head terms polarity))
+    (let ((v (funcall fun head terms polarity)))
+      (unless (eq none v)
+        (return v)))))
+
+(defun input-atom (atom polarity)
+  (cond
+    ((can-be-proposition-name atom)
+     (cond
+       ((cdr (assoc atom *input-wff-substitution*))
+	(unimplemented))			;proposition variables
+       (t
+        (input-proposition-symbol atom))))
+    ((and (consp atom) (can-be-function-name (first atom)))
+     (check-for-well-sorted-atom
+      (input-form (input-head-relation-symbol atom) (rest atom) polarity)))
+    ((and *input-proposition-variables* (can-be-free-variable-name atom))
+     (declare-variable atom))
+    (t
+     (error "Cannot understand ~S as an atomic formula." atom))))
+
+(defun input-term (term &key (polarity :pos) (*input-wff-substitution* nil))
+  (let ((*input-wff-new-antecedents* true)
+        (*input-wff-modal-prefix* nil))
+    (check-well-sorted (input-term1 term polarity))))
+
+(defun input-term1 (term polarity)
+  (cond
+   ((variable-p term)
+    term)
+   ((cdr (assoc term *input-wff-substitution*))
+    )
+   ((atom term)
+    (cond
+     ((can-be-free-variable-name term)
+      (declare-variable term))
+     (t
+      (input-constant-symbol term))))
+   (t
+    (can-be-function-name (first term) 'error)
+    (input-form (input-head-function-symbol term) (rest term) polarity))))
+
+(defun input-terms (terms polarity)
+  (lcons (input-term1 (first terms) polarity)
+	 (input-terms (rest terms) polarity)
+	 terms))
+
+(defun map-polarity (fun polarity)
+  (if fun (funcall fun polarity) polarity))
+
+(defun opposite-polarity (polarity)
+  (ecase polarity
+    (:pos
+      :neg)
+    (:neg
+      :pos)
+    (:both
+      :both)))
+
+(defun input-atom-with-keyword-arguments (head args polarity keywords)
+  ;; (declare-relation 'person :any
+  ;;   :sort '((1 string) (2 real) (3 string))
+  ;;   :input-code (atom-with-keywords-inputter '(:name :age :sex)))
+  ;; allows arguments of 3-ary person relation to be specified positionally, by keyword, or a combination
+  ;; (person "john" 21 "male"),
+  ;; (person "john" :age 21 :sex "male"),
+  ;; (person "john" :sex "male" :age 21),
+  ;; and (person :sex "male" :age 21 :name "john")
+  ;; all yield (person "john" 21 "male")
+  ;; argument list is scanned left-to-right, processed positionally until first keyword, then as keyword/value pairs
+  ;; (keywords must be syntactically distinguishable from values for this to work properly)
+  ;; missing arguments are replaced by existentially quantified variables
+  (let ((arity (length keywords)))
+    (cond
+     ((and (length= arity args) (null (intersection keywords args)))
+      none)
+     (t
+      (let ((args* (make-array (length keywords) :initial-element none)))
+        (let ((l args)
+              (processing-keyword-arguments nil)
+              (i 0)
+              pos)
+          (loop
+            (when (endp l)
+              (return))
+            (cond
+             ((setf pos (position (first l) keywords))
+              (cl:assert (eq none (svref args* pos)) () "~S argument given twice in ~S." (first l) (cons (function-name head) args))
+              (cl:assert (not (endp (setf l (rest l)))) () "Too few arguments in ~S." (cons (function-name head) args))
+              (setf processing-keyword-arguments t))
+             (t
+              (cl:assert (not processing-keyword-arguments) () "Expected ~S to be a keyword in ~S." (first l) (cons (function-name head) args)) 
+              (cl:assert (< i arity) () "Too many arguments in ~S." (cons (function-name head) args))
+              (setf pos i)
+              (setf i (+ 1 i))))
+            (setf (svref args* pos) (pop l))))
+        (let ((vars nil))
+          (dotimes (i arity)
+            (when (eq none (svref args* i))
+              (let ((var (gensym))
+                    (sort (asa-arg-sort (function-argument-sort-alist head) (+ 1 i))))
+                (setf (svref args* i) var)
+                (push (if (top-sort? sort) var (list var :sort sort)) vars))))
+          (let ((atom (cons (function-name head) (coerce args* 'list))))
+            (input-wff1 (if vars (list 'exists (nreverse vars) atom) atom) polarity))))))))
+
+(defun atom-with-keywords-inputter (keywords)
+  #'(lambda (head args polarity) (input-atom-with-keyword-arguments head args polarity keywords)))
+
+(defun clausify (wff &optional map-fun)
+  ;; apply map-fun to each clause in the clause form of wff
+  ;; if map-fun is NIL, return CNF of wff
+  (let ((clauses nil) clauses-last)
+    (labels
+      ((clausify* (cc wff pos lits)
+         (cond
+          ((and pos (test-option6?) (clause-p wff t))
+           (funcall cc (cons wff lits)))
+          (t
+	   (ecase (head-is-logical-symbol wff)
+	     ((nil)
+              (cond
+               ((eq true wff)
+                (unless pos
+                  (funcall cc lits)))
+               ((eq false wff)
+                (when pos
+                  (funcall cc lits)))
+               (t
+                (let ((-wff (make-compound *not* wff)))
+                  (dolist (lit lits (funcall cc (cons (if pos wff -wff) lits)))
+                    (cond
+                     ((equal-p lit wff)
+                      (when pos
+                        (funcall cc lits))
+                      (return))
+                     ((equal-p lit -wff)
+                      (unless pos
+                        (funcall cc lits))
+                      (return))))))))
+	     (not
+              (clausify* cc (first (args wff)) (not pos) lits))
+	     (and
+              (let ((args (args wff)))
+	        (if pos
+		    (if (and lits (some (lambda (arg) (member-p arg lits)) args))
+		        (funcall cc lits)
+		        (dolist (arg args)
+		          (clausify* cc arg t lits)))
+                    (let ((y (make-a1-compound* *and* true (rest args))))
+		      (clausify* (lambda (l) (clausify* cc y nil l)) (first args) nil lits)))))
+	     (or
+              (let ((args (args wff)))
+	        (if pos
+                    (let ((y (make-a1-compound* *or* false (rest args))))
+		      (clausify* (lambda (l) (clausify* cc y t l)) (first args) t lits))
+		    (if (and lits (some (lambda (arg) (member-p (negate arg) lits)) args))
+		        (funcall cc lits)
+		        (dolist (arg args)
+		          (clausify* cc arg nil lits))))))
+	     (implies
+              (let* ((args (args wff)) (x (first args)) (y (second args)))
+	        (if pos
+		    (clausify* (lambda (l) (clausify* cc y t l)) x nil lits)
+		    (progn
+		      (clausify* cc x t   lits)
+		      (clausify* cc y nil lits)))))
+	     (implied-by
+              (let* ((args (args wff)) (x (first args)) (y (second args)))
+	        (if pos
+		    (clausify* (lambda (l) (clausify* cc y nil l)) x t lits)
+		    (progn
+		      (clausify* cc y t   lits)
+		      (clausify* cc x nil lits)))))
+	     (iff
+              (let* ((args (args wff)) (x (first args)) (y (make-a1-compound* *iff* true (rest args))))
+	        (if pos
+		    (progn
+		      (clausify* (lambda (l) (clausify* cc y t   l)) x nil lits)
+		      (clausify* (lambda (l) (clausify* cc y nil l)) x t   lits))
+		    (progn
+		      (clausify* (lambda (l) (clausify* cc y nil l)) x nil lits)
+		      (clausify* (lambda (l) (clausify* cc y t   l)) x t   lits)))))
+	     (xor
+              (let* ((args (args wff)) (x (first args)) (y (make-a1-compound* *xor* false (rest args))))
+	        (if pos
+		    (progn
+		      (clausify* (lambda (l) (clausify* cc y nil l)) x nil lits)
+		      (clausify* (lambda (l) (clausify* cc y t   l)) x t   lits))
+		    (progn
+		      (clausify* (lambda (l) (clausify* cc y t   l)) x nil lits)
+		      (clausify* (lambda (l) (clausify* cc y nil l)) x t   lits)))))
+             (if 
+               (let* ((args (args wff)) (x (first args)) (y (second args)) (z (third args)))
+                 (clausify* (lambda (l) (clausify* cc y pos l)) x nil lits)
+                 (clausify* (lambda (l) (clausify* cc z pos l)) x t   lits))))))))
+      (clausify* (lambda (lits)
+                   (let ((clause (make-a1-compound* *or* false (reverse lits))))
+                     (if map-fun (funcall map-fun clause) (collect clause clauses))))
+                 wff t nil)
+      (if map-fun nil (make-a1-compound* *and* true clauses)))))
+
+(defun report-not-2-arguments-quantification (head args)
+  (case (use-extended-quantifiers?)
+    ((nil)
+     (with-standard-io-syntax2
+       (cerror "Convert it to a 2-ary quantification."
+               "~S does not have exactly 2 arguments as ~A ~S wants."
+               (cons (function-name head) args) (function-kind head) (function-name head))))
+    (warn
+     (with-standard-io-syntax2
+       (warn "~S does not have exactly 2 arguments as ~A ~S wants.  It will be converted."
+             (cons (function-name head) args) (function-kind head) (function-name head))))))
+
+(defun report-not-2-arguments-implication (head args)
+  (case (use-extended-implications?)
+    ((nil)
+     (with-standard-io-syntax2
+       (cerror "Convert it to a 2-ary implication."
+               "~S does not have exactly 2 arguments as ~A ~S wants."
+               (cons (function-name head) args) (function-kind head) (function-name head))))
+    (warn
+     (with-standard-io-syntax2
+       (warn "~S does not have exactly 2 arguments as ~A ~S wants.  It will be converted."
+             (cons (function-name head) args) (function-kind head) (function-name head))))))
+
+;;; the following functions can be used as in
+;;; (declare-relation 'product :any :input-code (lambda (h a p) (require-n-arguments h a p 3)))
+;;; so that that there is only one product relation symbol
+;;; (not more than one of different arities as is usually allowed)
+;;; and it always has three arguments
+;;; (not arbitrarily many as is usual for :any arity relations)
+
+(defun require-n-arguments (head args polarity n)
+  ;; if no error, returns none to cause later input-function-code to be used
+  (declare (ignore polarity))
+  (unless (length= n args)
+    (with-standard-io-syntax2
+      (cerror1 "~S does not have exactly ~D argument~:P as ~A ~S requires."
+               (cons (function-name head) args) n (function-kind head) (function-name head))))
+  none)
+
+(defun require-n-or-more-arguments (head args polarity n)
+  ;; if no error, returns none to cause later input-function-code to be used
+  (declare (ignore polarity))
+  (unless (length<= n args)
+    (with-standard-io-syntax2
+      (cerror1 "~S does not have at least ~D argument~:P as ~A ~S requires."
+               (cons (function-name head) args) n (function-kind head) (function-name head))))
+  none)
+
+;;; input.lisp EOF

snark-20120808r02/src/jepd-relations-tables.lisp

@@ -0,0 +1,511 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
+;;; File: jepd-relations-tables.lisp
+;;; The contents of this file are subject to the Mozilla Public License
+;;; Version 1.1 (the "License"); you may not use this file except in
+;;; compliance with the License. You may obtain a copy of the License at
+;;; http://www.mozilla.org/MPL/
+;;;
+;;; Software distributed under the License is distributed on an "AS IS"
+;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+;;; License for the specific language governing rights and limitations
+;;; under the License.
+;;;
+;;; The Original Code is SNARK.
+;;; The Initial Developer of the Original Code is SRI International.
+;;; Portions created by the Initial Developer are Copyright (C) 1981-2002.
+;;; All Rights Reserved.
+;;;
+;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
+
+(in-package :snark)
+
+(defparameter $rcc8-relation-code
+  '((tpp . 0) (ntpp . 1) (dc . 2) (ec . 3) (po . 4) (eq . 5) (ntppi . 6) (tppi . 7)))
+
+(defparameter $time-ii-relation-code
+  '((< . 0) (d . 1) (o . 2) (m . 3) (s . 4) (f . 5) (= . 6)
+    (fi . 7) (si . 8) (mi . 9) (oi . 10) (di . 11) (> . 12)))
+
+(defparameter $time-pp-relation-code
+  '((p<p . 0) (p=p . 1) (p>p . 2)))
+
+(defparameter $time-pi-relation-code
+  '((p<i . 0) (p_s_i . 1) (p_d_i . 2) (p_f_i . 3) (p>i . 4)))
+
+(defparameter $time-ip-relation-code
+  '((i>p . 0) (i_si_p . 1) (i_di_p . 2) (i_fi_p . 3) (i<p . 4)))
+
+(defparameter $rcc8-composition-table
+  ;; from Cohn, Bennett, Gooday, and Gotts
+  ;; "Qualitative Spatial Representation and Reasoning with the Region Connection Calculus"
+  ;; Geoinformatica 1 (1997), 1-44
+  '((dc dc       dc ec po tpp ntpp tppi ntppi eq)
+    (dc ec       dc ec po tpp ntpp              )
+    (dc po       dc ec po tpp ntpp              )
+    (dc tpp      dc ec po tpp ntpp              )
+    (dc ntpp     dc ec po tpp ntpp              )
+    (dc tppi     dc                             )
+    (dc ntppi    dc                             )
+    (dc eq       dc                             )
+    (ec dc       dc ec po          tppi ntppi   )
+    (ec ec       dc ec po tpp      tppi       eq)
+    (ec po       dc ec po tpp ntpp              )
+    (ec tpp         ec po tpp ntpp              )
+    (ec ntpp           po tpp ntpp              )
+    (ec tppi     dc ec                          )
+    (ec ntppi    dc                             )
+    (ec eq       ec                             )
+    (po dc       dc ec po          tppi ntppi   )
+    (po ec       dc ec po          tppi ntppi   )
+    (po po       dc ec po tpp ntpp tppi ntppi eq)
+    (po tpp            po tpp ntpp              )
+    (po ntpp           po tpp ntpp              )
+    (po tppi     dc ec po          tppi ntppi   )
+    (po ntppi    dc ec po          tppi ntppi   )
+    (po eq             po                       )
+    (tpp dc      dc                             )
+    (tpp ec      dc ec                          )
+    (tpp po      dc ec po tpp ntpp              )
+    (tpp tpp              tpp ntpp              )
+    (tpp ntpp                 ntpp              )
+    (tpp tppi    dc ec po tpp      tppi       eq)
+    (tpp ntppi   dc ec po          tppi ntppi   )
+    (tpp eq               tpp                   )
+    (ntpp dc     dc                             )
+    (ntpp ec     dc                             )
+    (ntpp po     dc ec po tpp ntpp              )
+    (ntpp tpp                 ntpp              )
+    (ntpp ntpp                ntpp              )
+    (ntpp tppi   dc ec po tpp ntpp              )
+    (ntpp ntppi  dc ec po tpp ntpp tppi ntppi eq)
+    (ntpp eq                  ntpp              )
+    (tppi dc     dc ec po          tppi ntppi   )
+    (tppi ec        ec po          tppi ntppi   )
+    (tppi po           po          tppi ntppi   )
+    (tppi tpp          po tpp      tppi       eq)
+    (tppi ntpp         po tpp ntpp              )
+    (tppi tppi                     tppi ntppi   )
+    (tppi ntppi                         ntppi   )
+    (tppi eq                       tppi         )
+    (ntppi dc    dc ec po          tppi ntppi   )
+    (ntppi ec          po          tppi ntppi   )
+    (ntppi po          po          tppi ntppi   )
+    (ntppi tpp         po          tppi ntppi   )
+    (ntppi ntpp        po tpp ntpp tppi ntppi eq)
+    (ntppi tppi                         ntppi   )
+    (ntppi ntppi                        ntppi   )
+    (ntppi eq                           ntppi   )
+    (eq dc       dc                             )
+    (eq ec          ec                          )
+    (eq po             po                       )
+    (eq tpp               tpp                   )
+    (eq ntpp                  ntpp              )
+    (eq tppi                       tppi         )
+    (eq ntppi                           ntppi   )
+    (eq eq                                    eq)))
+
+(defparameter $time-iii-composition-table
+  '((< < <)
+    (< > < > d di o oi m mi s si f fi =)
+    (< d < d o m s)
+    (< di <)
+    (< o <)
+    (< oi < d o m s)
+    (< m <)
+    (< mi < d o m s)
+    (< s <)
+    (< si <)
+    (< f < d o m s)
+    (< fi <)
+    (< = <)
+    (> < < > d di o oi m mi s si f fi =)
+    (> > >)
+    (> d > d oi mi f)
+    (> di >)
+    (> o > d oi mi f)
+    (> oi >)
+    (> m > d oi mi f)
+    (> mi >)
+    (> s > d oi mi f)
+    (> si >)
+    (> f >)
+    (> fi >)
+    (> = >)
+    (d < <)
+    (d > >)
+    (d d d)
+    (d di < > d di o oi m mi s si f fi =)
+    (d o < d o m s)
+    (d oi > d oi mi f)
+    (d m <)
+    (d mi >)
+    (d s d)
+    (d si > d oi mi f)
+    (d f d)
+    (d fi < d o m s)
+    (d = d)
+    (di < < di o m fi)
+    (di > > di oi mi si)
+    (di d d di o oi s si f fi =)
+    (di di di)
+    (di o di o fi)
+    (di oi di oi si)
+    (di m di o fi)
+    (di mi di oi si)
+    (di s di o fi)
+    (di si di)
+    (di f di oi si)
+    (di fi di)
+    (di = di)
+    (o < <)
+    (o > > di oi mi si)
+    (o d d o s)
+    (o di < di o m fi)
+    (o o < o m)
+    (o oi d di o oi s si f fi =)
+    (o m <)
+    (o mi di oi si)
+    (o s o)
+    (o si di o fi)
+    (o f d o s)
+    (o fi < o m)
+    (o = o)
+    (oi < < di o m fi)
+    (oi > >)
+    (oi d d oi f)
+    (oi di > di oi mi si)
+    (oi o d di o oi s si f fi =)
+    (oi oi > oi mi)
+    (oi m di o fi)
+    (oi mi >)
+    (oi s d oi f)
+    (oi si > oi mi)
+    (oi f oi)
+    (oi fi di oi si)
+    (oi = oi)
+    (m < <)
+    (m > > di oi mi si)
+    (m d d o s)
+    (m di <)
+    (m o <)
+    (m oi d o s)
+    (m m <)
+    (m mi f fi =)
+    (m s m)
+    (m si m)
+    (m f d o s)
+    (m fi <)
+    (m = m)
+    (mi < < di o m fi)
+    (mi > >)
+    (mi d d oi f)
+    (mi di >)
+    (mi o d oi f)
+    (mi oi >)
+    (mi m s si =)
+    (mi mi >)
+    (mi s d oi f)
+    (mi si >)
+    (mi f mi)
+    (mi fi mi)
+    (mi = mi)
+    (s < <)
+    (s > >)
+    (s d d)
+    (s di < di o m fi)
+    (s o < o m)
+    (s oi d oi f)
+    (s m <)
+    (s mi mi)
+    (s s s)
+    (s si s si =)
+    (s f d)
+    (s fi < o m)
+    (s = s)
+    (si < < di o m fi)
+    (si > >)
+    (si d d oi f)
+    (si di di)
+    (si o di o fi)
+    (si oi oi)
+    (si m di o fi)
+    (si mi mi)
+    (si s s si =)
+    (si si si)
+    (si f oi)
+    (si fi di)
+    (si = si)
+    (f < <)
+    (f > >)
+    (f d d)
+    (f di > di oi mi si)
+    (f o d o s)
+    (f oi > oi mi)
+    (f m m)
+    (f mi >)
+    (f s d)
+    (f si > oi mi)
+    (f f f)
+    (f fi f fi =)
+    (f = f)
+    (fi < <)
+    (fi > > di oi mi si)
+    (fi d d o s)
+    (fi di di)
+    (fi o o)
+    (fi oi di oi si)
+    (fi m m)
+    (fi mi di oi si)
+    (fi s o)
+    (fi si di)
+    (fi f f fi =)
+    (fi fi fi)
+    (fi = fi)
+    (= < <)
+    (= > >)
+    (= d d)
+    (= di di)
+    (= o o)
+    (= oi oi)
+    (= m m)
+    (= mi mi)
+    (= s s)
+    (= si si)
+    (= f f)
+    (= fi fi)
+    (= = =)))
+
+(defparameter $time-ppp-composition-table
+  '((p<p p<p p<p) 
+    (p<p p>p p<p p>p p=p) 
+    (p<p p=p p<p) 
+    (p>p p<p p<p p>p p=p) 
+    (p>p p>p p>p) 
+    (p>p p=p p>p) 
+    (p=p p<p p<p) 
+    (p=p p>p p>p) 
+    (p=p p=p p=p)))
+
+(defparameter $time-pii-composition-table
+  '((p<i < p<i) 
+    (p<i > p<i p>i p_d_i p_s_i p_f_i) 
+    (p<i d p<i p_d_i p_s_i) 
+    (p<i di p<i) 
+    (p<i o p<i) 
+    (p<i oi p<i p_d_i p_s_i) 
+    (p<i m p<i) 
+    (p<i mi p<i p_d_i p_s_i) 
+    (p<i s p<i) 
+    (p<i si p<i) 
+    (p<i f p<i p_d_i p_s_i) 
+    (p<i fi p<i) 
+    (p<i = p<i) 
+    (p>i < p<i p>i p_d_i p_s_i p_f_i) 
+    (p>i > p>i) 
+    (p>i d p>i p_d_i p_f_i) 
+    (p>i di p>i) 
+    (p>i o p>i p_d_i p_f_i) 
+    (p>i oi p>i) 
+    (p>i m p>i p_d_i p_f_i) 
+    (p>i mi p>i) 
+    (p>i s p>i p_d_i p_f_i) 
+    (p>i si p>i) 
+    (p>i f p>i) 
+    (p>i fi p>i) 
+    (p>i = p>i) 
+    (p_d_i < p<i) 
+    (p_d_i > p>i) 
+    (p_d_i d p_d_i) 
+    (p_d_i di p<i p>i p_d_i p_s_i p_f_i) 
+    (p_d_i o p<i p_d_i p_s_i) 
+    (p_d_i oi p>i p_d_i p_f_i) 
+    (p_d_i m p<i) 
+    (p_d_i mi p>i) 
+    (p_d_i s p_d_i) 
+    (p_d_i si p>i p_d_i p_f_i) 
+    (p_d_i f p_d_i) 
+    (p_d_i fi p<i p_d_i p_s_i) 
+    (p_d_i = p_d_i) 
+    (p_s_i < p<i) 
+    (p_s_i > p>i) 
+    (p_s_i d p_d_i) 
+    (p_s_i di p<i) 
+    (p_s_i o p<i) 
+    (p_s_i oi p_d_i) 
+    (p_s_i m p<i) 
+    (p_s_i mi p_f_i) 
+    (p_s_i s p_s_i) 
+    (p_s_i si p_s_i) 
+    (p_s_i f p_d_i) 
+    (p_s_i fi p<i) 
+    (p_s_i = p_s_i) 
+    (p_f_i < p<i) 
+    (p_f_i > p>i) 
+    (p_f_i d p_d_i) 
+    (p_f_i di p>i) 
+    (p_f_i o p_d_i) 
+    (p_f_i oi p>i) 
+    (p_f_i m p_s_i) 
+    (p_f_i mi p>i) 
+    (p_f_i s p_d_i) 
+    (p_f_i si p>i) 
+    (p_f_i f p_f_i) 
+    (p_f_i fi p_f_i) 
+    (p_f_i = p_f_i)))
+
+(defparameter $time-ppi-composition-table
+  '((p<p p<i p<i) 
+    (p<p p>i p<i p>i p_d_i p_s_i p_f_i) 
+    (p<p p_d_i p<i p_d_i p_s_i) 
+    (p<p p_s_i p<i) 
+    (p<p p_f_i p<i p_d_i p_s_i) 
+    (p>p p<i p<i p>i p_d_i p_s_i p_f_i) 
+    (p>p p>i p>i) 
+    (p>p p_d_i p>i p_d_i p_f_i) 
+    (p>p p_s_i p>i p_d_i p_f_i) 
+    (p>p p_f_i p>i) 
+    (p=p p<i p<i) 
+    (p=p p>i p>i) 
+    (p=p p_d_i p_d_i) 
+    (p=p p_s_i p_s_i) 
+    (p=p p_f_i p_f_i)))
+
+(defparameter $time-pip-composition-table
+  '((p<i i>p p<p p>p p=p) 
+    (p<i i<p p<p) 
+    (p<i i_di_p p<p) 
+    (p<i i_si_p p<p) 
+    (p<i i_fi_p p<p) 
+    (p>i i>p p>p) 
+    (p>i i<p p<p p>p p=p) 
+    (p>i i_di_p p>p) 
+    (p>i i_si_p p>p) 
+    (p>i i_fi_p p>p) 
+    (p_d_i i>p p>p) 
+    (p_d_i i<p p<p) 
+    (p_d_i i_di_p p<p p>p p=p) 
+    (p_d_i i_si_p p>p) 
+    (p_d_i i_fi_p p<p) 
+    (p_s_i i>p p>p) 
+    (p_s_i i<p p<p) 
+    (p_s_i i_di_p p<p) 
+    (p_s_i i_si_p p=p) 
+    (p_s_i i_fi_p p<p) 
+    (p_f_i i>p p>p) 
+    (p_f_i i<p p<p) 
+    (p_f_i i_di_p p>p) 
+    (p_f_i i_si_p p>p) 
+    (p_f_i i_fi_p p=p)))
+
+(defparameter $time-ipi-composition-table
+  '((i>p p<i < > d di o oi m mi s si f fi =) 
+    (i>p p>i >) 
+    (i>p p_d_i > d oi mi f) 
+    (i>p p_s_i > d oi mi f) 
+    (i>p p_f_i >) 
+    (i<p p<i <) 
+    (i<p p>i < > d di o oi m mi s si f fi =) 
+    (i<p p_d_i < d o m s) 
+    (i<p p_s_i <) 
+    (i<p p_f_i < d o m s) 
+    (i_di_p p<i < di o m fi) 
+    (i_di_p p>i > di oi mi si) 
+    (i_di_p p_d_i d di o oi s si f fi =) 
+    (i_di_p p_s_i di o fi) 
+    (i_di_p p_f_i di oi si) 
+    (i_si_p p<i < di o m fi) 
+    (i_si_p p>i >) 
+    (i_si_p p_d_i d oi f) 
+    (i_si_p p_s_i s si =) 
+    (i_si_p p_f_i mi) 
+    (i_fi_p p<i <) 
+    (i_fi_p p>i > di oi mi si) 
+    (i_fi_p p_d_i d o s) 
+    (i_fi_p p_s_i m) 
+    (i_fi_p p_f_i f fi =)))
+
+(defparameter $time-iip-composition-table
+  '((< i>p i>p i<p i_di_p i_si_p i_fi_p) 
+    (< i<p i<p) 
+    (< i_di_p i<p) 
+    (< i_si_p i<p) 
+    (< i_fi_p i<p) 
+    (> i>p i>p) 
+    (> i<p i>p i<p i_di_p i_si_p i_fi_p) 
+    (> i_di_p i>p) 
+    (> i_si_p i>p) 
+    (> i_fi_p i>p) 
+    (d i>p i>p) 
+    (d i<p i<p) 
+    (d i_di_p i>p i<p i_di_p i_si_p i_fi_p) 
+    (d i_si_p i>p) 
+    (d i_fi_p i<p) 
+    (di i>p i>p i_di_p i_si_p) 
+    (di i<p i<p i_di_p i_fi_p) 
+    (di i_di_p i_di_p) 
+    (di i_si_p i_di_p) 
+    (di i_fi_p i_di_p) 
+    (o i>p i>p i_di_p i_si_p) 
+    (o i<p i<p) 
+    (o i_di_p i<p i_di_p i_fi_p) 
+    (o i_si_p i_di_p) 
+    (o i_fi_p i<p) 
+    (oi i>p i>p) 
+    (oi i<p i<p i_di_p i_fi_p) 
+    (oi i_di_p 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) 
+    (m i_di_p i<p) 
+    (m i_si_p i_fi_p) 
+    (m i_fi_p i<p) 
+    (mi i>p i>p) 
+    (mi i<p i<p i_di_p i_fi_p) 
+    (mi i_di_p 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) 
+    (s i_di_p i<p i_di_p i_fi_p) 
+    (s i_si_p i_si_p) 
+    (s i_fi_p i<p) 
+    (si i>p i>p) 
+    (si i<p i<p i_di_p i_fi_p) 
+    (si i_di_p i_di_p) 
+    (si i_si_p i_si_p) 
+    (si i_fi_p i_di_p) 
+    (f i>p i>p) 
+    (f i<p i<p) 
+    (f i_di_p 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) 
+    (fi i_di_p i_di_p) 
+    (fi i_si_p i_di_p) 
+    (fi i_fi_p i_fi_p) 
+    (= i>p i>p) 
+    (= i<p i<p) 
+    (= i_di_p i_di_p) 
+    (= i_si_p i_si_p) 
+    (= i_fi_p i_fi_p)))
+
+(defparameter $time-ipp-composition-table
+  '((i>p p<p i>p i<p i_di_p i_si_p i_fi_p) 
+    (i>p p>p i>p) 
+    (i>p p=p i>p) 
+    (i<p p<p i<p) 
+    (i<p p>p i>p i<p i_di_p i_si_p i_fi_p) 
+    (i<p p=p i<p) 
+    (i_di_p p<p i<p i_di_p i_fi_p) 
+    (i_di_p p>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_di_p i_fi_p) 
+    (i_si_p p>p i>p) 
+    (i_si_p p=p i_si_p) 
+    (i_fi_p p<p i<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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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

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 <stickel@ai.sri.com>.
+
+(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