--- a/.lispwords Tue Aug 23 13:10:01 2016 +0000
+++ b/.lispwords Tue Aug 23 17:53:03 2016 +0000
@@ -4,8 +4,9 @@
(1 with-database)
(1 recursively)
(1 when-let)
-(1 rule)
-(0 push-logic-frame-with)
+(2 rule)
+(1 fact facts)
+(1 push-logic-frame-with)
(1 cell-typecase)
(1 opcode-case)
(2 define-invocation)
--- a/package.lisp Tue Aug 23 13:10:01 2016 +0000
+++ b/package.lisp Tue Aug 23 17:53:03 2016 +0000
@@ -1,3 +1,23 @@
+(defpackage #:temperance.internal
+ (:use #:cl))
+
+(in-package #:temperance.internal)
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun external-symbols (package)
+ (let ((symbols nil))
+ (do-external-symbols (s (find-package package) symbols)
+ (push s symbols)))))
+
+(defmacro defpackage-inheriting (name parent-packages &rest args)
+ `(defpackage ,name
+ ,@args
+ ,@(loop :for parent-package :in parent-packages
+ :collect `(:use ,parent-package)
+ :collect `(:export ,@(external-symbols parent-package)))))
+
+
(defpackage #:temperance.utils
(:use
#:cl
@@ -64,8 +84,8 @@
#:temperance.utils)
(:export
#:make-database
- #:reset-database
- #:with-database
+ #:reset-standard-database
+
#:with-fresh-database
#:invoke-rule
@@ -99,42 +119,6 @@
#:?
#:!))
-(defpackage #:temperance
- (:use #:cl #:temperance.wam)
- (:export
- #:make-database
- #:with-database
- #:with-fresh-database
- #:invoke-rule
- #:invoke-fact
- #:invoke-facts
-
- #:rule
- #:fact
- #:facts
-
- #:push-logic-frame
- #:pop-logic-frame
- #:finalize-logic-frame
- #:push-logic-frame-with
-
- #:invoke-query
- #:invoke-query-all
- #:invoke-query-map
- #:invoke-query-do
- #:invoke-query-find
- #:invoke-prove
-
- #:query
- #:query-all
- #:query-map
- #:query-do
- #:query-find
- #:prove
-
- #:call
- #:?
- #:!
-
- ))
+(defpackage-inheriting #:temperance (#:temperance.wam)
+ (:use #:cl))
--- a/src/ui.lisp Tue Aug 23 13:10:01 2016 +0000
+++ b/src/ui.lisp Tue Aug 23 17:53:03 2016 +0000
@@ -2,13 +2,18 @@
;;;; Database
-(defvar *standard-database* nil)
+(defvar *standard-database* (make-wam))
+
+(defun ensure-database (database-designator)
+ (etypecase database-designator
+ ((eql t) *standard-database*)
+ (wam database-designator)))
(defun make-database ()
(make-wam))
-(defun reset-database ()
+(defun reset-standard-database ()
(setf *standard-database* (make-database)))
@@ -39,77 +44,76 @@
;;;; Assertion
-(defun invoke-rule (head &rest body)
- (assert *standard-database* (*standard-database*) "No database.")
- (wam-logic-frame-add-clause! *standard-database*
+(defun invoke-rule (database head &rest body)
+ (wam-logic-frame-add-clause! (ensure-database database)
(list* (normalize-term head)
(mapcar #'normalize-term body)))
nil)
-(defun invoke-fact (fact)
- (invoke-rule fact)
+(defun invoke-fact (database fact)
+ (invoke-rule database fact)
nil)
-(defun invoke-facts (&rest facts)
- (mapc #'invoke-fact facts)
+(defun invoke-facts (database &rest facts)
+ (loop :for fact :in facts
+ :do (invoke-fact database fact))
nil)
-(defmacro rule (head &body body)
- `(invoke-rule ',head ,@(loop :for term :in body :collect `',term)))
+(defmacro rule (database head &body body)
+ `(invoke-rule ,database
+ ',head ,@(loop :for term :in body :collect `',term)))
-(defmacro fact (fact)
- `(invoke-fact ',fact))
+(defmacro fact (database fact)
+ `(invoke-fact ,database ',fact))
-(defmacro facts (&body facts)
- `(progn
- ,@(loop :for f :in facts :collect `(fact ,f))))
+(defmacro facts (database &body facts)
+ (once-only (database)
+ `(progn
+ ,@(loop :for f :in facts :collect `(fact ,database ,f)))))
;;;; Logic Frames
-(defun push-logic-frame ()
- (assert *standard-database* (*standard-database*) "No database.")
- (wam-push-logic-frame! *standard-database*))
+(defun push-logic-frame (database)
+ (wam-push-logic-frame! (ensure-database database)))
-(defun pop-logic-frame ()
- (assert *standard-database* (*standard-database*) "No database.")
- (wam-pop-logic-frame! *standard-database*))
+(defun pop-logic-frame (database)
+ (wam-pop-logic-frame! (ensure-database database)))
-(defun finalize-logic-frame ()
- (assert *standard-database* (*standard-database*) "No database.")
- (wam-finalize-logic-frame! *standard-database*))
+(defun finalize-logic-frame (database)
+ (wam-finalize-logic-frame! (ensure-database database)))
-(defmacro push-logic-frame-with (&body body)
- `(prog2
- (push-logic-frame)
- (progn ,@body)
- (finalize-logic-frame)))
+(defmacro push-logic-frame-with (database &body body)
+ (once-only (database)
+ `(prog2
+ (push-logic-frame ,database)
+ (progn ,@body)
+ (finalize-logic-frame ,database))))
;;;; Querying
-(defun perform-aot-query (code size vars result-function)
- (assert *standard-database* (*standard-database*) "No database.")
- (run-aot-compiled-query *standard-database* code size vars
+(defun perform-aot-query (database code size vars result-function)
+ (run-aot-compiled-query (ensure-database database) code size vars
:result-function result-function))
-(defun perform-query (terms result-function)
- (assert *standard-database* (*standard-database*) "No database.")
- (run-query *standard-database* (mapcar #'normalize-term terms)
+(defun perform-query (database terms result-function)
+ (run-query (ensure-database database)
+ (mapcar #'normalize-term terms)
:result-function result-function))
(defmacro define-invocation ((name aot-name) arglist &body body)
- (with-gensyms (terms data code size vars)
+ (with-gensyms (code size vars)
`(progn
- (defun ,name ,(append arglist `(&rest ,terms))
+ (defun ,name (database ,@arglist &rest terms)
(macrolet ((invoke (result-function)
- `(perform-query ,',terms ,result-function)))
+ `(perform-query database terms ,result-function)))
,@body))
- (defun ,aot-name ,(append arglist `(,data))
- (destructuring-bind (,code ,size ,vars) ,data
+ (defun ,aot-name (database ,@arglist data)
+ (destructuring-bind (,code ,size ,vars) data
(macrolet ((invoke (result-function)
- `(perform-aot-query ,',code ,',size ,',vars
- ,result-function)))
+ `(perform-aot-query database ,',code ,',size ,',vars
+ ,result-function)))
,@body))))))
@@ -165,23 +169,23 @@
(defun quote-terms (terms)
(loop :for term :in terms :collect `',term))
-(defmacro query (&rest terms)
- `(invoke-query ,@(quote-terms terms)))
+(defmacro query (database &rest terms)
+ `(invoke-query ,database ,@(quote-terms terms)))
-(defmacro query-all (&rest terms)
- `(invoke-query-all ,@(quote-terms terms)))
+(defmacro query-all (database &rest terms)
+ `(invoke-query-all ,database ,@(quote-terms terms)))
-(defmacro query-map (function &rest terms)
- `(invoke-query-map ,function ,@(quote-terms terms)))
+(defmacro query-map (database function &rest terms)
+ `(invoke-query-map ,database ,function ,@(quote-terms terms)))
-(defmacro query-do (function &rest terms)
- `(invoke-query-do ,function ,@(quote-terms terms)))
+(defmacro query-do (database function &rest terms)
+ `(invoke-query-do ,database ,function ,@(quote-terms terms)))
-(defmacro query-find (predicate &rest terms)
- `(invoke-query-find ,predicate ,@(quote-terms terms)))
+(defmacro query-find (database predicate &rest terms)
+ `(invoke-query-find ,database ,predicate ,@(quote-terms terms)))
-(defmacro prove (&rest terms)
- `(invoke-prove ,@(quote-terms terms)))
+(defmacro prove (database &rest terms)
+ `(invoke-prove ,database ,@(quote-terms terms)))
;;;; Chili Dogs
@@ -209,12 +213,17 @@
form)))
-(define-invocation-compiler-macro invoke-query invoke-query-aot ())
-(define-invocation-compiler-macro invoke-query-all invoke-query-all-aot ())
-(define-invocation-compiler-macro invoke-query-map invoke-query-map-aot (function))
-(define-invocation-compiler-macro invoke-query-do invoke-query-do-aot (function))
-(define-invocation-compiler-macro invoke-query-find invoke-query-find-aot (predicate))
-(define-invocation-compiler-macro invoke-prove invoke-prove-aot ())
+(define-invocation-compiler-macro invoke-query invoke-query-aot (database))
+
+(define-invocation-compiler-macro invoke-query-all invoke-query-all-aot (database))
+
+(define-invocation-compiler-macro invoke-query-map invoke-query-map-aot (database function))
+
+(define-invocation-compiler-macro invoke-query-do invoke-query-do-aot (database function))
+
+(define-invocation-compiler-macro invoke-query-find invoke-query-find-aot (database predicate))
+
+(define-invocation-compiler-macro invoke-prove invoke-prove-aot (database))
;;;; Debugging
--- a/test/99.lisp Tue Aug 23 13:10:01 2016 +0000
+++ b/test/99.lisp Tue Aug 23 17:53:03 2016 +0000
@@ -9,9 +9,9 @@
(define-test p1
;; Find the last element of a list.
(with-fresh-database
- (push-logic-frame-with
- (fact (last ?x (list ?x)))
- (rule (last ?x (list* ? ?tail))
+ (push-logic-frame-with t
+ (fact t (last ?x (list ?x)))
+ (rule t (last ?x (list* ? ?tail))
(last ?x ?tail)))
(should-return
@@ -33,9 +33,9 @@
(define-test p2
;; Find the last but one element of a list.
(with-fresh-database
- (push-logic-frame-with
- (fact (last-but-one ?x (list ?x ?)))
- (rule (last-but-one ?x (list* ? ?tail))
+ (push-logic-frame-with t
+ (fact t (last-but-one ?x (list ?x ?)))
+ (rule t (last-but-one ?x (list* ? ?tail))
(last-but-one ?x ?tail)))
(should-return
@@ -57,12 +57,12 @@
(defun %reverse ()
- (push-logic-frame-with
- (fact (reverse-acc nil ?acc ?acc))
- (rule (reverse-acc (list* ?x ?tail) ?acc ?reversed)
+ (push-logic-frame-with t
+ (fact t (reverse-acc nil ?acc ?acc))
+ (rule t (reverse-acc (list* ?x ?tail) ?acc ?reversed)
(reverse-acc ?tail (list* ?x ?acc) ?reversed))
- (rule (reverse ?l ?r)
+ (rule t (reverse ?l ?r)
(reverse-acc ?l nil ?r))))
(define-test p5
@@ -87,8 +87,8 @@
;; Find out whether a list is a palindrome.
(with-fresh-database
(%reverse)
- (push-logic-frame-with
- (rule (palindrome ?l)
+ (push-logic-frame-with t
+ (rule t (palindrome ?l)
(reverse ?l ?l)))
(should-return
@@ -107,18 +107,18 @@
(%not)
(%append)
- (push-logic-frame-with
- (fact (is-list nil))
- (fact (is-list (list* ? ?)))
+ (push-logic-frame-with t
+ (fact t (is-list nil))
+ (fact t (is-list (list* ? ?)))
- (fact (flatten nil nil))
+ (fact t (flatten nil nil))
- (rule (flatten (list* ?atom ?tail)
- (list* ?atom ?flat-tail))
+ (rule t (flatten (list* ?atom ?tail)
+ (list* ?atom ?flat-tail))
(not (is-list ?atom))
(flatten ?tail ?flat-tail))
- (rule (flatten (list* ?head ?tail) ?flattened)
+ (rule t (flatten (list* ?head ?tail) ?flattened)
(is-list ?head)
(flatten ?head ?flat-head)
(flatten ?tail ?flat-tail)
@@ -150,14 +150,14 @@
(%=)
(%not)
- (push-logic-frame-with
- (fact (compress nil nil))
- (fact (compress (list ?x) (list ?x)))
+ (push-logic-frame-with t
+ (fact t (compress nil nil))
+ (fact t (compress (list ?x) (list ?x)))
- (rule (compress (list* ?x ?x ?rest) ?result)
+ (rule t (compress (list* ?x ?x ?rest) ?result)
(compress (list* ?x ?rest) ?result))
- (rule (compress (list* ?x ?y ?rest) (list* ?x ?result))
+ (rule t (compress (list* ?x ?y ?rest) (list* ?x ?result))
(not (= ?x ?y))
(compress (list* ?y ?rest) ?result)))
@@ -185,17 +185,17 @@
; (%=)
; (%not)
-; (push-logic-frame-with
-; (fact (pack nil nil))
-; (fact (pack (list ?x) (list (list ?x))))
+; (push-logic-frame-with t
+; (fact t (pack nil nil))
+; (fact t (pack (list ?x) (list (list ?x))))
-; (rule (pack (list* ?x ?tail)
+; (rule t (pack (list* ?x ?tail)
; (list* (list ?x) ?ptail))
; (pack ?tail ?ptail)
; (= ?ptail (list* (list* ?y ?) ?))
; (not (= ?x ?y)))
-; (rule (pack (list* ?h ?tail)
+; (rule t (pack (list* ?h ?tail)
; (list* (list* ?h ?h ?hs) ?more))
; (pack ?tail (list* (list* ?h ?hs) ?more))))
@@ -214,9 +214,9 @@
(define-test p14
;; Duplicate the elements of a list.
(with-fresh-database
- (push-logic-frame-with
- (fact (duplicate nil nil))
- (rule (duplicate (list* ?x ?rest) (list* ?x ?x ?rest-dup))
+ (push-logic-frame-with t
+ (fact t (duplicate nil nil))
+ (rule t (duplicate (list* ?x ?rest) (list* ?x ?x ?rest-dup))
(duplicate ?rest ?rest-dup)))
(should-return
--- a/test/taop.lisp Tue Aug 23 13:10:01 2016 +0000
+++ b/test/taop.lisp Tue Aug 23 17:53:03 2016 +0000
@@ -6,83 +6,84 @@
(with-fresh-database
(%=)
(%not)
- (push-logic-frame-with
- (facts (father abraham isaac)
- (father haran lot)
- (father haran milcah)
- (father haran yiscah)
- (father terach abraham)
- (father terach nachor)
- (father terach haran)
- (mother sarah isaac)
- (male isaac)
- (male lot)
- (male terach)
- (male nachor)
- (male haran)
- (male abraham)
- (female sarah)
- (female milcah)
- (female yiscah))
+ (push-logic-frame-with t
+ (facts t
+ (father abraham isaac)
+ (father haran lot)
+ (father haran milcah)
+ (father haran yiscah)
+ (father terach abraham)
+ (father terach nachor)
+ (father terach haran)
+ (mother sarah isaac)
+ (male isaac)
+ (male lot)
+ (male terach)
+ (male nachor)
+ (male haran)
+ (male abraham)
+ (female sarah)
+ (female milcah)
+ (female yiscah))
- (rule (parent ?person ?kid) (father ?person ?kid))
- (rule (parent ?person ?kid) (mother ?person ?kid))
+ (rule t (parent ?person ?kid) (father ?person ?kid))
+ (rule t (parent ?person ?kid) (mother ?person ?kid))
- (rule (father ?person) (father ?person ?))
- (rule (mother ?person) (mother ?person ?))
- (rule (parent ?person) (father ?person))
- (rule (parent ?person) (mother ?person))
+ (rule t (father ?person) (father ?person ?))
+ (rule t (mother ?person) (mother ?person ?))
+ (rule t (parent ?person) (father ?person))
+ (rule t (parent ?person) (mother ?person))
- (rule (grandparent ?person ?grandkid)
+ (rule t (grandparent ?person ?grandkid)
(parent ?person ?kid)
(parent ?kid ?grandkid))
- (rule (grandmother ?person ?grandkid)
+ (rule t (grandmother ?person ?grandkid)
(grandparent ?person ?grandkid)
(female ?person))
- (rule (grandfather ?person ?grandkid)
+ (rule t (grandfather ?person ?grandkid)
(grandparent ?person ?grandkid)
(male ?person))
- (rule (son ?parent ?kid)
+ (rule t (son ?parent ?kid)
(parent ?parent ?kid)
(male ?kid))
- (rule (daughter ?parent ?kid)
+ (rule t (daughter ?parent ?kid)
(parent ?parent ?kid)
(female ?kid))
- (rule (siblings ?x ?y)
+ (rule t (siblings ?x ?y)
(parent ?p ?x)
(parent ?p ?y)
(not (= ?x ?y)))
- (rule (brother ?bro ?person)
+ (rule t (brother ?bro ?person)
(siblings ?bro ?person)
(male ?bro))
- (rule (sister ?sis ?person)
+ (rule t (sister ?sis ?person)
(siblings ?sis ?person)
(female ?sis))
- (rule (uncle ?unc ?kid)
+ (rule t (uncle ?unc ?kid)
(brother ?unc ?parent)
(parent ?parent ?kid))
- (rule (aunt ?unc ?kid)
+ (rule t (aunt ?unc ?kid)
(sister ?unc ?parent)
(parent ?parent ?kid))
- (rule (cousins ?x ?y)
+ (rule t (cousins ?x ?y)
(parent ?px ?x)
(parent ?py ?y)
(siblings ?px ?py))
- (rule (ancestor ?old ?young)
+ (rule t (ancestor ?old ?young)
(parent ?old ?young))
- (rule (ancestor ?old ?young)
+ (rule t (ancestor ?old ?young)
(parent ?old ?p)
(ancestor ?p ?young)))
@@ -119,28 +120,30 @@
(%=)
(%not)
- (push-logic-frame-with
+ (push-logic-frame-with t
;; and gate
;; (resistor name node-1 node-2)
- (facts (resistor r1 power n1)
- (resistor r2 power n2))
+ (facts t
+ (resistor r1 power n1)
+ (resistor r2 power n2))
;; (transistor name gate source drain)
- (facts (transistor t1 n2 ground n1)
- (transistor t2 n3 n4 n2)
- (transistor t3 n5 ground n4))
+ (facts t
+ (transistor t1 n2 ground n1)
+ (transistor t2 n3 n4 n2)
+ (transistor t3 n5 ground n4))
- (rule (inverter (inverter ?t ?r) ?input ?output)
+ (rule t (inverter (inverter ?t ?r) ?input ?output)
(transistor ?t ?input ground ?output)
(resistor ?r power ?output))
- (rule (nand (nand ?t1 ?t2 ?r) ?a ?b ?output)
+ (rule t (nand (nand ?t1 ?t2 ?r) ?a ?b ?output)
(transistor ?t1 ?a ?x ?output)
(transistor ?t2 ?b ground ?x)
(resistor ?r power ?output))
- (rule (and (and ?n ?i) ?a ?b ?output)
+ (rule t (and (and ?n ?i) ?a ?b ?output)
(nand ?n ?a ?b ?x)
(inverter ?i ?x ?output)))
@@ -149,27 +152,28 @@
(?a n3 ?b n5 ?out n1 ?g (and (nand t2 t3 r2)
(inverter t1 r1)))))
- (pop-logic-frame)
+ (pop-logic-frame t)
- (push-logic-frame-with
+ (push-logic-frame-with t
;; nor gate
- (facts (resistor r1 power o)
- (transistor t1 i1 ground o)
- (transistor t2 i2 ground o)
- (resistor r2 power no)
- (transistor t3 o ground no))
+ (facts t
+ (resistor r1 power o)
+ (transistor t1 i1 ground o)
+ (transistor t2 i2 ground o)
+ (resistor r2 power no)
+ (transistor t3 o ground no))
- (rule (inverter (inverter ?t ?r) ?input ?output)
+ (rule t (inverter (inverter ?t ?r) ?input ?output)
(transistor ?t ?input ground ?output)
(resistor ?r power ?output))
- (rule (or (or ?t1 ?t2 ?r) ?a ?b ?output)
+ (rule t (or (or ?t1 ?t2 ?r) ?a ?b ?output)
(transistor ?t1 ?a ground ?output)
(transistor ?t2 ?b ground ?output)
(not (= ?a ?b))
(resistor ?r power ?output))
- (rule (nor (nor ?o ?i) ?a ?b ?output)
+ (rule t (nor (nor ?o ?i) ?a ?b ?output)
(or ?o ?a ?b ?x)
(inverter ?i ?x ?output)))
@@ -185,38 +189,39 @@
(define-test courses
(with-fresh-database
- (push-logic-frame-with
- (facts (course complexity
- (time monday 9 11)
- (lecturer david harel)
- (location feinberg a))
- (course lisp
- (time monday 10 12)
- (lecturer alyssa p hacker)
- (location main-hall))
- (course scheme
- (time monday 12 15)
- (lecturer alyssa p hacker)
- (location online))
- (course prolog
- (time tuesday 12 15)
- (lecturer ben bitdiddle)
- (location feinberg b))
- (course haskell
- (time wednesday 12 15)
- (lecturer ben bitdiddle)
- (location online)))
+ (push-logic-frame-with t
+ (facts t
+ (course complexity
+ (time monday 9 11)
+ (lecturer david harel)
+ (location feinberg a))
+ (course lisp
+ (time monday 10 12)
+ (lecturer alyssa p hacker)
+ (location main-hall))
+ (course scheme
+ (time monday 12 15)
+ (lecturer alyssa p hacker)
+ (location online))
+ (course prolog
+ (time tuesday 12 15)
+ (lecturer ben bitdiddle)
+ (location feinberg b))
+ (course haskell
+ (time wednesday 12 15)
+ (lecturer ben bitdiddle)
+ (location online)))
- (rule (lecturer ?who ?course)
+ (rule t (lecturer ?who ?course)
(course ?course ? ?who ?))
- (rule (teaches-on ?who ?day)
+ (rule t (teaches-on ?who ?day)
(course ? (time ?day ? ?) ?who ?))
- (rule (teaches-in ?who ?location)
+ (rule t (teaches-in ?who ?location)
(course ? ? ?who ?location))
- (rule (location-of ?course ?location)
+ (rule t (location-of ?course ?location)
(course ?course ? ? ?location)))
(should-return
@@ -239,17 +244,18 @@
(define-test books
(with-fresh-database
(%member)
- (push-logic-frame-with
- (facts (book paip (list norvig) 1992)
- (book sicp (list abelson sussman) 1996)
- (book lol (list hoyte) 2008)
- (book clos (list keene) 1988))
+ (push-logic-frame-with t
+ (facts t
+ (book paip (list norvig) 1992)
+ (book sicp (list abelson sussman) 1996)
+ (book lol (list hoyte) 2008)
+ (book clos (list keene) 1988))
- (rule (wrote ?who ?title)
+ (rule t (wrote ?who ?title)
(book ?title ?authors ?)
(member ?who ?authors))
- (rule (published-in ?who ?year)
+ (rule t (published-in ?who ?year)
(book ? ?authors ?year)
(member ?who ?authors)))
@@ -264,16 +270,17 @@
(define-test graph
(with-fresh-database
- (push-logic-frame-with
- (facts (edge a b)
- (edge c d)
- (edge a c)
- (edge d e)
- (edge b d)
- (edge f g))
+ (push-logic-frame-with t
+ (facts t
+ (edge a b)
+ (edge c d)
+ (edge a c)
+ (edge d e)
+ (edge b d)
+ (edge f g))
- (fact (connected ?node ?node))
- (rule (connected ?node-1 ?node-2)
+ (fact t (connected ?node ?node))
+ (rule t (connected ?node-1 ?node-2)
(edge ?node-1 ?link)
(connected ?link ?node-2)))
--- a/test/utils.lisp Tue Aug 23 13:10:01 2016 +0000
+++ b/test/utils.lisp Tue Aug 23 17:53:03 2016 +0000
@@ -25,7 +25,7 @@
(defmacro should-fail (&body queries)
`(progn
,@(loop :for query :in queries :collect
- `(is (results= nil (query-all ,query))))))
+ `(is (results= nil (query-all t ,query))))))
(defmacro should-return (&body queries)
`(progn
@@ -37,26 +37,27 @@
((equal results '(fail))
nil)
(t results))
- (query-all ,query))))))
+ (query-all t ,query))))))
;;;; Prolog
(defun %= ()
- (push-logic-frame-with
- (fact (= ?x ?x))))
+ (push-logic-frame-with t
+ (fact t (= ?x ?x))))
(defun %not ()
- (push-logic-frame-with
- (rule (not ?x) (call ?x) ! fail)
- (fact (not ?x))))
+ (push-logic-frame-with t
+ (rule t (not ?x) (call ?x) ! fail)
+ (fact t (not ?x))))
+
(defun %append ()
- (push-logic-frame-with
- (fact (append nil ?l ?l))
- (rule (append (list* ?x ?rest) ?l (list* ?x ?result))
+ (push-logic-frame-with t
+ (fact t (append nil ?l ?l))
+ (rule t (append (list* ?x ?rest) ?l (list* ?x ?result))
(append ?rest ?l ?result))))
(defun %member ()
- (push-logic-frame-with
- (fact (member ?x (list* ?x ?)))
- (rule (member ?x (list* ? ?rest))
+ (push-logic-frame-with t
+ (fact t (member ?x (list* ?x ?)))
+ (rule t (member ?x (list* ? ?rest))
(member ?x ?rest))))
--- a/test/wam.lisp Tue Aug 23 13:10:01 2016 +0000
+++ b/test/wam.lisp Tue Aug 23 17:53:03 2016 +0000
@@ -3,53 +3,52 @@
;;;; Setup
(defun make-test-database ()
(let ((db (make-database)))
- (with-database db
- (push-logic-frame-with
+ (push-logic-frame-with db
- (facts (always)
+ (facts db
+ (always)
- (drinks tom ?anything)
- (drinks kim water)
- (drinks alice bourbon)
- (drinks bob genny-cream)
- (drinks candace birch-beer)
+ (drinks tom ?anything)
+ (drinks kim water)
+ (drinks alice bourbon)
+ (drinks bob genny-cream)
+ (drinks candace birch-beer)
- (listens alice blues)
- (listens alice jazz)
- (listens bob blues)
- (listens bob rock)
- (listens candace blues)
+ (listens alice blues)
+ (listens alice jazz)
+ (listens bob blues)
+ (listens bob rock)
+ (listens candace blues)
- (fuzzy cats)
+ (fuzzy cats)
- (cute cats)
- (cute snakes))
+ (cute cats)
+ (cute snakes))
- (rule (pets alice ?what)
- (cute ?what))
+ (rule db (pets alice ?what)
+ (cute ?what))
- (rule (pets bob ?what)
- (cute ?what)
- (fuzzy ?what))
+ (rule db (pets bob ?what)
+ (cute ?what)
+ (fuzzy ?what))
- (rule (pets candace ?bird)
- (flies ?bird))
+ (rule db (pets candace ?bird)
+ (flies ?bird))
- (rule (likes sally ?who)
- (likes ?who cats)
- (drinks ?who beer))
-
- (facts (likes tom cats)
- (likes alice cats)
- (likes kim cats))
+ (rule db (likes sally ?who)
+ (likes ?who cats)
+ (drinks ?who beer))
- (rule (likes kim ?who)
- (likes ?who cats))
+ (facts db (likes tom cats)
+ (likes alice cats)
+ (likes kim cats))
- (rule (narcissist ?person)
- (likes ?person ?person)))
+ (rule db (likes kim ?who)
+ (likes ?who cats))
- )
+ (rule db (narcissist ?person)
+ (likes ?person ?person)))
+
db))
(defparameter *test-database* (make-test-database))
@@ -83,21 +82,24 @@
(define-test facts-conjunctions
(with-database *test-database*
(is (results= '((?who alice))
- (query-all (listens ?who blues)
+ (query-all t
+ (listens ?who blues)
(listens ?who jazz))))
(is (results= '((?who alice))
- (query-all (listens ?who blues)
+ (query-all t
+ (listens ?who blues)
(drinks ?who bourbon))))
(is (results= '((?what bourbon ?who alice)
(?what genny-cream ?who bob)
(?what birch-beer ?who candace))
- (query-all (listens ?who blues)
+ (query-all t
+ (listens ?who blues)
(drinks ?who ?what))))))
(define-test simple-unification
(with-fresh-database
- (push-logic-frame-with
- (rule (= ?x ?x)))
+ (push-logic-frame-with t
+ (rule t (= ?x ?x)))
(should-return
((= x x) empty)
((= x y) fail)
@@ -110,12 +112,12 @@
(define-test dynamic-call
(with-fresh-database
- (push-logic-frame-with
- (facts (g cats)
- (g (f dogs)))
- (rule (normal ?x)
+ (push-logic-frame-with t
+ (facts t (g cats)
+ (g (f dogs)))
+ (rule t (normal ?x)
(g ?x))
- (rule (dynamic ?struct)
+ (rule t (dynamic ?struct)
(call ?struct)))
(should-return
((normal foo) fail)
@@ -136,11 +138,11 @@
(define-test negation
(with-fresh-database
- (push-logic-frame-with
- (fact (yes ?anything))
+ (push-logic-frame-with t
+ (fact t (yes ?anything))
- (rule (not ?x) (call ?x) ! fail)
- (rule (not ?x)))
+ (rule t (not ?x) (call ?x) ! fail)
+ (rule t (not ?x)))
(should-return
((yes x) empty)
((no x) fail)
@@ -149,57 +151,57 @@
(define-test backtracking
(with-fresh-database
- (push-logic-frame-with
- (facts (b))
- (facts (c))
- (facts (d))
- (rule (f ?x) (a))
- (rule (f ?x) (b) (c))
- (rule (f ?x) (d)))
+ (push-logic-frame-with t
+ (facts t (b))
+ (facts t (c))
+ (facts t (d))
+ (rule t (f ?x) (a))
+ (rule t (f ?x) (b) (c))
+ (rule t (f ?x) (d)))
(should-return
((f foo) empty)))
(with-fresh-database
- (push-logic-frame-with
- ; (facts (a))
- (facts (b))
- (facts (c))
- (facts (d))
- (rule (f ?x) (a))
- (rule (f ?x) (b) (c))
- (rule (f ?x) (d)))
+ (push-logic-frame-with t
+ ; (facts t (a))
+ (facts t (b))
+ (facts t (c))
+ (facts t (d))
+ (rule t (f ?x) (a))
+ (rule t (f ?x) (b) (c))
+ (rule t (f ?x) (d)))
(should-return
((f foo) empty)))
(with-fresh-database
- (push-logic-frame-with
- ; (facts (a))
- (facts (b))
- (facts (c))
- ; (facts (d))
- (rule (f ?x) (a))
- (rule (f ?x) (b) (c))
- (rule (f ?x) (d)))
+ (push-logic-frame-with t
+ ; (facts t (a))
+ (facts t (b))
+ (facts t (c))
+ ; (facts t (d))
+ (rule t (f ?x) (a))
+ (rule t (f ?x) (b) (c))
+ (rule t (f ?x) (d)))
(should-return
((f foo) empty)))
(with-fresh-database
- (push-logic-frame-with
- ; (facts (a))
- ; (facts (b))
- (facts (c))
- ; (facts (d))
- (rule (f ?x) (a))
- (rule (f ?x) (b) (c))
- (rule (f ?x) (d)))
+ (push-logic-frame-with t
+ ; (facts t (a))
+ ; (facts t (b))
+ (facts t (c))
+ ; (facts t (d))
+ (rule t (f ?x) (a))
+ (rule t (f ?x) (b) (c))
+ (rule t (f ?x) (d)))
(should-return
((f foo) fail)))
(with-fresh-database
- (push-logic-frame-with
- ; (facts (a))
- (facts (b))
- ; (facts (c))
- ; (facts (d))
- (rule (f ?x) (a))
- (rule (f ?x) (b) (c))
- (rule (f ?x) (d)))
+ (push-logic-frame-with t
+ ; (facts t (a))
+ (facts t (b))
+ ; (facts t (c))
+ ; (facts t (d))
+ (rule t (f ?x) (a))
+ (rule t (f ?x) (b) (c))
+ (rule t (f ?x) (d)))
(should-return
((f foo) fail))))
@@ -234,12 +236,12 @@
(define-test register-allocation
;; test for tricky register allocation bullshit
(with-fresh-database
- (push-logic-frame-with
- (fact (a fact-a fact-a))
- (fact (b fact-b fact-b))
- (fact (c fact-c fact-c))
+ (push-logic-frame-with t
+ (fact t (a fact-a fact-a))
+ (fact t (b fact-b fact-b))
+ (fact t (c fact-c fact-c))
- (rule (foo ?x)
+ (rule t (foo ?x)
(a ?a ?a)
(b ?b ?b)
(c ?c ?c)))
@@ -249,9 +251,9 @@
(define-test lists
(with-fresh-database
- (push-logic-frame-with
- (rule (member ?x (list* ?x ?)))
- (rule (member ?x (list* ?y ?rest))
+ (push-logic-frame-with t
+ (rule t (member ?x (list* ?x ?)))
+ (rule t (member ?x (list* ?y ?rest))
(member ?x ?rest)))
(should-fail
@@ -276,22 +278,22 @@
;; Check that we can unify against unbound vars that turn into lists
(is ((lambda (result)
(eql (car (getf result '?anything)) 'a))
- (query (member a ?anything))))))
+ (query t (member a ?anything))))))
(define-test cut
(with-fresh-database
- (push-logic-frame-with
- (facts (a))
- (facts (b))
- (facts (c))
- (facts (d))
+ (push-logic-frame-with t
+ (facts t (a))
+ (facts t (b))
+ (facts t (c))
+ (facts t (d))
- (rule (f a) (a))
- (rule (f bc) (b) ! (c))
- (rule (f d) (d))
+ (rule t (f a) (a))
+ (rule t (f bc) (b) ! (c))
+ (rule t (f d) (d))
- (rule (g ?what) (never))
- (rule (g ?what) (f ?what)))
+ (rule t (g ?what) (never))
+ (rule t (g ?what) (f ?what)))
(should-return
((f ?what)
(?what a)
@@ -301,18 +303,18 @@
(?what bc))))
(with-fresh-database
- (push-logic-frame-with
- ; (facts (a))
- (facts (b))
- (facts (c))
- (facts (d))
+ (push-logic-frame-with t
+ ; (facts t (a))
+ (facts t (b))
+ (facts t (c))
+ (facts t (d))
- (rule (f a) (a))
- (rule (f bc) (b) ! (c))
- (rule (f d) (d))
+ (rule t (f a) (a))
+ (rule t (f bc) (b) ! (c))
+ (rule t (f d) (d))
- (rule (g ?what) (never))
- (rule (g ?what) (f ?what)))
+ (rule t (g ?what) (never))
+ (rule t (g ?what) (f ?what)))
(should-return
((f ?what)
(?what bc))
@@ -320,18 +322,18 @@
(?what bc))))
(with-fresh-database
- (push-logic-frame-with
- ; (facts (a))
- ; (facts (b))
- (facts (c))
- (facts (d))
+ (push-logic-frame-with t
+ ; (facts t (a))
+ ; (facts t (b))
+ (facts t (c))
+ (facts t (d))
- (rule (f a) (a))
- (rule (f bc) (b) ! (c))
- (rule (f d) (d))
+ (rule t (f a) (a))
+ (rule t (f bc) (b) ! (c))
+ (rule t (f d) (d))
- (rule (g ?what) (never))
- (rule (g ?what) (f ?what)))
+ (rule t (g ?what) (never))
+ (rule t (g ?what) (f ?what)))
(should-return
((f ?what)
(?what d))
@@ -339,50 +341,50 @@
(?what d))))
(with-fresh-database
- (push-logic-frame-with
- ; (facts (a))
- (facts (b))
- ; (facts (c))
- (facts (d))
+ (push-logic-frame-with t
+ ; (facts t (a))
+ (facts t (b))
+ ; (facts t (c))
+ (facts t (d))
- (rule (f a) (a))
- (rule (f bc) (b) ! (c))
- (rule (f d) (d))
+ (rule t (f a) (a))
+ (rule t (f bc) (b) ! (c))
+ (rule t (f d) (d))
- (rule (g ?what) (never))
- (rule (g ?what) (f ?what)))
+ (rule t (g ?what) (never))
+ (rule t (g ?what) (f ?what)))
(should-fail
(f ?what)
(g ?what)))
(with-fresh-database
- (push-logic-frame-with
- ; (facts (a))
- ; (facts (b))
- (facts (c))
- ; (facts (d))
+ (push-logic-frame-with t
+ ; (facts t (a))
+ ; (facts t (b))
+ (facts t (c))
+ ; (facts t (d))
- (rule (f a) (a))
- (rule (f bc) (b) ! (c))
- (rule (f d) (d))
+ (rule t (f a) (a))
+ (rule t (f bc) (b) ! (c))
+ (rule t (f d) (d))
- (rule (g ?what) (never))
- (rule (g ?what) (f ?what)))
+ (rule t (g ?what) (never))
+ (rule t (g ?what) (f ?what)))
(should-fail
(f ?what)
(g ?what))))
(define-test anonymous-variables
(with-fresh-database
- (push-logic-frame-with
- (fact (following (s ? ? ? a)))
- (fact (foo x))
- (rule (bar (baz ?x ?y ?z ?thing))
+ (push-logic-frame-with t
+ (fact t (following (s ? ? ? a)))
+ (fact t (foo x))
+ (rule t (bar (baz ?x ?y ?z ?thing))
(foo ?thing))
- (fact (wild ? ? ?))
+ (fact t (wild ? ? ?))
- (fact (does x move))
- (rule (next z)
+ (fact t (does x move))
+ (rule t (next z)
(does ? move)))
(should-return
((following (s x x x a)) empty)
@@ -394,11 +396,11 @@
(define-test normalization-ui
(with-fresh-database
- (push-logic-frame-with
- (fact a)
- (facts (b)
- c)
- (rule dogs
+ (push-logic-frame-with t
+ (fact t a)
+ (facts t (b)
+ c)
+ (rule t dogs
a b (c)))
(should-return
(a empty)
@@ -414,8 +416,8 @@
(define-test nested-constants
(with-fresh-database
- (push-logic-frame-with
- (fact (foo (s a b c))))
+ (push-logic-frame-with t
+ (fact t (foo (s a b c))))
(should-return
((foo (s ?x ?y ?z))
(?x a ?y b ?z c)))))
@@ -429,27 +431,28 @@
(let* ((big-ass-list (loop :repeat 1000 :collect 'a))
(big-ass-result (reverse (cons 'x big-ass-list))))
(with-fresh-database
- (push-logic-frame-with
- (invoke-fact `(big-ass-list (list ,@big-ass-list)))
+ (push-logic-frame-with t
+ (invoke-fact t `(big-ass-list (list ,@big-ass-list)))
- (fact (append nil ?l ?l))
- (rule (append (list* ?i ?tail) ?other (list* ?i ?l))
+ (fact t (append nil ?l ?l))
+ (rule t (append (list* ?i ?tail) ?other (list* ?i ?l))
(append ?tail ?other ?l)))
(is (results= `((?bal ,big-ass-list ?bar ,big-ass-result))
- (query-all (big-ass-list ?bal)
+ (query-all t
+ (big-ass-list ?bal)
(append ?bal (list x) ?bar)))))))
(define-test hanoi
;; From The Art of Prolog
(with-fresh-database
- (push-logic-frame-with
- (fact (append nil ?l ?l))
- (rule (append (list* ?i ?tail) ?other (list* ?i ?l))
+ (push-logic-frame-with t
+ (fact t (append nil ?l ?l))
+ (rule t (append (list* ?i ?tail) ?other (list* ?i ?l))
(append ?tail ?other ?l))
- (fact (hanoi zero ?a ?b ?c nil))
- (rule (hanoi (s ?n) ?a ?b ?c ?moves)
+ (fact t (hanoi zero ?a ?b ?c nil))
+ (rule t (hanoi (s ?n) ?a ?b ?c ?moves)
(hanoi ?n ?a ?c ?b ?moves1)
(hanoi ?n ?c ?b ?a ?moves2)
(append ?moves1 (list* (move ?a ?b) ?moves2) ?moves)))
@@ -467,13 +470,13 @@
(define-test numbers
(with-fresh-database
- (push-logic-frame-with
- (rule (= ?x ?x))
- (fact (foo 1))
- (fact (bar 2))
- (rule (baz ?x) (foo ?x))
- (rule (baz ?x) (bar ?x))
- (rule (lol ?x)
+ (push-logic-frame-with t
+ (rule t (= ?x ?x))
+ (fact t (foo 1))
+ (fact t (bar 2))
+ (rule t (baz ?x) (foo ?x))
+ (rule t (baz ?x) (bar ?x))
+ (rule t (lol ?x)
(foo ?x)
(bar ?x)))