# HG changeset patch # User Steve Losh # Date 1467837716 0 # Node ID 55019395ba9368e7bcf1cf869e8561f63e65f259 # Parent f7b7440c46ff9ab481a256f8841059197758aa7f Normalize facts and queries because people are lazy diff -r f7b7440c46ff -r 55019395ba93 examples/ggp-wam.lisp --- a/examples/ggp-wam.lisp Wed Jul 06 20:08:27 2016 +0000 +++ b/examples/ggp-wam.lisp Wed Jul 06 20:41:56 2016 +0000 @@ -204,13 +204,13 @@ (defun apply-state (state) (push-logic-frame) (loop :for fact :in state - :do (add-fact `(true ,fact))) + :do (invoke-fact `(true ,fact))) (finalize-logic-frame)) (defun apply-moves (moves) (push-logic-frame) (loop :for (role . action) :in moves - :do (add-fact `(does ,role ,action))) + :do (invoke-fact `(does ,role ,action))) (finalize-logic-frame)) diff -r f7b7440c46ff -r 55019395ba93 src/wam/ui.lisp --- a/src/wam/ui.lisp Wed Jul 06 20:08:27 2016 +0000 +++ b/src/wam/ui.lisp Wed Jul 06 20:41:56 2016 +0000 @@ -16,9 +16,28 @@ `(with-database (make-database) ,@body)) +;;;; Normalization +(defun normalize-term (term) + ;; Normally a rule consists of a head terms and multiple body terms, like so: + ;; + ;; (likes sally ?who) (likes ?who cats) + ;; + ;; But sometimes people are lazy and don't include the parens around + ;; zero-arity predicates: + ;; + ;; (happy steve) sunny + (if (and (not (variablep term)) + (symbolp term) + (not (eq term '!))) ; jesus + (list term) + term)) + + ;;;; Assertion (defun invoke-rule (head &rest body) - (wam-logic-frame-add-clause! *database* (list* head body)) + (wam-logic-frame-add-clause! *database* + (list* (normalize-term head) + (mapcar #'normalize-term body))) (values)) (defun invoke-fact (fact) @@ -26,7 +45,7 @@ (values)) (defun invoke-facts (&rest facts) - (mapc #'add-fact facts) + (mapc #'invoke-fact facts) (values)) @@ -59,58 +78,57 @@ ;;;; Querying +(defun perform-query (terms result-function) + (run-query *database* (mapcar #'normalize-term terms) + :result-function result-function)) + + (defun invoke-query (&rest terms) (let ((result nil) (succeeded nil)) - (run-query *database* terms - :result-function (lambda (r) - (setf result r - succeeded t) - t)) + (perform-query terms (lambda (r) + (setf result r + succeeded t) + t)) (values result succeeded))) (defun invoke-query-all (&rest terms) (let ((results nil)) - (run-query *database* terms - :result-function (lambda (result) - (push result results) - nil)) + (perform-query terms (lambda (result) + (push result results) + nil)) (nreverse results))) (defun invoke-query-map (function &rest terms) (let ((results nil)) - (run-query *database* terms - :result-function (lambda (result) - (push (funcall function result) results) - nil)) + (perform-query terms (lambda (result) + (push (funcall function result) results) + nil)) (nreverse results))) (defun invoke-query-do (function &rest terms) - (run-query *database* terms - :result-function (lambda (result) - (funcall function result) - nil)) + (perform-query terms (lambda (result) + (funcall function result) + nil)) (values)) (defun invoke-query-find (predicate &rest terms) (let ((results nil) (succeeded nil)) - (run-query *database* terms - :result-function (lambda (result) - (if (funcall predicate result) - (progn (setf results result - succeeded t) - t) - nil))) + (perform-query terms (lambda (result) + (if (funcall predicate result) + (progn (setf results result + succeeded t) + t) + nil))) (values results succeeded))) (defun invoke-prove (&rest terms) (let ((succeeded nil)) - (run-query *database* terms - :result-function (lambda (result) - (declare (ignore result)) - (setf succeeded t) - t)) + (perform-query terms (lambda (result) + (declare (ignore result)) + (setf succeeded t) + t)) succeeded)) diff -r f7b7440c46ff -r 55019395ba93 test/wam.lisp --- a/test/wam.lisp Wed Jul 06 20:08:27 2016 +0000 +++ b/test/wam.lisp Wed Jul 06 20:41:56 2016 +0000 @@ -68,14 +68,11 @@ (defun results= (r1 r2) (set-equal r1 r2 :test #'result=)) -(defmacro q (&body query) - `(query-all ,@query)) - (defmacro should-fail (&body queries) `(progn ,@(loop :for query :in queries :collect - `(is (results= nil (q ,query)))))) + `(is (results= nil (query-all ,query)))))) (defmacro should-return (&body queries) `(progn @@ -87,43 +84,47 @@ ((equal results '(fail)) nil) (t results)) - (q ,query)))))) + (query-all ,query)))))) ;;;; Tests (test facts-literal (with-database *test-database* - (is (results= '(nil) (q (always)))) - (is (results= '(nil) (q (fuzzy cats)))) - (is (results= nil (q (fuzzy snakes)))))) + (should-return + ((always) empty) + ((fuzzy cats) empty) + ((fuzzy snakes) fail)))) (test facts-variables (with-database *test-database* - (is (results= '((?what cats)) - (q (fuzzy ?what)))) - (is (results= '((?what blues) - (?what rock)) - (q (listens bob ?what)))) - (is (results= '((?who alice) - (?who bob) - (?who candace)) - (q (listens ?who blues)))) - (is (results= '() - (q (listens ?who metal)))))) + (should-return + ((fuzzy ?what) + (?what cats)) + + ((listens bob ?what) + (?what blues) + (?what rock)) + + ((listens ?who blues) + (?who alice) + (?who bob) + (?who candace)) + + ((listens ?who metal) fail)))) (test facts-conjunctions (with-database *test-database* (is (results= '((?who alice)) - (q (listens ?who blues) - (listens ?who jazz)))) + (query-all (listens ?who blues) + (listens ?who jazz)))) (is (results= '((?who alice)) - (q (listens ?who blues) - (drinks ?who bourbon)))) + (query-all (listens ?who blues) + (drinks ?who bourbon)))) (is (results= '((?what bourbon ?who alice) (?what genny-cream ?who bob) (?what birch-beer ?who candace)) - (q (listens ?who blues) - (drinks ?who ?what)))))) + (query-all (listens ?who blues) + (drinks ?who ?what)))))) (test simple-unification (with-fresh-database @@ -414,3 +415,23 @@ ((bar (baz a b c no)) fail) ((bar (baz a b c ?what)) (?what x)) ((wild a b c) empty)))) + +(test normalization-ui + (with-fresh-database + (push-logic-frame-with + (fact a) + (facts (b) + c) + (rule dogs + a b (c))) + (should-return + (a empty) + (b empty) + (c empty) + (d fail) + (dogs empty) + ((a) empty) + ((b) empty) + ((c) empty) + ((d) fail) + (dogs empty))))