├── .gitignore ├── defs.lisp ├── Papers ├── interp-abduct-ai.pdf ├── stickel-pttp-jar.pdf ├── stickel-pttp-tcs.pdf ├── stickel-pttp-tr.pdf └── stickel-abduction-icsc88-amai.pdf ├── pttp.asd ├── README.md └── pttp-1i.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl 3 | -------------------------------------------------------------------------------- /defs.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Lisp -*- 2 | 3 | (defpackage pttp 4 | (:use :cl)) 5 | 6 | -------------------------------------------------------------------------------- /Papers/interp-abduct-ai.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slburson/PTTP/HEAD/Papers/interp-abduct-ai.pdf -------------------------------------------------------------------------------- /Papers/stickel-pttp-jar.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slburson/PTTP/HEAD/Papers/stickel-pttp-jar.pdf -------------------------------------------------------------------------------- /Papers/stickel-pttp-tcs.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slburson/PTTP/HEAD/Papers/stickel-pttp-tcs.pdf -------------------------------------------------------------------------------- /Papers/stickel-pttp-tr.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slburson/PTTP/HEAD/Papers/stickel-pttp-tr.pdf -------------------------------------------------------------------------------- /Papers/stickel-abduction-icsc88-amai.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slburson/PTTP/HEAD/Papers/stickel-abduction-icsc88-amai.pdf -------------------------------------------------------------------------------- /pttp.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Lisp -*- 2 | 3 | (defsystem pttp 4 | :components ((:file "defs") 5 | (:file "pttp-1i" :depends-on ("defs")))) 6 | 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Mark Stickel's PTTP 2 | =================== 3 | 4 | This is the Lisp implementation of the Prolog Technology Theorem Prover by the late Mark 5 | Stickel of SRI, with some minor changes: 6 | 7 | * I have converted it to portable ANSI Common Lisp. 8 | 9 | * In particular, the proof-printing feature now works in portable CL; it no longer 10 | requires Symbolics Common Lisp. 11 | 12 | * I have taken the liberty of doing some minor reformatting so the lines aren't longer 13 | than I like. 14 | 15 | For more information on PTTP see: http://www.ai.sri.com/~stickel/pttp.html (There are 16 | papers in PostScript format linked from this page; I have placed PDF versions in this 17 | repo under `Papers/`, since readers for bare PostScript are getting hard to find these 18 | days.) 19 | 20 | For copyright and license information, see the source file, `pttp-1i.lisp`. 21 | -------------------------------------------------------------------------------- /pttp-1i.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: PTTP; Base: 10. -*- 2 | 3 | ;;; Copyright (c) 1986 Mark E. Stickel, SRI International, Menlo Park, CA 94025 USA 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a 6 | ;;; copy of this software and associated documentation files (the "Software"), 7 | ;;; to deal in the Software without restriction, including without limitation 8 | ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | ;;; and/or sell copies of the Software, and to permit persons to whom the 10 | ;;; Software is furnished to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included 13 | ;;; in all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 17 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 18 | ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 19 | ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 20 | ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 21 | ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 22 | 23 | (in-package :pttp) 24 | 25 | (eval-when (:compile-toplevel :load-toplevel :execute) 26 | (setq *print-radix* nil)) 27 | 28 | (defvar float-internal-time-units-per-second (float internal-time-units-per-second)) 29 | 30 | (defvar and-connective '|,/2|) 31 | (defvar or-connective '\;/2) 32 | 33 | ;; dynamic variables used during compilation 34 | 35 | (eval-when (:compile-toplevel :load-toplevel :execute) 36 | (defvar name nil)) ; name of procedure being compiled 37 | (defvar arity) ; arity of procedure being compiled 38 | (defvar clause-numbers) ; association list of clauses and their numbers 39 | (defvar first-argument-type) ; the type of the first argument to the procedure 40 | (defvar traceable) ; compile-procedure option to compile code 41 | ; for tracing 42 | (defvar unbounded-search) ; compile-procedure option to not compile code 43 | ; for depth-bounded search 44 | (defvar unsafe-unification) ; compile-procedure option to not use the 45 | ; occurs check during unification 46 | (defvar incomplete-inference) ; compile-procedure option to compile 47 | ; ME reduction operations 48 | (defvar allow-repeated-goals) ; compile-procedure option to compile 49 | ; ME pruning operations 50 | (defvar trace-calls t) ; if nil, tracing will not be compiled 51 | ; regardless of :traceable option 52 | (defvar count-calls t) ; compile code to count successful unifications? 53 | (defvar recompile nil) ; recompile procedure even if clauses and 54 | ; parameters are the same 55 | (defvar print-clauses t) ; print input clauses 56 | (defvar print-compile-names t) ; print names of functions as they are compiled 57 | (defvar print-compile-times t) ; print compilation time 58 | 59 | ;; when variable names are included in the variable, 60 | ;; variables are represented by 61 | ;; (variable-level pointer-to-value . variable-name) for bound variables 62 | ;; and (variable-level nil . variable-name) for unbound variables 63 | ;; 64 | ;; when variable names are not included in the variable, 65 | ;; variables are represented by 66 | ;; (variable-level . pointer-to-value) for bound variables 67 | ;; and (variable-level . nil ) for unbound variables 68 | 69 | ;; this encoding assumes that integers will not be used as functors 70 | 71 | (eval-when (:compile-toplevel :load-toplevel :execute) 72 | (pushnew :include-name-in-variable *features*)) 73 | 74 | (defun new-variable (var-name var-level) 75 | #-include-name-in-variable (declare (ignore var-name)) 76 | (list* var-level nil #+include-name-in-variable var-name)) 77 | 78 | (defmacro variable-p (x) 79 | ;; x nonatomic 80 | `(integerp (car ,x))) 81 | 82 | (defmacro variable-level (x) 83 | `(car ,x)) 84 | 85 | (eval-when (:compile-toplevel :load-toplevel :execute) 86 | (defmacro variable-value (x) 87 | #+include-name-in-variable `(cadr ,x) 88 | #-include-name-in-variable `(cdr ,x))) 89 | 90 | (defmacro variable-name (x) 91 | #-include-name-in-variable (declare (ignore x)) 92 | #+include-name-in-variable `(cddr ,x) 93 | #-include-name-in-variable `'_) 94 | 95 | (defmacro dereference (x &key (if-constant t) (if-variable nil) (if-compound nil)) 96 | ;; dereferences x leaving result in x, returns t if result is atomic, nil if not 97 | (assert (symbolp x)) 98 | (let ((y (gensym))) 99 | `(do nil (nil) 100 | (cond ((atom ,x) (return ,if-constant)) 101 | ((variable-p ,x) 102 | (unless (let ((,y (variable-value ,x))) 103 | (when ,y (setq ,x ,y))) 104 | (return ,if-variable))) 105 | (t (return ,if-compound)))))) 106 | 107 | (defvar *trail-array* (make-array 10000)) 108 | 109 | (defvar *trail* 0) 110 | 111 | (defmacro trail-variable-p (var) 112 | `(< (variable-level ,var) !level!)) 113 | 114 | (defmacro bind-variable-to-term (var term trail?) 115 | ;; returns non-nil value (term is never nil) 116 | (assert (symbolp var)) 117 | (assert (member trail? '(:trail :dont-trail :maybe-trail))) 118 | (cond ((eq trail? :dont-trail) 119 | `(progn (setf (variable-value ,var) ,term) 120 | t)) 121 | ((eq trail? :trail) 122 | `(progn (setf (svref *trail-array* (incf *trail*)) ,var) 123 | (setf (variable-value ,var) ,term) 124 | t)) 125 | (t `(progn (if (trail-variable-p ,var) 126 | (setf (svref *trail-array* (incf *trail*)) ,var)) 127 | (setf (variable-value ,var) ,term) 128 | t)))) 129 | 130 | (defmacro undo-bindings nil 131 | ;; MUST RETURN NIL 132 | `(let ((trail *trail*)) 133 | (when (> trail !old-trail!) 134 | (do ((trail-array *trail-array*)) 135 | (nil) 136 | (setf (variable-value (svref trail-array trail)) nil) 137 | (when (= (decf trail) !old-trail!) 138 | (setq *trail* !old-trail!) 139 | (return nil)))))) 140 | 141 | (defmacro safe-bind-variable-to-compound (var term trail? undo?) 142 | ;; returns non-nil value if binding is successful, 143 | ;; undoes bindings on trail and returns nil if not successful 144 | (assert (symbolp term)) 145 | `(if (variable-occurs-in-terms-p ,var (cdr ,term)) 146 | ,(if undo? `(undo-bindings) nil) 147 | (bind-variable-to-term ,var ,term ,trail?))) 148 | 149 | (defmacro pcall (term (vars unbound) level continuation) 150 | (stack-list-new-variables 151 | unbound 152 | (let* ((formals (head-locs (cdr term) 'a)) 153 | (actuals (mapcar #'(lambda (x) (term-constructor x vars)) (cdr term))) 154 | (decls (mapcan #'(lambda (x y) 155 | (if (or (atom y) (eq (car y) 'quote)) 156 | nil 157 | (list (list x y)))) 158 | formals actuals)) 159 | (args (mapcar #'(lambda (x y) 160 | (if (or (atom y) (eq (car y) 'quote)) 161 | y x)) 162 | formals actuals))) 163 | (if decls 164 | `(let ,decls (,(car term) ,@args ,level ,continuation)) 165 | `(,(car term) ,@args ,level ,continuation))))) 166 | 167 | (defvar *ncalls* 0) ; counter for number of inferences 168 | 169 | (eval-when (:compile-toplevel :load-toplevel :execute) 170 | (defun wrap-count-calls (form) 171 | (if (and count-calls (not (eq name 'query/0))) 172 | `(progn (incf *ncalls*) ,form) 173 | form))) 174 | 175 | (eval-when (:compile-toplevel :load-toplevel :execute) 176 | (defun head-locs (terms &optional (name 'arg) nth) 177 | (let* ((prop (if nth 'nth-arguments 'arguments)) 178 | (n (if (numberp terms) terms (length terms))) 179 | (l (get name prop))) 180 | (or (cdr (assoc n l)) 181 | (let (w) 182 | (dotimes (i n) 183 | (push (if nth 184 | `(nth ,(1+ i) ,name) 185 | (intern (concatenate 'string "!" (symbol-name name) 186 | (princ-to-string (1+ i)) "!") 187 | 'pttp)) 188 | w)) 189 | (setq w (nreverse w)) 190 | (setf (get name prop) (cons (cons n w) l)) 191 | w))))) 192 | 193 | ;; UNIFICATION 194 | 195 | (defun ground-term-p (term) 196 | (dereference term 197 | :if-constant t 198 | :if-variable nil 199 | :if-compound (ground-terms-p (cdr term)))) 200 | 201 | (defun ground-terms-p (terms) 202 | (do ((l terms (cdr l)) (term)) 203 | ((null l) t) 204 | (setq term (car l)) 205 | (dereference term 206 | :if-constant nil 207 | :if-variable (return-from ground-terms-p nil) 208 | :if-compound (cond ((null (cdr l)) (setq l term)) 209 | ((not (ground-terms-p (cdr term))) 210 | (return-from ground-terms-p nil)))))) 211 | 212 | (defun variable-occurs-in-term-p (var term) 213 | ;; works for both external (e.g., X) and internal (i.e., (level 214 | ;; pointer-or-nil . name)) variable representations 215 | ;; i.e., we check (eq var term) in the constant as well as variable case 216 | ;; it would be slightly more efficient to handle only the internal 217 | ;; representation when running Prolog programs 218 | (dereference term 219 | :if-constant (eq var term) 220 | :if-variable (eq var term) 221 | :if-compound (variable-occurs-in-terms-p var (cdr term)))) 222 | 223 | (defun variable-occurs-in-terms-p (var terms) 224 | ;; works for both external (e.g., X) and internal (i.e., (level 225 | ;; pointer-or-nil . name)) variable representations 226 | ;; i.e., we check (eq var term) in the constant as well as variable case 227 | ;; it would be slightly more efficient to handle only the internal 228 | ;; representation when running Prolog programs 229 | (do ((l terms (cdr l)) (term)) 230 | ((null l) nil) 231 | (setq term (car l)) 232 | (dereference term 233 | :if-constant (when (eq var term) 234 | (return-from variable-occurs-in-terms-p t)) 235 | :if-variable (when (eq var term) 236 | (return-from variable-occurs-in-terms-p t)) 237 | :if-compound (cond ((null (cdr l)) (setq l term)) 238 | ((variable-occurs-in-terms-p var (cdr term)) 239 | (return-from variable-occurs-in-terms-p t)))))) 240 | 241 | (defmacro unify-macro (unify-list-fun trail? safely?) 242 | ;; undoes bindings on trail and returns nil if not successful 243 | `(dereference t1 244 | :if-constant 245 | (dereference t2 246 | :if-constant (or (eql t1 t2) (undo-bindings)) 247 | :if-variable (bind-variable-to-term t2 t1 ,trail?) 248 | :if-compound (undo-bindings)) 249 | :if-variable 250 | (dereference t2 251 | :if-constant (bind-variable-to-term t1 t2 ,trail?) 252 | :if-variable (or (eq t1 t2) 253 | (if (<= (variable-level t1) 254 | (variable-level t2)) 255 | (bind-variable-to-term t2 t1 ,trail?) 256 | (bind-variable-to-term t1 t2 ,trail?))) 257 | :if-compound ,(if safely? 258 | `(safe-bind-variable-to-compound 259 | t1 t2 ,trail? t) 260 | `(bind-variable-to-term t1 t2 ,trail?))) 261 | :if-compound 262 | (dereference t2 263 | :if-constant (undo-bindings) 264 | :if-variable ,(if safely? 265 | `(safe-bind-variable-to-compound 266 | t2 t1 ,trail? t) 267 | `(bind-variable-to-term t2 t1 ,trail?)) 268 | :if-compound (or (eq t1 t2) 269 | (if (eq (car t1) (car t2)) 270 | (let ((l1 (cdr t1)) (l2 (cdr t2))) 271 | (unify-list-macro ,unify-list-fun 272 | ,trail? ,safely?)) 273 | (undo-bindings)))))) 274 | 275 | (defmacro unify-list-macro (unify-list-fun trail? safely?) 276 | ;; undoes bindings on trail and returns nil if not successful 277 | `(block unify-list 278 | (do ((t1) (t2)) 279 | ((null l1) (return t)) 280 | (setq t1 (car l1)) (setq l1 (cdr l1)) 281 | (setq t2 (car l2)) (setq l2 (cdr l2)) 282 | (dereference t1 283 | :if-constant 284 | (dereference t2 285 | :if-constant (unless (eql t1 t2) 286 | (return-from unify-list (undo-bindings))) 287 | :if-variable (bind-variable-to-term t2 t1 ,trail?) 288 | :if-compound (return-from unify-list (undo-bindings))) 289 | :if-variable 290 | (dereference t2 291 | :if-constant (bind-variable-to-term t1 t2 ,trail?) 292 | :if-variable 293 | (or (eq t1 t2) 294 | (if (<= (variable-level t1) 295 | (variable-level t2)) 296 | (bind-variable-to-term t2 t1 ,trail?) 297 | (bind-variable-to-term t1 t2 ,trail?))) 298 | :if-compound 299 | ,(if safely? 300 | `(unless (safe-bind-variable-to-compound 301 | t1 t2 ,trail? t) 302 | (return-from unify-list nil)) 303 | `(bind-variable-to-term t1 t2 ,trail?))) 304 | :if-compound 305 | (dereference t2 306 | :if-constant (return-from unify-list (undo-bindings)) 307 | :if-variable 308 | ,(if safely? 309 | `(unless (safe-bind-variable-to-compound 310 | t2 t1 ,trail? t) 311 | (return-from unify-list nil)) 312 | `(bind-variable-to-term t2 t1 ,trail?)) 313 | :if-compound 314 | (cond ((eq t1 t2)) 315 | ((not (eq (car t1) (car t2))) 316 | (return-from unify-list 317 | (undo-bindings))) 318 | ((null l1) 319 | (setq l1 (cdr t1)) (setq l2 (cdr t2))) 320 | ((not ,(if (eq trail? :maybe-trail) 321 | `(,unify-list-fun (cdr t1) (cdr t2) 322 | !old-trail! !level!) 323 | `(,unify-list-fun (cdr t1) (cdr t2) 324 | !old-trail!))) 325 | (return-from unify-list nil)))))))) 326 | 327 | (defun always-trails-unify (t1 t2 !old-trail!) 328 | (unify-macro always-trails-unify-list :trail t)) 329 | 330 | (defun always-trails-unify-list (l1 l2 !old-trail!) 331 | (unify-list-macro always-trails-unify-list :trail t)) 332 | 333 | (defun maybe-trails-unify (t1 t2 !old-trail! !level!) 334 | (unify-macro maybe-trails-unify-list :maybe-trail t)) 335 | 336 | (defun maybe-trails-unify-list (l1 l2 !old-trail! !level!) 337 | (unify-list-macro maybe-trails-unify-list :maybe-trail t)) 338 | 339 | (defun unsafe-always-trails-unify (t1 t2 !old-trail!) 340 | (unify-macro unsafe-always-trails-unify-list :trail nil)) 341 | 342 | (defun unsafe-always-trails-unify-list (l1 l2 !old-trail!) 343 | (unify-list-macro unsafe-always-trails-unify-list :trail nil)) 344 | 345 | (defun unsafe-maybe-trails-unify (t1 t2 !old-trail! !level!) 346 | (unify-macro unsafe-maybe-trails-unify-list :maybe-trail nil)) 347 | 348 | (defun unsafe-maybe-trails-unify-list (l1 l2 !old-trail! !level!) 349 | (unify-list-macro unsafe-maybe-trails-unify-list :maybe-trail nil)) 350 | 351 | (defmacro unify-argument-with-constant (actual formal &key trail-is-nil) 352 | (assert (or (atom formal) (eq (car formal) 'quote) (eq (car formal) 'nth))) 353 | `(let ((!temp! ,actual)) 354 | (dereference !temp! 355 | :if-constant ,(if trail-is-nil 356 | `(eql !temp! ,formal) 357 | `(or (eql !temp! ,formal) (undo-bindings))) 358 | :if-variable (bind-variable-to-term !temp! ,formal :trail) 359 | :if-compound ,(if trail-is-nil nil `(undo-bindings))))) 360 | 361 | (defmacro unify-argument-with-compound (actual formal &key trail-is-nil unsafe) 362 | (assert (symbolp formal)) 363 | `(let ((!temp! ,actual)) 364 | (dereference !temp! 365 | :if-constant ,(if trail-is-nil nil `(undo-bindings)) 366 | :if-variable ,(if unsafe 367 | `(bind-variable-to-term !temp! ,formal :trail) 368 | `(safe-bind-variable-to-compound 369 | !temp! ,formal :trail ,(not trail-is-nil))) 370 | :if-compound (or (eq !temp! ,formal) 371 | (if (eq (car !temp!) (car ,formal)) 372 | ,(if unsafe 373 | `(unsafe-maybe-trails-unify-list 374 | (cdr !temp!) (cdr ,formal) 375 | !old-trail! !level!) 376 | `(maybe-trails-unify-list 377 | (cdr !temp!) (cdr ,formal) 378 | !old-trail! !level!)) 379 | ,(if trail-is-nil nil `(undo-bindings))))))) 380 | 381 | (defmacro identical-to-constant (term constant) 382 | (assert (symbolp constant)) 383 | (if (symbolp term) 384 | `(dereference ,term 385 | :if-constant (eql ,term ,constant) 386 | :if-variable nil 387 | :if-compound nil) 388 | (let ((temp (gensym))) 389 | `(let ((,temp ,term)) 390 | (identical-to-constant ,temp ,constant))))) 391 | 392 | (defmacro identical-to-variable (term variable) 393 | (assert (symbolp variable)) 394 | (if (symbolp term) 395 | `(dereference ,term 396 | :if-constant nil 397 | :if-variable (eq ,term ,variable) 398 | :if-compound nil) 399 | (let ((temp (gensym))) 400 | `(let ((,temp ,term)) 401 | (identical-to-variable ,temp ,variable))))) 402 | 403 | (defmacro identical-to-compound (term compound) 404 | (assert (symbolp compound)) 405 | (if (symbolp term) 406 | `(dereference ,term 407 | :if-constant nil 408 | :if-variable nil 409 | :if-compound (or (eq ,term ,compound) 410 | (and (eq (car ,term) (car ,compound)) 411 | (identical-list (cdr ,term) (cdr ,compound))))) 412 | (let ((temp (gensym))) 413 | `(let ((,temp ,term)) 414 | (identical-to-compound ,temp ,compound))))) 415 | 416 | (defmacro identical (t1 t2) 417 | (if (symbolp t2) 418 | `(dereference ,t2 419 | :if-constant (identical-to-constant ,t1 ,t2) 420 | :if-variable (identical-to-variable ,t1 ,t2) 421 | :if-compound (identical-to-compound ,t1 ,t2)) 422 | (let ((temp (gensym))) 423 | `(let ((,temp ,t2)) 424 | (identical ,t1 ,temp))))) 425 | 426 | (defmacro identical-list (l1 l2) 427 | `(block identical-list 428 | (do ((l1 ,l1) (l2 ,l2) (t1) (t2)) 429 | ((null l1) (return t)) 430 | (setq t1 (car l1)) (setq l1 (cdr l1)) 431 | (setq t2 (car l2)) (setq l2 (cdr l2)) 432 | (dereference t2 433 | :if-constant (unless (identical-to-constant t1 t2) 434 | (return-from identical-list nil)) 435 | :if-variable (unless (identical-to-variable t1 t2) 436 | (return-from identical-list nil)) 437 | :if-compound 438 | (dereference t1 439 | :if-constant (return-from identical-list nil) 440 | :if-variable (return-from identical-list nil) 441 | :if-compound 442 | (cond ((eq t1 t2)) 443 | ((not (eq (car t1) (car t2))) 444 | (return-from identical-list nil)) 445 | ((null l1) 446 | (setq l1 (cdr t1)) 447 | (setq l2 (cdr t2))) 448 | ((not (identical-list-fun (cdr t1) (cdr t2))) 449 | (return-from identical-list nil)))))))) 450 | 451 | (defun identical-list-fun (l1 l2) 452 | (identical-list l1 l2)) 453 | 454 | ;; SUPPORT FOR OUTPUT AND TRACING 455 | 456 | (eval-when (:compile-toplevel :load-toplevel :execute) 457 | (defmacro specifier (x) 458 | `(get ,x 'specifier)) 459 | (defmacro precedence (x) 460 | `(get ,x 'precedence))) 461 | 462 | (defvar *writing* t) ; use prefix, postfix, infix operators during printing 463 | 464 | (defun function-case (x) 465 | (string-downcase x)) 466 | 467 | (defun constant-case (x) 468 | (string-downcase x)) 469 | 470 | (defun variable-case (x) 471 | (string-capitalize x)) 472 | 473 | (defun display-term (term) 474 | (let ((*writing* nil)) 475 | (write-term term))) 476 | 477 | (defun write-term (term) 478 | (dereference term) 479 | (cond ((atom term) (princ (if (symbolp term) (constant-case term) term))) 480 | ((variable-p term) (princ (variable-case (variable-name term))) (princ "_") (princ (variable-level term))) 481 | (t (write-functor-and-arguments (car term) (cdr term)))) 482 | term) 483 | 484 | (defun parenthesize-argument (arg prec rel) 485 | (dereference arg 486 | :if-constant nil 487 | :if-variable nil 488 | :if-compound (let ((argprec (precedence (car arg)))) 489 | (and argprec (funcall rel prec argprec))))) 490 | 491 | (defun write-functor-and-arguments (fn args &aux spec prec) 492 | (cond ((eq fn 'cons/2) 493 | (princ "[") 494 | (write-term (car args)) 495 | (do ((x (cadr args) (caddr x))) 496 | (nil) 497 | (dereference x) 498 | (cond ((eq x '|[]|) (princ "]") (return)) 499 | ((and (not (atom x)) (eq (car x) 'cons/2)) 500 | (princ ",") 501 | (write-term (cadr x))) 502 | (t 503 | (princ "|") 504 | (write-term x) 505 | (princ "]") 506 | (return))))) 507 | ((and *writing* (setq spec (specifier fn))) 508 | (setq prec (precedence fn)) 509 | (case spec 510 | ((fx fy) 511 | (princ (function-case (functor-name fn))) 512 | (princ " ") 513 | (cond ((parenthesize-argument (car args) prec (if (eq spec 'fx) #'<= #'<)) 514 | (princ "(") (write-term (car args)) (princ ")")) 515 | (t (write-term (car args))))) 516 | ((xf yf) 517 | (cond ((parenthesize-argument (car args) prec (if (eq spec 'fx) #'<= #'<)) 518 | (princ "(") (write-term (car args)) (princ ")")) 519 | (t (write-term (car args)))) 520 | (princ " ") 521 | (princ (function-case (functor-name fn)))) 522 | ((xfx xfy yfx yfy) 523 | (cond ((parenthesize-argument (car args) prec (if (member spec '(xfx xfy)) 524 | #'<= #'<)) 525 | (princ "(") (write-term (car args)) (princ ")")) 526 | (t (write-term (car args)))) 527 | (princ " ") 528 | (princ (function-case (functor-name fn))) 529 | (princ " ") 530 | (cond ((parenthesize-argument (cadr args) prec (if (member spec '(xfx yfx)) 531 | #'<= #'<)) 532 | (princ "(") (write-term (cadr args)) (princ ")")) 533 | (t (write-term (cadr args))))))) 534 | (t (princ (function-case (functor-name fn))) 535 | (when args 536 | (princ "(") 537 | (cond ((parenthesize-argument (car args) 0 #'<) 538 | (princ "(") (write-term (car args)) (princ ")")) 539 | (t (write-term (car args)))) 540 | (dolist (term (cdr args)) 541 | (princ ",") 542 | (cond ((parenthesize-argument term 0 #'<) 543 | (princ "(") (write-term term) (princ ")")) 544 | (t (write-term term)))) 545 | (princ ")")))) 546 | nil) 547 | 548 | (defun write-functor-and-arguments* (fn &rest args) 549 | (write-functor-and-arguments fn args)) 550 | 551 | (defun write-clause (clause &optional number variables) 552 | (let ((goalp (and (eq (car clause) '<-/2) (equal (cadr clause) '(query/0))))) 553 | (fresh-line) 554 | (when goalp (princ " ----------------") (terpri)) 555 | (when number 556 | (if (consp number) 557 | (format t "~3D~A. " (car number) (cdr number)) 558 | (format t "~3D. " number))) 559 | (if goalp 560 | (let (quantified) 561 | (write-term (cadr clause)) 562 | (princ " <- ") 563 | (dolist (v variables) 564 | (when (variable-occurs-in-term-p v (caddr clause)) 565 | (princ "(") (write-term v) (princ ")") (setq quantified t))) 566 | (when quantified (princ " ")) 567 | (write-term (caddr clause))) 568 | (let (quantified) 569 | (dolist (v variables) 570 | (when (variable-occurs-in-term-p v clause) 571 | (princ "(") (write-term v) (princ ")") (setq quantified t))) 572 | (when quantified (princ " ")) 573 | (write-term clause))) 574 | (princ "."))) 575 | 576 | (defvar *tracing* nil) 577 | (defvar *spy-points* nil) 578 | 579 | (defmacro trace-call-fail (nm form) 580 | (let ((args (head-locs (get nm 'arity)))) 581 | `(progn 582 | (when (or *tracing* (member ',nm *spy-points*)) 583 | (format t "~&~VT~4D CALL " (+ !level! !level! -1) !level!) 584 | (write-functor-and-arguments* ',nm . ,args)) 585 | ,form 586 | (when (or *tracing* (member ',nm *spy-points*)) 587 | (format t "~&~VT~4D FAIL " (+ !level! !level! -1) !level!) 588 | (write-functor-and-arguments* ',nm . ,args))))) 589 | 590 | (defmacro trace-exit-redo (nm form) 591 | (let ((args (head-locs (get nm 'arity)))) 592 | `(progn (when (or *tracing* (member ',nm *spy-points*)) 593 | (format t "~&~VT~4D EXIT " (+ !level! !level! -1) !level!) 594 | (write-functor-and-arguments* ',nm . ,args)) 595 | ,form 596 | (when (or *tracing* (member ',nm *spy-points*)) 597 | (format t "~&~VT~4D REDO " (+ !level! !level! -1) !level!) 598 | (write-functor-and-arguments* ',nm . ,args))))) 599 | 600 | (defun wrap-call-fail-trace (form) 601 | (if traceable `(trace-call-fail ,name ,form) form)) 602 | 603 | (eval-when (:compile-toplevel :load-toplevel :execute) 604 | (defun wrap-exit-redo-trace (form) 605 | (if traceable `(trace-exit-redo ,name ,form) form))) 606 | 607 | ;; CONSECUTIVELY BOUNDED DEPTH-FIRST SEARCH 608 | 609 | (defvar *remaining-depth* 1000000) ; effectively infinite values so that depth- 610 | (defvar *prev-depth-increment* 1000001) ; bounded code will run outside of search calls 611 | (defvar *minus-next-depth-increment* -1000) 612 | 613 | (defvar *old-remaining-depths* nil) 614 | (defvar *old-prev-depth-increments* nil) 615 | (defvar *old-minus-next-depth-increments* nil) 616 | 617 | ;; search is a Prolog predicate which takes 618 | ;; goal argument so that the user does not have to insert 619 | ;; end-search calls between the goals and additional 620 | ;; code to do something with, e.g., print, each solution 621 | 622 | (defvar *trace-search* t) ; print a message when starting search on each level, etc. 623 | (defvar *trace-search-calls* t) ; include number of inferences in the message 624 | (defvar *trace-search-time*) ; time spent printing search messages to be excluded 625 | ; from execution time 626 | 627 | (defmacro trace-search (&rest args) 628 | `(when *trace-search* 629 | (let ((start-time (get-internal-run-time))) 630 | (fresh-line) 631 | (when *trace-search-calls* 632 | (format t "~11:D inferences so far. " *ncalls*)) 633 | (format t ,@args) 634 | (incf *trace-search-time* (- (get-internal-run-time) start-time))))) 635 | 636 | (defun begin-search (maximum-depth minimum-depth default-depth-increment 637 | !level! !continuation!) 638 | (let ((*old-remaining-depths* (cons *remaining-depth* *old-remaining-depths*)) 639 | (*old-prev-depth-increments* (cons *prev-depth-increment* 640 | *old-prev-depth-increments*)) 641 | (*old-minus-next-depth-increments* (cons *minus-next-depth-increment* 642 | *old-minus-next-depth-increments*))) 643 | (let (*remaining-depth* *prev-depth-increment* *minus-next-depth-increment* cut) 644 | (dereference maximum-depth) (if (null maximum-depth) (setq maximum-depth 1000000)) 645 | (dereference minimum-depth) (if (null minimum-depth) (setq minimum-depth 0)) 646 | (dereference default-depth-increment) (if (null default-depth-increment) 647 | (setq default-depth-increment 1)) 648 | (setq *remaining-depth* minimum-depth) 649 | (setq *prev-depth-increment* (1+ minimum-depth)) 650 | (do nil (nil) 651 | (when (> *remaining-depth* maximum-depth) 652 | (trace-search "Search ended, maximum depth reached. ") (return nil)) 653 | (trace-search "Start searching with ~:[no subgoals~;at most ~2D subgoal~:P~]. " 654 | (> *remaining-depth* 0) *remaining-depth*) 655 | (setq *minus-next-depth-increment* -1000) 656 | (setq cut t) 657 | (unwind-protect 658 | (progn (funcall !continuation! !level!) (setq cut nil)) 659 | (when cut (trace-search "Search ended by cut. "))) 660 | (let ((next-depth-increment (- *minus-next-depth-increment*))) 661 | (when (= next-depth-increment 1000) 662 | (trace-search "Search ended, no more inferences possible. ") 663 | (return nil)) 664 | (setq next-depth-increment (max next-depth-increment default-depth-increment)) 665 | (incf *remaining-depth* next-depth-increment) 666 | (setq *prev-depth-increment* next-depth-increment)))))) 667 | 668 | (defmacro end-search (form) 669 | ;; executes form only for solutions that were not discovered in a previous 670 | ;; search with lower depth bound 671 | `(if (< *remaining-depth* *prev-depth-increment*) 672 | (let* ((*remaining-depth* (car *old-remaining-depths*)) 673 | (*prev-depth-increment* (car *old-prev-depth-increments*)) 674 | (*minus-next-depth-increment* (car *old-minus-next-depth-increments*)) 675 | (*old-remaining-depths* (cdr *old-remaining-depths*)) 676 | (*old-prev-depth-increments* (cdr *old-prev-depth-increments*)) 677 | (*old-minus-next-depth-increments* (cdr *old-minus-next-depth-increments*))) 678 | ,form))) 679 | 680 | (defmacro with-n-subgoals (n form) 681 | `(let ((*remaining-depth* (- *remaining-depth* ,n))) 682 | (cond ((minusp *remaining-depth*) 683 | (if (> *remaining-depth* *minus-next-depth-increment*) 684 | (setq *minus-next-depth-increment* *remaining-depth*)) 685 | nil) 686 | (t ,form)))) 687 | 688 | (defun wrap-depth-test (form clause-body) 689 | (if unbounded-search 690 | form 691 | (let ((n (clause-body-length clause-body T))) 692 | (if (> n 0) 693 | `(with-n-subgoals ,n ,form) 694 | form)))) 695 | 696 | (defun not-solvable (!arg1! !arg2! !level! !continuation! &aux (!old-trail! *trail*)) 697 | ;; !arg2! specifies depth of search 698 | (incf !level!) 699 | (trace-call-fail 700 | not/2 701 | (dereference !arg1! 702 | :if-variable (error "NOT was given non-compound argument ~A" !arg1!) 703 | :if-constant (error "NOT was given non-compound argument ~A" !arg1!) 704 | :if-compound 705 | (if (ground-term-p !arg1!) 706 | (let ((*trace-search* (and *tracing* *trace-search*))) 707 | (begin-search 708 | !arg2! !arg2! nil !level! 709 | #'(lambda (lev) 710 | #+LispM (declare (sys:downward-function)) 711 | (apply (car !arg1!) 712 | (append (cdr !arg1!) ; inefficient 713 | (list lev 714 | #'(lambda (lev) 715 | #+LispM 716 | (declare (sys:downward-function)) 717 | (declare (ignore lev)) 718 | (undo-bindings) 719 | (return-from not-solvable nil))))))) 720 | (trace-exit-redo not/2 (funcall !continuation! !level!))) 721 | (error "NOT was given non-ground argument ~A" !arg1!))))) 722 | 723 | ;; MODEL-ELIMINATION REDUCTION RULE 724 | 725 | (defun ancestors-name (nm) 726 | (or (get nm 'ancestors) 727 | (let ((w (intern (concatenate 'string "*" (symbol-name nm) "-ANCESTORS*") 'pttp))) 728 | (setf (get nm 'ancestors) w) 729 | w))) 730 | 731 | (defun wrap-push-ancestor (form) 732 | (if (or (not allow-repeated-goals) (not incomplete-inference)) 733 | (let ((nname (ancestors-name name))) 734 | (if (= arity 0) 735 | `(let ((,nname t)) 736 | ,form) 737 | `(let ((,nname (cons ,(cond ((= arity 0) t) 738 | ((= arity 1) '!arg1!) 739 | (t '!args!)) 740 | ,nname))) 741 | ,form))) 742 | form)) 743 | 744 | (defun wrap-pop-ancestor (form) 745 | (if (or (not allow-repeated-goals) (not incomplete-inference)) 746 | (let ((nname (ancestors-name name))) 747 | (if (= arity 0) 748 | `(let ((,nname nil)) 749 | ,form) 750 | `(let ((,nname (cdr ,nname))) 751 | ,form))) 752 | form)) 753 | 754 | (defmacro reduce-by-ancestor (arity type) 755 | ;; must recompile this and its calls to change counting and tracing 756 | (let ((count-calls t) (traceable nil)) 757 | `(dolist (!ancestor! !ancestors!) 758 | (when ,(cond ((eq type :constant-first-argument) 759 | (if (= arity 1) 760 | `(unify-argument-with-constant !ancestor! !arg1! :trail-is-nil t) 761 | `(and (unify-argument-with-constant 762 | (car !ancestor!) !arg1! :trail-is-nil t) 763 | ,(if (= arity 2) 764 | `(always-trails-unify-list 765 | (cdr !ancestor!) (cdr !args!) !old-trail!) 766 | `(always-trails-unify-list 767 | (cdr !ancestor!) (cdr !args!) !old-trail!))))) 768 | ((eq type :variable-first-argument) 769 | (if (= arity 1) 770 | `(always-trails-unify !ancestor! !arg1! !old-trail!) 771 | `(always-trails-unify-list !ancestor! !args! !old-trail!))) 772 | ((eq type :compound-first-argument) 773 | (if (= arity 1) 774 | `(unify-argument-with-compound !ancestor! !arg1! :trail-is-nil t) 775 | `(and (unify-argument-with-compound 776 | (car !ancestor!) !arg1! :trail-is-nil t) 777 | ,(if (= arity 2) 778 | `(always-trails-unify-list 779 | (cdr !ancestor!) (cdr !args!) !old-trail!) 780 | `(always-trails-unify-list 781 | (cdr !ancestor!) (cdr !args!) !old-trail!))))) 782 | (t (error "Unrecognized first argument type ~A" type))) 783 | ,(wrap-count-calls (wrap-exit-redo-trace `(funcall !continuation! !level!))) 784 | (if (= *trail* !old-trail!) 785 | (return t) 786 | (undo-bindings)))))) 787 | 788 | (defun reduce-by-ancestor-for-constant-first-argument/1 (!ancestors! !arg1! !old-trail! 789 | !level! !continuation!) 790 | (reduce-by-ancestor 1 :constant-first-argument)) 791 | 792 | (defun reduce-by-ancestor-for-variable-first-argument/1 (!ancestors! !arg1! !old-trail! 793 | !level! !continuation!) 794 | (reduce-by-ancestor 1 :variable-first-argument)) 795 | 796 | (defun reduce-by-ancestor-for-compound-first-argument/1 (!ancestors! !arg1! !old-trail! 797 | !level! !continuation!) 798 | (reduce-by-ancestor 1 :compound-first-argument)) 799 | 800 | (defun reduce-by-ancestor-for-constant-first-argument/2 (!ancestors! !arg1! !args! 801 | !old-trail! !level! 802 | !continuation!) 803 | (reduce-by-ancestor 2 :constant-first-argument)) 804 | 805 | (defun reduce-by-ancestor-for-variable-first-argument/2 (!ancestors! !args! !old-trail! 806 | !level! !continuation!) 807 | (reduce-by-ancestor 2 :variable-first-argument)) 808 | 809 | (defun reduce-by-ancestor-for-compound-first-argument/2 (!ancestors! !arg1! !args! 810 | !old-trail! !level! 811 | !continuation!) 812 | (reduce-by-ancestor 2 :compound-first-argument)) 813 | 814 | (defun reduce-by-ancestor-for-constant-first-argument/3 (!ancestors! !arg1! !args! 815 | !old-trail! !level! 816 | !continuation!) 817 | (reduce-by-ancestor 3 :constant-first-argument)) 818 | 819 | (defun reduce-by-ancestor-for-variable-first-argument/3 (!ancestors! !args! !old-trail! 820 | !level! !continuation!) 821 | (reduce-by-ancestor 3 :variable-first-argument)) 822 | 823 | (defun reduce-by-ancestor-for-compound-first-argument/3 (!ancestors! !arg1! !args! 824 | !old-trail! !level! 825 | !continuation!) 826 | (reduce-by-ancestor 3 :compound-first-argument)) 827 | 828 | (defun reduce-by-ancestor-for-constant-first-argument/4+ (!ancestors! !arg1! !args! 829 | !old-trail! !level! 830 | !continuation!) 831 | (reduce-by-ancestor 4 :constant-first-argument)) 832 | 833 | (defun reduce-by-ancestor-for-variable-first-argument/4+ (!ancestors! !args! !old-trail! 834 | !level! !continuation!) 835 | (reduce-by-ancestor 4 :variable-first-argument)) 836 | 837 | (defun reduce-by-ancestor-for-compound-first-argument/4+ (!ancestors! !arg1! !args! 838 | !old-trail! !level! 839 | !continuation!) 840 | (reduce-by-ancestor 4 :compound-first-argument)) 841 | 842 | (defun reduce-by-ancestor-call-fun (arity type) 843 | (case arity 844 | (1 (case type 845 | (:constant-first-argument 'reduce-by-ancestor-for-constant-first-argument/1) 846 | (:variable-first-argument 'reduce-by-ancestor-for-variable-first-argument/1) 847 | (:compound-first-argument 'reduce-by-ancestor-for-compound-first-argument/1))) 848 | (2 (case type 849 | (:constant-first-argument 'reduce-by-ancestor-for-constant-first-argument/2) 850 | (:variable-first-argument 'reduce-by-ancestor-for-variable-first-argument/2) 851 | (:compound-first-argument 'reduce-by-ancestor-for-compound-first-argument/2))) 852 | (3 (case type 853 | (:constant-first-argument 'reduce-by-ancestor-for-constant-first-argument/3) 854 | (:variable-first-argument 'reduce-by-ancestor-for-variable-first-argument/3) 855 | (:compound-first-argument 'reduce-by-ancestor-for-compound-first-argument/3))) 856 | (t (case type 857 | (:constant-first-argument 'reduce-by-ancestor-for-constant-first-argument/4+) 858 | (:variable-first-argument 'reduce-by-ancestor-for-variable-first-argument/4+) 859 | (:compound-first-argument 'reduce-by-ancestor-for-compound-first-argument/4+))))) 860 | 861 | (defun reduce-by-ancestor-call (name arity type) 862 | (let ((ancestors (ancestors-name (negated-functor name)))) 863 | (if (= arity 0) 864 | `(when ,ancestors 865 | ,(wrap-count-calls (wrap-exit-redo-trace `(progn 866 | (funcall !continuation! !level!) 867 | (return-from ,name nil))))) 868 | `(when ,ancestors 869 | (,(reduce-by-ancestor-call-fun arity type) 870 | ,ancestors 871 | ,@(cond ((= arity 0) nil) 872 | ((= arity 1) `(!arg1!)) 873 | (t (if (eq type :variable-first-argument) 874 | `(!args!) `(!arg1! !args!)))) 875 | !old-trail! 876 | !level! 877 | !continuation!))))) 878 | 879 | ;; MODEL ELIMINATION PRUNING 880 | 881 | (defmacro identical-to-ancestor (arity type) 882 | (let ((temp (cond ((= arity 2) `(identical (cadr !ancestor!) !arg2!)) 883 | ((= arity 3) `(and (identical (cadr !ancestor!) !arg2!) 884 | (identical (caddr !ancestor!) !arg3!))) 885 | ((>= arity 4) `(identical-list (cdr !ancestor!) (cdr !args!)))))) 886 | `(dolist (!ancestor! !ancestors!) 887 | (when ,(cond ((eq type :constant-first-argument) 888 | (if (= arity 1) 889 | `(identical-to-constant !ancestor! !arg1!) 890 | `(and (identical-to-constant (car !ancestor!) !arg1!) ,temp))) 891 | ((eq type :variable-first-argument) 892 | (if (= arity 1) 893 | `(identical-to-variable !ancestor! !arg1!) 894 | `(and (identical-to-variable (car !ancestor!) !arg1!) ,temp))) 895 | ((eq type :compound-first-argument) 896 | (if (= arity 1) 897 | `(identical-to-compound !ancestor! !arg1!) 898 | `(and (identical-to-compound (car !ancestor!) !arg1!) ,temp))) 899 | (t (error "Unrecognized first argument type ~A" type))) 900 | (return t))))) 901 | 902 | (defun identical-to-ancestor-for-constant-first-argument/1 (!ancestors! !arg1!) 903 | (identical-to-ancestor 1 :constant-first-argument)) 904 | 905 | (defun identical-to-ancestor-for-variable-first-argument/1 (!ancestors! !arg1!) 906 | (identical-to-ancestor 1 :variable-first-argument)) 907 | 908 | (defun identical-to-ancestor-for-compound-first-argument/1 (!ancestors! !arg1!) 909 | (identical-to-ancestor 1 :compound-first-argument)) 910 | 911 | (defun identical-to-ancestor-for-constant-first-argument/2 (!ancestors! !arg1! !arg2!) 912 | (identical-to-ancestor 2 :constant-first-argument)) 913 | 914 | (defun identical-to-ancestor-for-variable-first-argument/2 (!ancestors! !arg1! !arg2!) 915 | (identical-to-ancestor 2 :variable-first-argument)) 916 | 917 | (defun identical-to-ancestor-for-compound-first-argument/2 (!ancestors! !arg1! !arg2!) 918 | (identical-to-ancestor 2 :compound-first-argument)) 919 | 920 | (defun identical-to-ancestor-for-constant-first-argument/3 (!ancestors! !arg1! !arg2! 921 | !arg3!) 922 | (identical-to-ancestor 3 :constant-first-argument)) 923 | 924 | (defun identical-to-ancestor-for-variable-first-argument/3 (!ancestors! !arg1! !arg2! 925 | !arg3!) 926 | (identical-to-ancestor 3 :variable-first-argument)) 927 | 928 | (defun identical-to-ancestor-for-compound-first-argument/3 (!ancestors! !arg1! !arg2! 929 | !arg3!) 930 | (identical-to-ancestor 3 :compound-first-argument)) 931 | 932 | (defun identical-to-ancestor-for-constant-first-argument/4+ (!ancestors! !arg1! !args!) 933 | (identical-to-ancestor 4 :constant-first-argument)) 934 | 935 | (defun identical-to-ancestor-for-variable-first-argument/4+ (!ancestors! !arg1! !args!) 936 | (identical-to-ancestor 4 :variable-first-argument)) 937 | 938 | (defun identical-to-ancestor-for-compound-first-argument/4+ (!ancestors! !arg1! !args!) 939 | (identical-to-ancestor 4 :compound-first-argument)) 940 | 941 | (defun identical-to-ancestor-call-fun (arity type) 942 | (case arity 943 | (1 (case type 944 | (:constant-first-argument 'identical-to-ancestor-for-constant-first-argument/1) 945 | (:variable-first-argument 'identical-to-ancestor-for-variable-first-argument/1) 946 | (:compound-first-argument 'identical-to-ancestor-for-compound-first-argument/1))) 947 | (2 (case type 948 | (:constant-first-argument 'identical-to-ancestor-for-constant-first-argument/2) 949 | (:variable-first-argument 'identical-to-ancestor-for-variable-first-argument/2) 950 | (:compound-first-argument 'identical-to-ancestor-for-compound-first-argument/2))) 951 | (3 (case type 952 | (:constant-first-argument 'identical-to-ancestor-for-constant-first-argument/3) 953 | (:variable-first-argument 'identical-to-ancestor-for-variable-first-argument/3) 954 | (:compound-first-argument 'identical-to-ancestor-for-compound-first-argument/3))) 955 | (t (case type 956 | (:constant-first-argument 'identical-to-ancestor-for-constant-first-argument/4+) 957 | (:variable-first-argument 'identical-to-ancestor-for-variable-first-argument/4+) 958 | (:compound-first-argument 'identical-to-ancestor-for-compound-first-argument/4+))))) 959 | 960 | (defun identical-to-ancestor-call (name arity type) 961 | (let ((ancestors (ancestors-name name))) 962 | (if (= arity 0) 963 | ancestors 964 | `(when ,ancestors 965 | (,(identical-to-ancestor-call-fun arity type) 966 | ,ancestors 967 | ,@(cond ((= arity 0) nil) 968 | ((= arity 1) `(!arg1!)) 969 | ((= arity 2) `(!arg1! !arg2!)) 970 | ((= arity 3) `(!arg1! !arg2! !arg3!)) 971 | (t `(!arg1! !args!)))))))) 972 | 973 | ;; COMPILER 974 | 975 | (defun clause-head (clause) 976 | (cond 977 | ((or (eq (car clause) '<-/2) (eq (car clause) '<-)) 978 | (cadr clause)) 979 | ((or (eq (car clause) '->/2) (eq (car clause) '->)) 980 | (caddr clause)) 981 | (t 982 | clause))) 983 | 984 | (defun clause-pred (clause) 985 | (car (clause-head clause))) 986 | 987 | (defun clause-args (clause) 988 | (cdr (clause-head clause))) 989 | 990 | (defun clause-body (clause) 991 | (cond 992 | ((or (eq (car clause) '<-/2) (eq (car clause) '<-)) 993 | (caddr clause)) 994 | ((or (eq (car clause) '->/2) (eq (car clause) '->)) 995 | (cadr clause)) 996 | (t 997 | '(true/0)))) 998 | 999 | (defun replace-variable-in-term (var value term) 1000 | (cond ((eq var term) value) 1001 | ((atom term) term) 1002 | (t (let ((z (replace-variable-in-terms var value (cdr term)))) 1003 | (if (eq z (cdr term)) term (cons (car term) z)))))) 1004 | 1005 | (defun replace-variable-in-terms (var value terms) 1006 | (cond ((null terms) nil) 1007 | (t (let ((x (replace-variable-in-term var value (car terms))) 1008 | (y (replace-variable-in-terms var value (cdr terms)))) 1009 | (if (and (eq x (car terms)) (eq y (cdr terms))) terms (cons x y)))))) 1010 | 1011 | (defun term-constructor (term vars) 1012 | (cond ((atom term) 1013 | (cond ((eq term '_) 1014 | ;; i.e., (new-variable '_ !level!) 1015 | `(list* !level! nil #+include-name-in-variable '_)) 1016 | ((member term vars) term) 1017 | (t (list 'quote term)))) 1018 | (t (let ((args (mapcar #'(lambda (x) (term-constructor x vars)) (cdr term)))) 1019 | (cond ((every #'(lambda (x) (and (not (atom x)) (eq (car x) 'quote))) args) 1020 | (list 'quote term)) 1021 | (t (list* 'list (list 'quote (car term)) args))))))) 1022 | 1023 | (defun term-constructors (terms vars &aux newterms) 1024 | (setq newterms (mapcar #'(lambda (term) (term-constructor term vars)) terms)) 1025 | (cond ((every #'(lambda (x) (and (not (atom x)) (eq (car x) 'quote))) newterms) 1026 | (list 'quote terms)) 1027 | (t (cons 'list newterms)))) 1028 | 1029 | (defun wrap-progn (forms) 1030 | (cond ((null forms) nil) 1031 | ((null (cdr forms)) (car forms)) 1032 | (t (cons 'progn forms)))) 1033 | 1034 | (defun wrap-bind-args (form) 1035 | (if (and (or (not allow-repeated-goals) (not incomplete-inference)) (> arity 1)) 1036 | `(let ((!args! (list . ,(head-locs arity)))) 1037 | ,form) 1038 | form)) 1039 | 1040 | (defvar trail-is-nil) 1041 | 1042 | (defun wrap-undo-bindings (form) 1043 | (if trail-is-nil 1044 | form 1045 | `(progn ,form (undo-bindings)))) 1046 | 1047 | (defun stack-list-new-variables (variables form) 1048 | (cond ((null variables) form) 1049 | (t (list 'let 1050 | (mapcar 1051 | #'(lambda (v) 1052 | ;; i.e., `(new-variable ',v !level!) 1053 | (list v `(list* !level! nil #+include-name-in-variable ',v))) 1054 | variables) 1055 | form)))) 1056 | 1057 | (eval-when (:compile-toplevel :load-toplevel :execute) 1058 | (defmacro invisible-functor-p (x) 1059 | `(get ,x 'invisible-functor))) 1060 | 1061 | (defun clause-body-length (body &optional fl) 1062 | (cond ((atom body) 0) 1063 | ((eq (car body) 'true/0) 0) 1064 | ((eq (car body) 'fail/0) 0) 1065 | ((eq (car body) 'false/0) 0) 1066 | ((eq (car body) 'nsubgoals/1) (if fl (cadr body) 0)) 1067 | ((eq (car body) and-connective) 1068 | (+ (clause-body-length (cadr body) fl) (clause-body-length (caddr body) fl))) 1069 | ((eq (car body) or-connective) 1070 | (let ((l1 (clause-body-length (cadr body) fl)) 1071 | (l2 (clause-body-length (caddr body) fl))) 1072 | (if (= l1 l2) 1073 | l1 1074 | (error "OR branches ~A and ~A not of same length.~%Proof printing won't work." 1075 | (cadr body) (caddr body))))) 1076 | ((member (car body) '(search/1 search/2 search/3 search/4)) 1077 | (clause-body-length (cadr body) fl)) 1078 | ((invisible-functor-p (car body)) 0) 1079 | (t 1))) 1080 | 1081 | (defun compile-clause-body1 (body vars unbound continuation) 1082 | (cond ((eq body '!) 1083 | `(progn ,continuation (undo-bindings) (return-from ,name nil))) 1084 | ((eq body '?!) 1085 | (if (member first-argument-type '(:variable-bound-to-constant-first-argument 1086 | :variable-bound-to-compound-first-argument)) 1087 | continuation 1088 | `(progn 1089 | ,continuation 1090 | (when (= *trail* !old-trail!) 1091 | (return-from ,name nil))))) 1092 | ((eq body 'end-search) 1093 | `(end-search ,continuation)) 1094 | ((member (car body) '(search/1 search/2 search/3 search/4)) 1095 | (compile-clause-body1 `(,and-connective 1096 | (begin-search ,(caddr body) ,(car (cdddr body)) 1097 | ,(cadr (cdddr body))) 1098 | (,and-connective ,(cadr body) end-search)) 1099 | vars unbound continuation)) 1100 | ((equal body '(true/0)) continuation) 1101 | ((equal body '(fail/0)) nil) 1102 | ((equal body '(false/0)) nil) 1103 | ((eq (car body) 'nsubgoals/1) continuation) 1104 | ((eq (car body) and-connective) 1105 | (cond ((and (not (atom (cadr body))) 1106 | (eq (car (cadr body)) and-connective)) 1107 | (compile-clause-body1 `(,and-connective 1108 | ,(cadr (cadr body)) 1109 | (,and-connective ,(caddr (cadr body)) 1110 | ,(caddr body))) 1111 | vars unbound continuation)) 1112 | ((and (not (atom (cadr body))) 1113 | (eq (car (cadr body)) or-connective)) 1114 | (compile-clause-body1 `(,or-connective 1115 | (,and-connective ,(cadr (cadr body)) 1116 | ,(caddr body)) 1117 | (,and-connective ,(caddr (cadr body)) 1118 | ,(caddr body))) 1119 | vars unbound continuation)) 1120 | (t (compile-clause-body1 1121 | (cadr body) vars unbound 1122 | (compile-clause-body1 (caddr body) 1123 | vars 1124 | (remove-if 1125 | #'(lambda (v) 1126 | (variable-occurs-in-term-p v (cadr body))) 1127 | unbound) 1128 | continuation))))) 1129 | ((eq (car body) or-connective) 1130 | (let ((x (compile-clause-body1 (cadr body) vars unbound continuation)) 1131 | (y (compile-clause-body1 (caddr body) vars unbound continuation))) 1132 | (cond ((and (not (atom x)) (eq (car x) 'progn)) 1133 | (cond ((and (not (atom y)) (eq (car y) 'progn)) 1134 | `(progn ,@(cdr x) ,@(cdr y))) 1135 | (t `(progn ,@(cdr x) ,y)))) 1136 | ((and (not (atom y)) (eq (car y) 'progn)) 1137 | `(progn ,x ,@(cdr y))) 1138 | (t `(progn ,x ,y))))) 1139 | (t `(pcall ,body 1140 | (,(remove-if-not #'(lambda (v) (variable-occurs-in-term-p v body)) 1141 | vars) 1142 | ,(remove-if-not #'(lambda (v) (variable-occurs-in-term-p v body)) 1143 | unbound)) 1144 | !level! 1145 | ,(if (and (not (atom continuation)) 1146 | (eq (car continuation) 'funcall) 1147 | (eq (caddr continuation) '!level!)) 1148 | (cadr continuation) 1149 | `(function (lambda (!new-level!) 1150 | #+LispM (declare (sys:downward-function)) 1151 | ;; WARNING: put !level! inside macro if no subst 1152 | ;; desired 1153 | ,(subst '!new-level! '!level! continuation)))))))) 1154 | 1155 | (defun compile-clause-body (body vars unbound) 1156 | (declare (special *clausenum*)) 1157 | (if (equal body '(true/0)) 1158 | (setq body '?!)) ; automatically cut if unit clause subsumes goal 1159 | (let* ((length (clause-body-length body)) 1160 | (nonunit (> length 0)) 1161 | (incomplete-inference (or incomplete-inference (not nonunit))) 1162 | (allow-repeated-goals (or allow-repeated-goals (not nonunit))) 1163 | (x (compile-clause-body1 1164 | body vars unbound (wrap-pop-ancestor 1165 | (wrap-exit-redo-trace 1166 | `(funcall !continuation! !level!)))))) 1167 | `(progn (update-subgoal ,length ',*clausenum*) 1168 | ,(wrap-count-calls (wrap-push-ancestor (wrap-undo-bindings x)))))) 1169 | 1170 | (defun compile-clause1 (headpats headlocs body vars unbound trail-is-nil) 1171 | (cond ((null headpats) (compile-clause-body body vars unbound)) 1172 | ((eq (car headpats) '_) 1173 | (compile-clause1 (cdr headpats) (cdr headlocs) body vars unbound trail-is-nil)) 1174 | ((member (car headpats) unbound) 1175 | (if (and (not (variable-occurs-in-terms-p (car headpats) (cdr headpats))) 1176 | (not (variable-occurs-in-term-p (car headpats) body))) 1177 | (compile-clause1 (cdr headpats) (cdr headlocs) body vars unbound 1178 | trail-is-nil) 1179 | (if (atom (car headlocs)) 1180 | (compile-clause1 1181 | (replace-variable-in-terms (car headpats) (car headlocs) 1182 | (cdr headpats)) 1183 | (cdr headlocs) 1184 | (replace-variable-in-term (car headpats) (car headlocs) body) 1185 | (cons (car headlocs) vars) (remove (car headpats) unbound) 1186 | trail-is-nil) 1187 | `(let ((,(car headpats) ,(car headlocs))) 1188 | ,(compile-clause1 (cdr headpats) (cdr headlocs) body 1189 | vars (remove (car headpats) unbound) 1190 | trail-is-nil))))) 1191 | ((member (car headpats) vars) 1192 | (cond ((and (eq (car headpats) '!arg1!) 1193 | (member first-argument-type 1194 | '(:constant-first-argument 1195 | :variable-bound-to-constant-first-argument))) 1196 | `(when (unify-argument-with-constant ,(car headlocs) !arg1! 1197 | :trail-is-nil ,trail-is-nil) 1198 | ,(compile-clause1 (cdr headpats) (cdr headlocs) body vars unbound 1199 | nil))) 1200 | ((and (eq (car headpats) '!arg1!) 1201 | (member first-argument-type 1202 | '(:compound-first-argument 1203 | :variable-bound-to-compound-first-argument))) 1204 | `(when (unify-argument-with-compound ,(car headlocs) !arg1! 1205 | :unsafe ,unsafe-unification) 1206 | ,(compile-clause1 (cdr headpats) (cdr headlocs) body vars unbound 1207 | nil))) 1208 | (t `(when (,(if unsafe-unification 'unsafe-maybe-trails-unify 1209 | 'maybe-trails-unify) 1210 | ,(car headlocs) ,(car headpats) !old-trail! !level!) 1211 | ,(compile-clause1 (cdr headpats) (cdr headlocs) 1212 | body vars unbound nil))))) 1213 | ((or (atom (car headpats)) (eq (caar headpats) 'nth)) 1214 | `(when (unify-argument-with-constant ,(car headlocs) 1215 | ,(if (and (not (atom (car headpats))) 1216 | (eq (caar headpats) 'nth)) 1217 | (car headpats) 1218 | `',(car headpats)) 1219 | :trail-is-nil ,trail-is-nil) 1220 | ,(compile-clause1 (cdr headpats) (cdr headlocs) body vars unbound nil))) 1221 | (t (let ((newunbound (remove-if #'(lambda (v) 1222 | (variable-occurs-in-term-p v (car headpats))) 1223 | unbound))) 1224 | (stack-list-new-variables 1225 | (remove-if-not #'(lambda (v) 1226 | (variable-occurs-in-term-p v (car headpats))) 1227 | unbound) 1228 | `(let 1229 | ((!compound! ,(term-constructor (car headpats) vars))) 1230 | (when (unify-argument-with-compound 1231 | ,(car headlocs) !compound! :trail-is-nil ,trail-is-nil 1232 | :unsafe ,unsafe-unification) 1233 | ,(compile-clause1 (cdr headpats) (cdr headlocs) 1234 | body vars newunbound nil)))))))) 1235 | 1236 | (defun compile-clause (headpats headlocs body vars unbound &aux (trail-is-nil t)) 1237 | (compile-clause1 headpats headlocs body vars unbound trail-is-nil)) 1238 | 1239 | (defun all-distinct-variable-arguments (clause variables) 1240 | (let (seen) 1241 | (dolist (arg (clause-args clause) t) 1242 | (if (or (eq arg '_) (and (member arg variables) (not (member arg seen)))) 1243 | (push arg seen) 1244 | (return nil))))) 1245 | 1246 | (defun all-constant-arguments (clause variables) 1247 | (dolist (arg (clause-args clause) t) 1248 | (if (or (not (atom arg)) (eq arg '_) (member arg variables)) (return nil)))) 1249 | 1250 | (defun compile-procedure-for-constant-first-argument (clauses variables) 1251 | (do ((first-argument-type :constant-first-argument) 1252 | (clauses clauses (cdr clauses)) 1253 | (compiled-clauses nil) 1254 | (unbound variables) 1255 | (clause) 1256 | (*clausenum*)) 1257 | ((null clauses) 1258 | (wrap-progn 1259 | (nconc 1260 | (if (not allow-repeated-goals) 1261 | (list `(when ,(identical-to-ancestor-call name arity first-argument-type) 1262 | (return-from ,name nil)))) 1263 | (if (not incomplete-inference) 1264 | (list `(when ,(reduce-by-ancestor-call name arity first-argument-type) 1265 | (return-from ,name nil)))) 1266 | (nreverse compiled-clauses)))) 1267 | (declare (special *clausenum*)) 1268 | (setq clause (car clauses)) 1269 | (setq *clausenum* (cdr (assoc clause clause-numbers))) 1270 | (unless (not (atom (first (clause-args clause)))) 1271 | (push (cond ((eq (first (clause-args clause)) '_) 1272 | (wrap-depth-test 1273 | (compile-clause (rest (clause-args clause)) 1274 | (rest (head-locs (clause-args clause))) 1275 | (clause-body clause) variables unbound) 1276 | (clause-body clause))) 1277 | ((member (first (clause-args clause)) variables) 1278 | (wrap-depth-test 1279 | (compile-clause 1280 | (replace-variable-in-terms (first (clause-args clause)) 1281 | '!arg1! (rest (clause-args clause))) 1282 | (rest (head-locs (clause-args clause))) 1283 | (replace-variable-in-term (first (clause-args clause)) 1284 | '!arg1! (clause-body clause)) 1285 | (cons '!arg1! variables) 1286 | (remove (first (clause-args clause)) unbound)) 1287 | (clause-body clause))) 1288 | ((and (not (null (cdr clauses))) 1289 | (all-constant-arguments clause variables) 1290 | (equal (clause-body clause) (clause-body (cadr clauses))) 1291 | (all-constant-arguments (cadr clauses) variables)) 1292 | (setq *clausenum* nil) 1293 | (setq clauses (cdr clauses)) 1294 | (do ((values (list (if (= arity 1) (first (clause-args (car clauses))) 1295 | (clause-args (car clauses))) 1296 | (if (= arity 1) (first (clause-args clause)) 1297 | (clause-args clause))) 1298 | (cons (if (= arity 1) (first (clause-args (car clauses))) 1299 | (clause-args (car clauses))) values))) 1300 | ((not (and (not (null (cdr clauses))) 1301 | (equal (clause-body clause) 1302 | (clause-body (cadr clauses))) 1303 | (all-constant-arguments (cadr clauses) variables))) 1304 | `(dolist (!vector! ',(nreverse values)) 1305 | (when (eql !arg1! ,(if (= arity 1) `!vector! `(car !vector!))) 1306 | ,(wrap-depth-test 1307 | (if (= arity 1) 1308 | (compile-clause nil nil (clause-body clause) 1309 | variables unbound) 1310 | (compile-clause (head-locs (rest (clause-args clause)) 1311 | '!vector! t) 1312 | (cdr (head-locs (clause-args clause))) 1313 | (clause-body clause) 1314 | variables unbound)) 1315 | (clause-body clause))))) 1316 | (setq clauses (cdr clauses)))) 1317 | (t `(when (eql !arg1! ',(first (clause-args clause))) 1318 | ,(wrap-depth-test 1319 | (compile-clause (rest (clause-args clause)) 1320 | (rest (head-locs (clause-args clause))) 1321 | (clause-body clause) variables unbound) 1322 | (clause-body clause))))) 1323 | compiled-clauses)))) 1324 | 1325 | (defun compile-procedure-for-compound-first-argument (clauses variables) 1326 | (do ((first-argument-type :compound-first-argument) 1327 | (clauses clauses (cdr clauses)) 1328 | (compiled-clauses nil) 1329 | (unbound variables) 1330 | (clause) 1331 | (*clausenum*)) 1332 | ((null clauses) 1333 | (wrap-progn 1334 | (nconc 1335 | (if (not allow-repeated-goals) 1336 | (list `(when ,(identical-to-ancestor-call name arity first-argument-type) 1337 | (return-from ,name nil)))) 1338 | (if (not incomplete-inference) 1339 | (list `(when ,(reduce-by-ancestor-call name arity first-argument-type) 1340 | (return-from ,name nil)))) 1341 | (nreverse compiled-clauses)))) 1342 | (declare (special *clausenum*)) 1343 | (setq clause (car clauses)) 1344 | (setq *clausenum* (cdr (assoc clause clause-numbers))) 1345 | (unless (and (atom (first (clause-args clause))) 1346 | (not (eq (first (clause-args clause)) '_)) 1347 | (not (member (first (clause-args clause)) variables))) 1348 | (push (cond ((eq (first (clause-args clause)) '_) 1349 | (wrap-depth-test 1350 | (compile-clause (rest (clause-args clause)) 1351 | (rest (head-locs (clause-args clause))) 1352 | (clause-body clause) variables unbound) 1353 | (clause-body clause))) 1354 | ((member (first (clause-args clause)) variables) 1355 | (wrap-depth-test 1356 | (compile-clause 1357 | (replace-variable-in-terms (first (clause-args clause)) 1358 | '!arg1! (rest (clause-args clause))) 1359 | (rest (head-locs (clause-args clause))) 1360 | (replace-variable-in-term (first (clause-args clause)) 1361 | '!arg1! (clause-body clause)) 1362 | (cons '!arg1! variables) 1363 | (remove (first (clause-args clause)) unbound)) 1364 | (clause-body clause))) 1365 | (t `(when (eq (car !arg1!) ',(car (first (clause-args clause)))) 1366 | ,(wrap-depth-test 1367 | (compile-clause 1368 | (append (rest (first (clause-args clause))) 1369 | (rest (clause-args clause))) 1370 | (append (head-locs (rest (first (clause-args clause))) 1371 | '!arg1! t) 1372 | (rest (head-locs (clause-args clause)))) 1373 | (clause-body clause) variables unbound) 1374 | (clause-body clause))))) 1375 | compiled-clauses)))) 1376 | 1377 | (defun compile-procedure-for-variable-first-argument (clauses variables) 1378 | (do ((first-argument-type :variable-first-argument) 1379 | (clauses clauses (cdr clauses)) 1380 | (compiled-clauses nil) 1381 | (unbound variables) 1382 | (clause) 1383 | (*clausenum*)) 1384 | ((null clauses) 1385 | (wrap-progn 1386 | (nconc 1387 | (if (not allow-repeated-goals) 1388 | (list `(when ,(identical-to-ancestor-call name arity first-argument-type) 1389 | (return-from ,name nil)))) 1390 | (if (not incomplete-inference) 1391 | (list `(when ,(reduce-by-ancestor-call name arity first-argument-type) 1392 | (return-from ,name nil)))) 1393 | (nreverse compiled-clauses)))) 1394 | (declare (special *clausenum*)) 1395 | (setq clause (car clauses)) 1396 | (setq *clausenum* (cdr (assoc clause clause-numbers))) 1397 | (push (cond ((eq (first (clause-args clause)) '_) 1398 | (wrap-depth-test 1399 | (compile-clause (rest (clause-args clause)) 1400 | (rest (head-locs (clause-args clause))) 1401 | (clause-body clause) variables unbound) 1402 | (clause-body clause))) 1403 | ((member (first (clause-args clause)) variables) 1404 | (wrap-depth-test 1405 | (compile-clause 1406 | (replace-variable-in-terms (first (clause-args clause)) 1407 | '!arg1! (rest (clause-args clause))) 1408 | (rest (head-locs (clause-args clause))) 1409 | (replace-variable-in-term (first (clause-args clause)) 1410 | '!arg1! (clause-body clause)) 1411 | (cons '!arg1! variables) 1412 | (remove (first (clause-args clause)) unbound)) 1413 | (clause-body clause))) 1414 | ((and (not (null (cdr clauses))) 1415 | (all-constant-arguments clause variables) 1416 | (equal (clause-body clause) (clause-body (cadr clauses))) 1417 | (all-constant-arguments (cadr clauses) variables)) 1418 | (setq *clausenum* nil) 1419 | (setq clauses (cdr clauses)) 1420 | (do ((first-argument-type :variable-bound-to-constant-first-argument) 1421 | (values (list (if (= arity 1) (first (clause-args (car clauses))) 1422 | (clause-args (car clauses))) 1423 | (if (= arity 1) (first (clause-args clause)) 1424 | (clause-args clause))) 1425 | (cons (if (= arity 1) (first (clause-args (car clauses))) 1426 | (clause-args (car clauses))) 1427 | values))) 1428 | ((not (and (not (null (cdr clauses))) 1429 | (equal (clause-body clause) (clause-body (cadr clauses))) 1430 | (all-constant-arguments (cadr clauses) variables))) 1431 | `(dolist (!vector! ',(nreverse values)) 1432 | ,(wrap-depth-test 1433 | (if (= arity 1) 1434 | `(progn (bind-variable-to-term !arg1! !vector! :trail) 1435 | ,(compile-clause nil nil (clause-body clause) 1436 | variables unbound) 1437 | (undo-bindings)) 1438 | `(progn (bind-variable-to-term !arg1! (car !vector!) 1439 | :trail) 1440 | ,(compile-clause 1441 | (head-locs (rest (clause-args clause)) 1442 | '!vector! t) 1443 | (cdr (head-locs (clause-args clause))) 1444 | (clause-body clause) variables unbound) 1445 | (undo-bindings))) 1446 | (clause-body clause)))) 1447 | (setq clauses (cdr clauses)))) 1448 | ((atom (first (clause-args clause))) 1449 | (let ((first-argument-type :variable-bound-to-constant-first-argument)) 1450 | (wrap-depth-test 1451 | `(progn (bind-variable-to-term !arg1! ',(first (clause-args clause)) 1452 | :trail) 1453 | ,(compile-clause (rest (clause-args clause)) 1454 | (rest (head-locs (clause-args clause))) 1455 | (clause-body clause) variables unbound) 1456 | (undo-bindings)) 1457 | (clause-body clause)))) 1458 | (t (wrap-depth-test 1459 | (let ((first-argument-type 1460 | :variable-bound-to-compound-first-argument) 1461 | (unbound (remove-if #'(lambda (v) 1462 | (variable-occurs-in-term-p 1463 | v (first (clause-args clause)))) 1464 | unbound))) 1465 | (stack-list-new-variables 1466 | (remove-if-not #'(lambda (v) 1467 | (variable-occurs-in-term-p 1468 | v (first (clause-args clause)))) 1469 | variables) 1470 | `(let 1471 | ((!compound! ,(term-constructor (first (clause-args clause)) 1472 | variables))) 1473 | (progn 1474 | (bind-variable-to-term !arg1! !compound! :trail) 1475 | ,(compile-clause (rest (clause-args clause)) 1476 | (rest (head-locs (clause-args clause))) 1477 | (clause-body clause) variables unbound) 1478 | (undo-bindings))))) 1479 | (clause-body clause)))) 1480 | compiled-clauses))) 1481 | 1482 | (defun compile-procedure (name variables clauses 1483 | &key 1484 | (traceable nil) 1485 | (unbounded-search nil) 1486 | (unsafe-unification nil) 1487 | (incomplete-inference nil) 1488 | (allow-repeated-goals nil) 1489 | (split-procedure nil) 1490 | (collapse-clauses nil) 1491 | &aux (arity (get name 'arity)) parameters (unbound variables) 1492 | (lisp-compile-time 0)) 1493 | (declare (ignore collapse-clauses)) 1494 | (when (eq name 'query/0) 1495 | (setq traceable nil) 1496 | (setq unbounded-search t) 1497 | (setq incomplete-inference t) 1498 | (setq allow-repeated-goals t)) 1499 | (if (= arity 0) (setq split-procedure nil)) 1500 | (if (not trace-calls) (setq traceable nil)) 1501 | (setq parameters (list 'count-calls count-calls 1502 | 'clause-numbers 1503 | (mapcar #'(lambda (clause) 1504 | (cdr (assoc clause clause-numbers :test #'equal))) 1505 | clauses) 1506 | :variables variables 1507 | :traceable traceable 1508 | :unbounded-search unbounded-search 1509 | :unsafe-unification unsafe-unification 1510 | :incomplete-inference incomplete-inference 1511 | :allow-repeated-goals allow-repeated-goals 1512 | :split-procedure split-procedure)) 1513 | (when (or recompile 1514 | (not (equal clauses (get name 'compiled-clauses))) 1515 | (not (equal parameters (get name 'compiled-parameters)))) 1516 | (let (arglist auxlist namec names namev defn defnc defns defnv) 1517 | (when (not allow-repeated-goals) 1518 | (dolist (clause clauses (setq allow-repeated-goals t)) 1519 | (when (> (clause-body-length (clause-body clause)) 0) 1520 | (return)))) 1521 | (setq arglist (append (head-locs arity) '(!level! !continuation!))) 1522 | (setq auxlist (append arglist '(&aux (!old-trail! *trail*)))) 1523 | (when (or (not allow-repeated-goals) (not incomplete-inference)) 1524 | (eval `(defvar ,(ancestors-name name) nil)) 1525 | (eval `(defvar ,(ancestors-name (negated-functor name)) nil))) 1526 | (setq defn 1527 | `(lambda ,(if (and split-procedure (not (= arity 0))) arglist auxlist) 1528 | (declare (ignorable !old-trail!)) 1529 | (with-subgoal (,name . ,(head-locs arity)) 1530 | (incf !level!) 1531 | (block ,name 1532 | ,(wrap-call-fail-trace 1533 | (cond ((= arity 0) 1534 | (do ((first-argument-type nil) 1535 | (clauses clauses (cdr clauses)) 1536 | (compiled-clauses nil) 1537 | (clause) 1538 | (*clausenum*)) 1539 | ((null clauses) 1540 | (wrap-progn 1541 | (nconc 1542 | (if (not allow-repeated-goals) 1543 | (list `(when ,(identical-to-ancestor-call 1544 | name 0 nil) 1545 | (return-from ,name nil)))) 1546 | (if (not incomplete-inference) 1547 | (list `(when ,(reduce-by-ancestor-call 1548 | name 0 nil) 1549 | (return-from ,name nil)))) 1550 | (nreverse compiled-clauses)))) 1551 | (declare (special *clausenum*)) 1552 | (setq clause (car clauses)) 1553 | (setq *clausenum* (cdr (assoc clause clause-numbers))) 1554 | (push (wrap-depth-test (compile-clause 1555 | nil nil (clause-body clause) 1556 | variables unbound) 1557 | (clause-body clause)) 1558 | compiled-clauses))) 1559 | (split-procedure 1560 | (setq namec 1561 | (intern (concatenate 'string (symbol-name name) 1562 | "C") 1563 | 'pttp)) 1564 | (setq names 1565 | (intern (concatenate 'string (symbol-name name) 1566 | "S") 1567 | 'pttp)) 1568 | (setq namev 1569 | (intern (concatenate 'string (symbol-name name) 1570 | "V") 1571 | 'pttp)) 1572 | (let ((nm (functor-name name))) 1573 | (setf (get namec 'name) nm) 1574 | (setf (get names 'name) nm) 1575 | (setf (get namev 'name) nm) 1576 | (setf (get namec 'arity) arity) 1577 | (setf (get names 'arity) arity) 1578 | (setf (get namev 'arity) arity)) 1579 | (setq defnc (list 'lambda 1580 | auxlist 1581 | (list 'block name 1582 | (wrap-bind-args 1583 | (compile-procedure-for-constant-first-argument clauses variables))))) 1584 | (setq defns (list 'lambda 1585 | auxlist 1586 | (list 'block name 1587 | (wrap-bind-args 1588 | (compile-procedure-for-compound-first-argument clauses variables))))) 1589 | (setq defnv (list 'lambda 1590 | auxlist 1591 | (list 'block name 1592 | (wrap-bind-args 1593 | (compile-procedure-for-variable-first-argument clauses variables))))) 1594 | `(dereference 1595 | !arg1! 1596 | :if-constant (,namec . ,arglist) 1597 | :if-compound (,names . ,arglist) 1598 | :if-variable (,namev . ,arglist))) 1599 | (t (wrap-bind-args 1600 | `(dereference 1601 | !arg1! 1602 | :if-constant ,(compile-procedure-for-constant-first-argument clauses variables) 1603 | :if-compound ,(compile-procedure-for-compound-first-argument clauses variables) 1604 | :if-variable ,(compile-procedure-for-variable-first-argument clauses variables)))))))))) 1605 | (when print-compile-names (format t "~&~A compiled from PTTP to LISP" name)) 1606 | (setq lisp-compile-time (get-internal-run-time)) 1607 | (when (and split-procedure (> arity 0)) 1608 | (compile namec defnc) 1609 | (compile names defns) 1610 | (compile namev defnv)) 1611 | ;(print `(defun ,name . ,(cdr defn))) 1612 | (compile name defn) 1613 | (when print-compile-names (format t "~&~A compiled from LISP to machine code" name)) 1614 | (setq lisp-compile-time (- (get-internal-run-time) lisp-compile-time))) 1615 | (setf (get name 'compiled-clauses) clauses) 1616 | (setf (get name 'compiled-parameters) parameters)) 1617 | lisp-compile-time) 1618 | 1619 | (defun print-clauses (clauses variables) 1620 | (when variables 1621 | (fresh-line) 1622 | (terpri) 1623 | (cond ((null (cdr variables)) 1624 | (princ " The symbol ") 1625 | (write-term (car variables)) 1626 | (princ " denotes a variable.")) 1627 | (t (princ " The symbols ") 1628 | (write-term (car variables)) 1629 | (do ((v (cdr variables) (cdr v))) 1630 | ((null (cdr v)) (princ " and ") (write-term (car v))) 1631 | (princ ", ") (write-term (car v))) 1632 | (princ " denote variables.")))) 1633 | (dolist (clause clauses) 1634 | (write-clause clause (cdr (assoc clause clause-numbers))))) 1635 | 1636 | (defun predicate-clauses (predicate clauses) 1637 | (remove-if-not #'(lambda (clause) (eq (clause-pred clause) predicate)) 1638 | clauses)) 1639 | 1640 | (defun program (variables wffs &rest options) 1641 | (let (clauses predicates wff-number start-time stop-time (lisp-compile-time 0)) 1642 | (setq start-time (get-internal-run-time)) 1643 | (setq wffs (canonicalize-functors-in-terms wffs)) 1644 | (setq stop-time (get-internal-run-time)) 1645 | 1646 | (when print-clauses 1647 | (setq wff-number 0) 1648 | (setq clause-numbers nil) 1649 | (dolist (wff wffs) 1650 | (incf wff-number) 1651 | (push (cons wff wff-number) clause-numbers)) 1652 | (print-clauses wffs variables)) 1653 | 1654 | (setq start-time (- (get-internal-run-time) (- stop-time start-time))) 1655 | (setq wff-number 0) 1656 | (setq clause-numbers nil) 1657 | (dolist (wff wffs) 1658 | (incf wff-number) 1659 | (let ((cls (clauses-from-wff wff))) 1660 | (cond ((null (cdr cls)) 1661 | (push (car cls) clauses) 1662 | (push (cons (car clauses) wff-number) clause-numbers) 1663 | (pushnew (clause-pred (car clauses)) predicates)) 1664 | (t (let ((literal-number 0)) 1665 | (dolist (cl cls) 1666 | (incf literal-number) 1667 | (push cl clauses) 1668 | (push (cons (car clauses) (cons wff-number 1669 | (numbered-letter literal-number))) 1670 | clause-numbers) 1671 | (pushnew (clause-pred (car clauses)) predicates) 1672 | (pushnew (negated-functor (clause-pred (car clauses))) 1673 | predicates))))))) 1674 | (setq clauses (nreverse clauses)) 1675 | (setq predicates (nreverse predicates)) 1676 | 1677 | (dolist (pred predicates) 1678 | (incf lisp-compile-time 1679 | (apply #'compile-procedure 1680 | (list* pred variables (predicate-clauses pred clauses) options)))) 1681 | (setq stop-time (get-internal-run-time)) 1682 | 1683 | (when print-compile-times 1684 | (format t "~2&Compilation time: ~,3F seconds (PTTP) + ~,3F seconds (LISP)~%" 1685 | (/ (- stop-time start-time lisp-compile-time) 1686 | float-internal-time-units-per-second) 1687 | (/ lisp-compile-time float-internal-time-units-per-second))) 1688 | 1689 | nil)) 1690 | 1691 | (defvar *print-proof* t) 1692 | 1693 | (defvar *proof* nil) 1694 | 1695 | (defmacro with-subgoal ((name &rest args) &body body) 1696 | `(let ((*proof* (cons (list ,(length args) `(,',name ,,@args) 0 nil) *proof*))) 1697 | . ,body)) 1698 | 1699 | (defun update-subgoal (length clausenum) 1700 | (let ((proof-frame-tail (cddar *proof*))) 1701 | (setf (car proof-frame-tail) length) 1702 | (setf (cadr proof-frame-tail) clausenum))) 1703 | 1704 | (defvar *print-proof-time* 0) 1705 | 1706 | (defun query-success (!level!) 1707 | (declare (ignore !level!)) 1708 | (let ((start-time (get-internal-run-time))) 1709 | (when *print-proof* 1710 | (print-proof)) 1711 | (incf *print-proof-time* (- (get-internal-run-time) start-time))) 1712 | nil) 1713 | 1714 | (defun query (&optional variables goal &rest options) 1715 | (when goal 1716 | (apply #'program variables (list* `((<- (query) ,goal)) options))) 1717 | (let (start-time stop-time value time) 1718 | (setq *ncalls* 0) 1719 | (setq *trail* 0) 1720 | (setq *trace-search-time* 0) 1721 | (setq *print-proof-time* 0) 1722 | (setq start-time (get-internal-run-time)) 1723 | (setq value (query/0 0 #'query-success)) 1724 | (setq stop-time (get-internal-run-time)) 1725 | (when (> *ncalls* 0) 1726 | (setq time (/ (max 1 (- stop-time start-time *trace-search-time* 1727 | *print-proof-time*)) 1728 | (float internal-time-units-per-second))) 1729 | (format t "~2&Execution time: ~:D inferences in ~,6F seconds (~,2F kLIPS)~%" 1730 | *ncalls* time (/ *ncalls* time 1000))) 1731 | value)) 1732 | 1733 | ;; INPUT EXPRESSION CANONICALIZATION 1734 | 1735 | (defun make-functor (name arity) 1736 | (let ((l (get name 'functors))) 1737 | (or (cdr (assoc arity l)) 1738 | (let ((w (intern (concatenate 'string (symbol-name name) "/" 1739 | (princ-to-string arity)) 'pttp))) 1740 | (setf (get name 'functors) (cons (cons arity w) l)) 1741 | (setf (get w 'arity) arity) 1742 | (setf (get w 'name) name) 1743 | w)))) 1744 | 1745 | (defun negated-functor (name) 1746 | (or (get name 'negation) 1747 | (let* ((s (symbol-name name)) 1748 | (w (intern (if (and (>= (length s) 2) (char= (char s 0) '#\~)) 1749 | (subseq s 1) 1750 | (concatenate 'string "~" s)) 1751 | 'pttp))) 1752 | (setf (get name 'negation) w) 1753 | (setf (get w 'negation) name) 1754 | (let ((arity (get name 'arity))) (when arity (setf (get w 'arity) arity))) 1755 | w))) 1756 | 1757 | (defun functor-name (x) 1758 | (or (get x 'name) 1759 | (let* ((s (symbol-name x)) (n (length s))) 1760 | (if (digit-char-p (char s (1- n))) 1761 | (do ((n (- n 2) (1- n)) (ch)) 1762 | ((= n 0) x) 1763 | (setq ch (char s n)) 1764 | (cond ((digit-char-p ch)) 1765 | ((char= ch '#\/) (return (setf (get x 'name) (subseq s 0 n)))) 1766 | (t (return (setf (get x 'name) x))))) 1767 | x)))) 1768 | 1769 | (defun functor-arity (x) 1770 | (or (get x 'arity) 1771 | (let* ((s (symbol-name x)) (n (length s)) (arity (digit-char-p (char s (1- n))))) 1772 | (if arity 1773 | (do ((n (- n 2) (1- n)) (tens 10 (* 10 tens)) (ch) (num)) 1774 | ((= n 0) '?) 1775 | (setq ch (char s n)) 1776 | (setq num (digit-char-p ch)) 1777 | (cond (num (incf arity (* tens num))) 1778 | ((char= ch '#\/) (setf (get x 'arity) arity) (return arity)) 1779 | (t (return '?)))) 1780 | '?)))) 1781 | 1782 | (defun negate (x) 1783 | (cond ((equal x '(true/0)) '(false/0)) 1784 | ((equal x '(false/0)) '(true/0)) 1785 | ((and (not (atom x)) (eq (car x) and-connective)) 1786 | (list or-connective (negate (cadr x)) (negate (caddr x)))) 1787 | ((and (not (atom x)) (eq (car x) or-connective)) 1788 | (list and-connective (negate (cadr x)) (negate (caddr x)))) 1789 | (t (cons (negated-functor (car x)) (cdr x))))) 1790 | 1791 | (defun conjoin (x y) 1792 | (cond ((equal x '(true/0)) y) 1793 | ((equal y '(true/0)) x) 1794 | ((equal x '(false/0)) x) 1795 | ((equal y '(false/0)) y) 1796 | ((and (not (atom x)) (not (atom y)) 1797 | (eq (car x) (negated-functor (car y))) 1798 | (equal (cdr x) (cdr y))) 1799 | '(false/0)) 1800 | ((and (not (atom x)) (eq (car x) and-connective)) 1801 | (list and-connective (cadr x) (list and-connective (caddr x) y))) 1802 | (t (list and-connective x y)))) 1803 | 1804 | (defun disjoin (x y) 1805 | (cond ((equal x '(false/0)) y) 1806 | ((equal y '(false/0)) x) 1807 | ((equal x '(true/0)) x) 1808 | ((equal y '(true/0)) y) 1809 | ((and (not (atom x)) (not (atom y)) 1810 | (eq (car x) (negated-functor (car y))) 1811 | (equal (cdr x) (cdr y))) 1812 | '(true/0)) 1813 | ((and (not (atom x)) (eq (car x) or-connective)) 1814 | (list or-connective (cadr x) (list or-connective (caddr x) y))) 1815 | (t (list or-connective x y)))) 1816 | 1817 | (defun convert-string-to-list (s) 1818 | (do ((i (1- (length s)) (1- i)) (w '|[]|)) 1819 | ((< i 0) w) 1820 | (setq w `(cons/2 ,(char-code (char s i)) ,w)))) 1821 | 1822 | (defun canonicalize-functors-in-term (term) 1823 | (cond ((atom term) (cond ((null term) '|[]|) 1824 | ((stringp term) (convert-string-to-list term)) 1825 | (t term))) 1826 | ((not (symbolp (car term))) (error "Nonsymbol functor ~A" (car term))) 1827 | ((member (car term) '(and \ \& \,)) 1828 | (if (null (cddr term)) 1829 | (canonicalize-functors-in-term (cadr term)) 1830 | (conjoin (canonicalize-functors-in-term (cadr term)) 1831 | (if (cdddr term) 1832 | (canonicalize-functors-in-term (cons (car term) (cddr term))) 1833 | (canonicalize-functors-in-term (caddr term)))))) 1834 | ((member (car term) '(or \ \| \;)) 1835 | (if (null (cddr term)) 1836 | (canonicalize-functors-in-term (cadr term)) 1837 | (disjoin (canonicalize-functors-in-term (cadr term)) 1838 | (if (cdddr term) 1839 | (canonicalize-functors-in-term (cons (car term) (cddr term))) 1840 | (canonicalize-functors-in-term (caddr term)))))) 1841 | ((member (car term) '(\ imply imp implies)) 1842 | (disjoin (negate (canonicalize-functors-in-term (cadr term))) 1843 | (canonicalize-functors-in-term (caddr term)))) 1844 | ((member (car term) '(\ equiv equ iff)) 1845 | (let ((x (canonicalize-functors-in-term (cadr term))) 1846 | (y (canonicalize-functors-in-term (caddr term)))) 1847 | (conjoin (disjoin (negate x) y) (disjoin x (negate y))))) 1848 | (t (cons (make-functor (car term) (length (cdr term))) 1849 | (canonicalize-functors-in-terms (cdr term)))))) 1850 | 1851 | (defun canonicalize-functors-in-terms (terms) 1852 | (cond ((null terms) nil) 1853 | (t (let ((x (canonicalize-functors-in-term (car terms))) 1854 | (y (canonicalize-functors-in-terms (cdr terms)))) 1855 | (if (and (eq x (car terms)) (eq y (cdr terms))) terms (cons x y)))))) 1856 | 1857 | ;; CONVERSION OF NONCLAUSAL INPUTS TO CLAUSE FORM 1858 | 1859 | (defun clause-body-for-literal (lit wff &aux ~f) 1860 | (cond ((atom wff) wff) 1861 | ((eq (car wff) and-connective) 1862 | (disjoin (clause-body-for-literal lit (cadr wff)) 1863 | (clause-body-for-literal lit (caddr wff)))) 1864 | ((eq (car wff) or-connective) 1865 | (conjoin (clause-body-for-literal lit (cadr wff)) 1866 | (clause-body-for-literal lit (caddr wff)))) 1867 | ((equal lit wff) '(true/0)) 1868 | ((and (eq (car lit) 1869 | (setq ~f (negated-functor (car wff)))) 1870 | (equal (cdr lit) (cdr wff))) '(false/0)) 1871 | (t (cons ~f (cdr wff))))) 1872 | 1873 | (defun literals-in-wff (wff &optional literals) 1874 | (cond ((and (not (atom wff)) (or (eq (car wff) and-connective) 1875 | (eq (car wff) or-connective))) 1876 | (literals-in-wff (caddr wff) (literals-in-wff (cadr wff) literals))) 1877 | (t (pushnew wff literals :test #'equal)))) 1878 | 1879 | (defun clauses-from-wff (wff) 1880 | (cond ((eq (car wff) and-connective) 1881 | (nconc (clauses-from-wff (cadr wff)) (clauses-from-wff (caddr wff)))) 1882 | ((eq (car wff) or-connective) 1883 | (let (result) 1884 | (dolist (lit (literals-in-wff wff)) 1885 | (when (not (atom lit)) ;don't promote ! to head 1886 | (push (list '<-/2 lit (clause-body-for-literal lit wff)) result))) 1887 | result)) 1888 | (t (list wff)))) 1889 | 1890 | ;; PROLOG BUILT-IN PREDICATES 1891 | 1892 | (defun call/1 (x !level! !continuation!) 1893 | (with-subgoal (call/1 x) 1894 | (incf !level!) 1895 | (dereference x 1896 | :if-variable (error "CALL was given non-compound argument ~A" x) 1897 | :if-constant (error "CALL was given non-compound argument ~A" x) 1898 | :if-compound 1899 | (apply (car x) 1900 | (append (cdr x) 1901 | (list !level! !continuation!)))))) ; inefficient 1902 | 1903 | (defun not/1 (x !level! !continuation!) 1904 | (with-subgoal (not/1 x) 1905 | (not-solvable x 1000000 !level! !continuation!))) 1906 | 1907 | (defun not/2 (x y !level! !continuation!) 1908 | (with-subgoal (not/2 x y) 1909 | (not-solvable x y !level! !continuation!))) 1910 | 1911 | (defun y-or-n-p/0 (!level! !continuation!) 1912 | (with-subgoal (y-or-n-p/0) 1913 | (incf !level!) 1914 | (and (y-or-n-p) 1915 | (funcall !continuation! !level!)))) 1916 | 1917 | (defun y-or-n-p/1 (x !level! !continuation!) 1918 | (with-subgoal (y-or-n-p/1 x) 1919 | (incf !level!) 1920 | (fresh-line) (write-term x) (princ "? ") 1921 | (and (y-or-n-p) 1922 | (funcall !continuation! !level!)))) 1923 | 1924 | (defun atomic/1 (x !level! !continuation!) 1925 | (with-subgoal (atomic/1 x) 1926 | (incf !level!) 1927 | (and (dereference x) (funcall !continuation! !level!)))) 1928 | 1929 | (defun atom/1 (x !level! !continuation!) 1930 | (with-subgoal (atom/1 x) 1931 | (incf !level!) 1932 | (and (dereference x) (symbolp x) (funcall !continuation! !level!)))) 1933 | 1934 | (defun integer/1 (x !level! !continuation!) 1935 | (with-subgoal (integer/1 x) 1936 | (incf !level!) 1937 | (and (dereference x) (integerp x) (funcall !continuation! !level!)))) 1938 | 1939 | (defun var/1 (x !level! !continuation!) 1940 | (with-subgoal (var/1 x) 1941 | (incf !level!) 1942 | (dereference x 1943 | :if-constant nil 1944 | :if-variable (funcall !continuation! !level!) 1945 | :if-compound nil))) 1946 | 1947 | (defun nonvar/1 (x !level! !continuation!) 1948 | (with-subgoal (nonvar/1 x) 1949 | (incf !level!) 1950 | (dereference x 1951 | :if-constant (funcall !continuation! !level!) 1952 | :if-variable nil 1953 | :if-compound (funcall !continuation! !level!)))) 1954 | 1955 | (defun functor/3 (term functor arity !level! !continuation! 1956 | &aux (!old-trail! *trail*)) 1957 | (with-subgoal (functor/3 term functor arity) 1958 | (incf !level!) 1959 | (dereference 1960 | term 1961 | :if-variable 1962 | (when (and (dereference functor) (dereference arity)) 1963 | (case arity 1964 | (0 (progn (bind-variable-to-term term functor :trail) 1965 | (funcall !continuation! !level!) 1966 | (undo-bindings))) 1967 | (1 (let ((struct (list functor 1968 | (list* !level! nil #+include-name-in-variable 1969 | 'z1)))) ; (new-variable '_) 1970 | (progn (bind-variable-to-term term struct :trail) 1971 | (funcall !continuation! !level!) 1972 | (undo-bindings)))) 1973 | (2 (let ((struct (list functor 1974 | (list* !level! nil #+include-name-in-variable 'z1) 1975 | (list* !level! nil #+include-name-in-variable 'z2)))) 1976 | (progn (bind-variable-to-term term struct :trail) 1977 | (funcall !continuation! !level!) 1978 | (undo-bindings)))) 1979 | (3 (let ((struct (list functor 1980 | (list* !level! nil #+include-name-in-variable 'z1) 1981 | (list* !level! nil #+include-name-in-variable 'z2) 1982 | (list* !level! nil #+include-name-in-variable 'z3)))) 1983 | (progn (bind-variable-to-term term struct :trail) 1984 | (funcall !continuation! !level!) 1985 | (undo-bindings)))) 1986 | (4 (let ((struct (list functor 1987 | (list* !level! nil #+include-name-in-variable 'z1) 1988 | (list* !level! nil #+include-name-in-variable 'z2) 1989 | (list* !level! nil #+include-name-in-variable 'z3) 1990 | (list* !level! nil #+include-name-in-variable 'z4)))) 1991 | (progn (bind-variable-to-term term struct :trail) 1992 | (funcall !continuation! !level!) 1993 | (undo-bindings)))) 1994 | (5 (let ((struct (list functor 1995 | (list* !level! nil #+include-name-in-variable 'z1) 1996 | (list* !level! nil #+include-name-in-variable 'z2) 1997 | (list* !level! nil #+include-name-in-variable 'z3) 1998 | (list* !level! nil #+include-name-in-variable 'z4) 1999 | (list* !level! nil #+include-name-in-variable 'z5)))) 2000 | (progn (bind-variable-to-term term struct :trail) 2001 | (funcall !continuation! !level!) 2002 | (undo-bindings)))) 2003 | (otherwise (error "Functor argument of FUNCTOR has arity ~A. Unimplemented" 2004 | arity)))) 2005 | :if-constant 2006 | (when (and (always-trails-unify functor term !old-trail!) 2007 | (always-trails-unify arity 0 !old-trail!)) 2008 | (funcall !continuation! !level!) (undo-bindings)) 2009 | :if-compound 2010 | (when (and (always-trails-unify functor (car term) !old-trail!) 2011 | (always-trails-unify arity (length (cdr term)) !old-trail!)) 2012 | (funcall !continuation! !level!) (undo-bindings))))) 2013 | 2014 | (defun arg/3 (index term arg !level! !continuation! 2015 | &aux (!old-trail! *trail*)) 2016 | (with-subgoal (arg/3 index term arg) 2017 | (incf !level!) 2018 | (dereference term 2019 | :if-variable (error "ARG was given non-compound second argument ~A" term) 2020 | :if-constant (error "ARG was given non-compound second argument ~A" term) 2021 | :if-compound 2022 | (progn 2023 | (dereference index) 2024 | (cond ((not (integerp index)) 2025 | (error "ARG was given non-integer first argument ~A" index)) 2026 | ((or (< index 1) (> index (length (cdr term)))) 2027 | (error "ARG was given out-of-range first argument ~A for term ~A" 2028 | index term)) 2029 | (t (when (always-trails-unify arg (nth (1- index) (cdr term)) 2030 | !old-trail!) 2031 | (funcall !continuation! !level!) (undo-bindings)))))))) 2032 | 2033 | (defun is/2 (x y !level! !continuation! 2034 | &aux (!old-trail! *trail*)) 2035 | (with-subgoal (is/2 x y) 2036 | (incf !level!) 2037 | (labels ((evaluate (term) 2038 | (if (dereference term) 2039 | term 2040 | (case (length (cdr term)) 2041 | (0 (funcall (car term))) 2042 | (1 (funcall (car term) (evaluate (cadr term)))) 2043 | (2 (funcall (car term) (evaluate (cadr term)) (evaluate (caddr term)))) 2044 | (3 (funcall (car term) (evaluate (cadr term)) 2045 | (evaluate (cadddr term)))) 2046 | (otherwise 2047 | (error "Function argument of IS has ~A arguments. Unimplemented" 2048 | (length (cdr term)))))))) 2049 | (let ((y (evaluate y))) 2050 | (when (unify-argument-with-constant x y :trail-is-nil t) 2051 | (funcall !continuation! !level!) (undo-bindings)))))) 2052 | 2053 | (defun =/2 (x y !level! !continuation! 2054 | &aux (!old-trail! *trail*)) 2055 | (with-subgoal (=/2 x y)) 2056 | (incf !level!) 2057 | (when (always-trails-unify x y !old-trail!) 2058 | (funcall !continuation! !level!) (undo-bindings))) 2059 | 2060 | (defun \\=/2 (x y !level! !continuation! 2061 | &aux (!old-trail! *trail*)) 2062 | (with-subgoal (\\=/2 x y) 2063 | (incf !level!) 2064 | (if (always-trails-unify x y !old-trail!) 2065 | (undo-bindings) 2066 | (funcall !continuation! !level!)))) 2067 | 2068 | (defun unsafe-=/2 (x y !level! !continuation! 2069 | &aux (!old-trail! *trail*)) 2070 | (with-subgoal (unsafe-=/2 x y) 2071 | (incf !level!) 2072 | (when (unsafe-always-trails-unify x y !old-trail!) 2073 | (funcall !continuation! !level!) 2074 | (undo-bindings)))) 2075 | 2076 | (defun unsafe-\\=/2 (x y !level! !continuation! 2077 | &aux (!old-trail! *trail*)) 2078 | (with-subgoal (unsafe-\\=/2 x y) 2079 | (incf !level!) 2080 | (if (unsafe-always-trails-unify x y !old-trail!) 2081 | (undo-bindings) 2082 | (funcall !continuation! !level!)))) 2083 | 2084 | (defun ==/2 (x y !level! !continuation!) 2085 | (with-subgoal (==/2 x y) 2086 | (incf !level!) 2087 | (and (identical x y) (funcall !continuation! !level!)))) 2088 | 2089 | (defun \\==/2 (x y !level! !continuation!) 2090 | (with-subgoal (\\==/2 x y) 2091 | (incf !level!) 2092 | (and (not (identical x y)) (funcall !continuation! !level!)))) 2093 | 2094 | (defun >/2 (x y !level! !continuation!) 2095 | (with-subgoal (>/2 x y) 2096 | (incf !level!) 2097 | (and (dereference x) (dereference y) (> x y) (funcall !continuation! !level!)))) 2098 | 2099 | (defun =/2 (x y !level! !continuation!) 2107 | (with-subgoal (>=/2 x y) 2108 | (incf !level!) 2109 | (and (dereference x) (dereference y) 2110 | (>= x y) 2111 | (funcall !continuation! !level!)))) 2112 | 2113 | (defun =) ; unimplemented 2207 | (op/3 1200 'fx '|:-|) ; unimplemented 2208 | (op/3 1200 'fx '?-) ; unimplemented 2209 | (op/3 1100 'xfy or-connective) 2210 | (op/3 1100 'xf '\;) ; unimplemented 2211 | (op/3 1050 'xfy '->) ; unimplemented 2212 | (op/3 1000 'xfy and-connective) 2213 | (op/3 800 'fx 'not) ; unimplemented 2214 | (op/3 700 'xfx '=) 2215 | (op/3 700 'xfx '\\=) 2216 | (op/3 700 'xfx '==) 2217 | (op/3 700 'xfx '\\==) 2218 | (op/3 700 'xfx 'is) 2219 | (op/3 700 'xfx '|=..|) ; unimplemented 2220 | (op/3 700 'xfx '<) 2221 | (op/3 700 'xfx '>) 2222 | (op/3 700 'xfx '=<) 2223 | (op/3 700 'xfx '>=) 2224 | (op/3 500 'yfx '+) 2225 | (op/3 500 'yfx '-) 2226 | (op/3 500 'fx '+) 2227 | (op/3 500 'fx '-) 2228 | (op/3 400 'yfx '*) 2229 | (op/3 400 'yfx '/) 2230 | (op/3 300 'xfx 'mod) 2231 | 2232 | ;; PROLOG BUILT-IN FUNCTIONS (FOR IS/2 PREDICATE INTERPRETATION) 2233 | 2234 | (defun |+/1| (m) 2235 | m) 2236 | 2237 | (defun |-/1| (m) 2238 | (- m)) 2239 | 2240 | (defun |+/2| (m n) 2241 | (+ m n)) 2242 | 2243 | (defun |-/2| (m n) 2244 | (- m n)) 2245 | 2246 | (defun */2 (m n) 2247 | (* m n)) 2248 | 2249 | (defun //2 (m n) 2250 | (truncate m n)) 2251 | 2252 | (defun mod/2 (m n) 2253 | (rem m n)) 2254 | 2255 | (defun cputime/0 nil 2256 | (get-internal-run-time)) 2257 | 2258 | ;; PROOF PRINTING FACILITY 2259 | ;; if including variable names in variables is turned off for speed, variable names 2260 | ;; printed in proof may be ambiguous 2261 | 2262 | (defun print-proof () 2263 | (labels ((rec (goals goalnum ngoals level) 2264 | (dotimes (i ngoals) 2265 | (let ((arity (caar goals)) 2266 | (goal (cadar goals)) 2267 | (nsubgoals (caddar goals)) 2268 | (number (cadddr (car goals)))) 2269 | (format t "~&(~3D)" goalnum) 2270 | (cond ((consp number) (format t "~5D~A " (car number) (cdr number))) 2271 | (number (format t "~5D " number)) 2272 | (t (princ " "))) 2273 | (dotimes (i level) (princ " ")) 2274 | (write-functor-and-arguments (car goal) (subseq goal 1 (1+ arity))) 2275 | (cond ((= nsubgoals 0) 2276 | (princ ".") 2277 | (setq goalnum (1+ goalnum)) 2278 | (setq goals (cdr goals))) 2279 | (t (princ " <-") 2280 | (let ((first t)) 2281 | (dolist (subgoal (collect-goals (cdr goals) nsubgoals)) 2282 | (cond (first (princ " ") (setq first nil)) 2283 | (t (princ " , "))) 2284 | (write-functor-and-arguments 2285 | (car subgoal) 2286 | (subseq subgoal 1 (1+ (get (car subgoal) 'arity)))))) 2287 | (princ ".") 2288 | (multiple-value-setq (goals goalnum) 2289 | (rec (cdr goals) (1+ goalnum) nsubgoals (1+ level))))))) 2290 | (values goals goalnum)) 2291 | (collect-goals (goals ngoals) 2292 | (let (w) 2293 | (dotimes (i ngoals) 2294 | (push (cadar goals) w) 2295 | (setq goals (skip-goals (cdr goals) (caddar goals)))) 2296 | (nreverse w))) 2297 | (skip-goals (goals ngoals) 2298 | (dotimes (i ngoals) 2299 | (setq goals (skip-goals (cdr goals) (caddar goals)))) 2300 | goals)) 2301 | (format t "~2&Proof:~%Goal# Wff# Wff Instance~%----- ---- ------------") 2302 | (rec (reverse *proof*) 0 1 0) 2303 | (values))) 2304 | 2305 | (defun numbered-letter (n) 2306 | (case n 2307 | ( 1 "a") ( 2 "b") ( 3 "c") ( 4 "d") ( 5 "e") ( 6 "f") ( 7 "g") ( 8 "h") ( 9 "i") (10 "j") 2308 | (11 "k") (12 "l") (13 "m") (14 "n") (15 "o") (16 "p") (17 "q") (18 "r") (19 "s") (20 "t") 2309 | (21 "u") (22 "v") (23 "w") (24 "x") (25 "y") (26 "z"))) 2310 | 2311 | (defun chang&lee-examples nil 2312 | (print 'chang&lee-examples) 2313 | (chang&lee-example-1) 2314 | (chang&lee-example-2) 2315 | (chang&lee-example-3) 2316 | (chang&lee-example-4) 2317 | (chang&lee-example-5) 2318 | (chang&lee-example-6) 2319 | (chang&lee-example-7) 2320 | (chang&lee-example-8) 2321 | (chang&lee-example-9)) 2322 | 2323 | (defun chang&lee-example-1 nil 2324 | (print 'chang&lee-example-1) 2325 | (format t "~&Prove that in an associative system with left and right solutions,~%there is a right identity element.") 2326 | (program '(u v w x y z) 2327 | '((p (g x y) x y) 2328 | (p x (h x y) y) 2329 | (-> (and (p x y u) (p y z v) (p x v w)) (p u z w)) 2330 | (-> (and (p x y u) (p y z v) (p u z w)) (p x v w)) 2331 | (<- (query) (and (search (p (k x) x (k x))) !))) 2332 | :incomplete-inference t) 2333 | (query)) 2334 | 2335 | (defun chang&lee-example-2 nil 2336 | (print 'chang&lee-example-2) 2337 | (format t "~&In an associative system with an identity element, if the square~%of every element is the identity, the system~%is commutative.") 2338 | (program '(u v w x y z) 2339 | '((p e x x) 2340 | (p x e x) 2341 | (p x x e) 2342 | (p a b c) 2343 | (-> (and (p x y u) (p y z v) (p x v w)) (p u z w)) 2344 | (-> (and (p x y u) (p y z v) (p u z w)) (p x v w)) 2345 | (<- (query) (and (search (p b a c)) !))) 2346 | :incomplete-inference t) 2347 | (query)) 2348 | 2349 | (defun chang&lee-example-3 nil 2350 | (print 'chang&lee-example-3) 2351 | (format t "~&In a group the left identity element is also a right identity.") 2352 | (program '(u v w x y z) 2353 | '((p e x x) 2354 | (p (i x) x e) 2355 | (-> (and (p x y u) (p y z v) (p x v w)) (p u z w)) 2356 | (-> (and (p x y u) (p y z v) (p u z w)) (p x v w)) 2357 | (<- (query) (and (search (p a e a)) !))) 2358 | :incomplete-inference t) 2359 | (query)) 2360 | 2361 | (defun chang&lee-example-4 nil 2362 | (print 'chang&lee-example-4) 2363 | (format t "~&In a group with left inverse and left identity every element~%has a right inverse.") 2364 | (program '(u v w x y z) 2365 | '((p e x x) 2366 | (p (i x) x e) 2367 | (-> (and (p x y u) (p y z v) (p x v w)) (p u z w)) 2368 | (-> (and (p x y u) (p y z v) (p u z w)) (p x v w)) 2369 | (<- (query) (and (search (p a x e)) !))) 2370 | :incomplete-inference t) 2371 | (query)) 2372 | 2373 | (defun chang&lee-example-5 nil 2374 | (print 'chang&lee-example-5) 2375 | (format t "~&If S is a nonempty subset of a group such that if x,y belong to S,~%then x*y^-1 belongs to S, then the identity e belongs to S.") 2376 | (program '(u v w x y z) 2377 | '((p e x x) 2378 | (p x e x) 2379 | (p x (i x) e) 2380 | (p (i x) x e) 2381 | (s a) 2382 | (-> (and (s x) (s y) (p x (i y) z)) (s z)) 2383 | (-> (and (p x y u) (p y z v) (p x v w)) (p u z w)) 2384 | (-> (and (p x y u) (p y z v) (p u z w)) (p x v w)) 2385 | (<- (query) (and (search (s e)) !))) 2386 | :incomplete-inference t) 2387 | (query)) 2388 | 2389 | (defun chang&lee-example-6 nil 2390 | (print 'chang&lee-example-6) 2391 | (format t "~&If S is a nonempty subset of a group such that if x,y belong to S,~%then x*y^-1 belongs to S, then S contains x^-1 whenever it contains x.") 2392 | (program '(u v w x y z) 2393 | '((p e x x) 2394 | (p x e x) 2395 | (p x (i x) e) 2396 | (p (i x) x e) 2397 | (s a) 2398 | (-> (and (s x) (s y) (p x (i y) z)) (s z)) 2399 | (-> (and (p x y u) (p y z v) (p x v w)) (p u z w)) 2400 | (-> (and (p x y u) (p y z v) (p u z w)) (p x v w)) 2401 | (<- (query) (and (search (s (i a))) !))) 2402 | :incomplete-inference t) 2403 | (query)) 2404 | 2405 | (defun chang&lee-example-7 nil 2406 | (print 'chang&lee-example-7) 2407 | (format t "~&If a is a prime and a = b^2/c^2 then a divides b.") 2408 | (program '(u x y z) 2409 | '((p a) 2410 | (m a (s c) (s b)) 2411 | (m x x (s x)) 2412 | (or (~m x y z) (m y x z)) 2413 | (or (~m x y z) (d x z)) 2414 | (or (~p x) (~m y z u) (~d x u) (d x y) (d x z)) 2415 | (<- (query) (and (search (d a b)) !)))) 2416 | (query)) 2417 | 2418 | (defun chang&lee-example-8 nil 2419 | (print 'chang&lee-example-8) 2420 | (format t "~&Any number greater than 1 has a prime divisor.") 2421 | (program '(x y z) 2422 | '((l 1 a) 2423 | (d x x) 2424 | (or (p x) (d (g x) x)) 2425 | (or (p x) (l 1 (g x))) 2426 | (or (p x) (l (g x) x)) 2427 | (or (~p x) (~d x a)) ; negation of theorem 2428 | (or (~d x y) (~d y z) (d x z)) 2429 | (or (~l 1 x) (~l x a) (p (f x))) 2430 | (or (~l 1 x) (~l x a) (d (f x) x)) 2431 | (<- (query) (and (search (and (p x) (d x a))) !)))) 2432 | (query)) 2433 | 2434 | (defun chang&lee-example-9 nil 2435 | (print 'chang&lee-example-9) 2436 | (format t "~&There exist infinitely many primes.") 2437 | (program '(x y) 2438 | '((l x (f x)) 2439 | (~l x x) 2440 | (or (~l x y) (~l y x)) 2441 | (or (~d x (f y)) (l y x)) 2442 | (or (p x) (d (h x) x)) 2443 | (or (p x) (p (h x))) 2444 | (or (p x) (l (h x) x)) 2445 | (or (~p x) (~l a x) (l (f a) x)) ; negation of theorem 2446 | (<- (query) (and (search (and (p x) (l a x) (~l (f a) x))) !)))) 2447 | (query)) 2448 | --------------------------------------------------------------------------------