# HG changeset patch # User Steve Losh # Date 1467829831 0 # Node ID 0955ab257feff6918be8a96b51ab8f1af6683325 # Parent be83cfc938fb9705d02a0e3a21804c46386795d1 Clean up the UI diff -r be83cfc938fb -r 0955ab257fef examples/ggp-wam.lisp --- a/examples/ggp-wam.lisp Wed Jul 06 13:49:47 2016 +0000 +++ b/examples/ggp-wam.lisp Wed Jul 06 18:30:31 2016 +0000 @@ -167,7 +167,7 @@ (defun initial-state () - (extract '?what (return-all (init ?what)))) + (extract '?what (query-all (init ?what)))) (defun terminalp () (prove (terminal))) @@ -178,28 +178,27 @@ (defun legal-moves () (let* ((individual-moves - (loop :for move :in (return-all (legal ?role ?action)) - :collect (cons (getf move '?role) - (getf move '?action)))) + (query-map (lambda (move) + (cons (getf move '?role) + (getf move '?action))) + (legal ?role ?action))) (joint-moves (apply #'map-product #'list (equivalence-classes #'equiv-roles individual-moves)))) joint-moves)) (defun roles () - (extract '?role (return-all (role ?role)))) + (extract '?role (query-all (role ?role)))) (defun goal-value (role) - (getf (perform-return `((goal ,role ?goal)) - :one) + (getf (invoke-query `(goal ,role ?goal)) '?goal)) (defun goal-values () - (perform-return `((goal ?role ?goal)) - :all)) + (invoke-query-all `(goal ?role ?goal))) (defun next-state () - (extract '?what (return-all (next ?what)))) + (extract '?what (query-all (next ?what)))) (defun apply-state (state) diff -r be83cfc938fb -r 0955ab257fef package-test.lisp --- a/package-test.lisp Wed Jul 06 13:49:47 2016 +0000 +++ b/package-test.lisp Wed Jul 06 18:30:31 2016 +0000 @@ -30,8 +30,8 @@ #:facts #:call #:? - #:return-one - #:return-all) + #:query + #:query-all) (:shadowing-import-from #:bones.wam #:!)) diff -r be83cfc938fb -r 0955ab257fef src/wam/ui.lisp --- a/src/wam/ui.lisp Wed Jul 06 13:49:47 2016 +0000 +++ b/src/wam/ui.lisp Wed Jul 06 18:30:31 2016 +0000 @@ -2,8 +2,7 @@ ;;;; Database -(defparameter *database* nil) -(defvar *results* nil) +(defvar *database* nil) (defun make-database () @@ -60,96 +59,91 @@ ;;;; Querying -(defun display-results (results) - (format t "~%") - (loop :for (var result . more) :on results :by #'cddr :do - (format t "~S = ~S~%" var result))) +(defun invoke-query (&rest terms) + (let ((result nil) + (succeeded nil)) + (run-query *database* terms + :result-function (lambda (r) + (setf result r + succeeded t) + t)) + (values result succeeded))) -(defun display-results-one (results) - (display-results results) - t) +(defun invoke-query-all (&rest terms) + (let ((results nil)) + (run-query *database* terms + :result-function (lambda (result) + (push result results) + nil)) + (nreverse results))) -(defun display-results-all (results) - (display-results results) - nil) +(defun invoke-query-map (function &rest terms) + (let ((results nil)) + (run-query *database* terms + :result-function (lambda (result) + (push (funcall function result) results) + nil)) + (nreverse results))) -(defun display-results-interactive (results) - (display-results results) - (format t "~%More? [Yn] ") - (force-output) - (switch ((read-line) :test #'string=) - ("y" nil) - ("" nil) - ("n" t) - (t t))) - +(defun invoke-query-do (function &rest terms) + (run-query *database* terms + :result-function (lambda (result) + (funcall function result) + nil)) + (values)) -(defun perform-query (query mode) - (run-query *database* query - :result-function - (ecase mode - (:interactive #'display-results-interactive) - (:all #'display-results-all) - (:one #'display-results-one)) - :status-function - (lambda (failp) - (if failp - (princ "No.") - (princ "Yes.")))) - (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))) + (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)) + succeeded)) -(defun return-results-one (results) - (setf *results* results) - t) +(defun quote-terms (terms) + (loop :for term :in terms :collect `',term)) + +(defmacro query (&rest terms) + `(invoke-query ,@(quote-terms terms))) + +(defmacro query-all (&rest terms) + `(invoke-query-all ,@(quote-terms terms))) -(defun return-results-all (results) - (push results *results*) - nil) +(defmacro query-map (function &rest terms) + `(invoke-query-map ,function ,@(quote-terms terms))) + +(defmacro query-do (function &rest terms) + `(invoke-query-do ,function ,@(quote-terms terms))) + +(defmacro query-find (predicate &rest terms) + `(invoke-query-find ,predicate ,@(quote-terms terms))) + +(defmacro prove (&rest terms) + `(invoke-prove ,@(quote-terms terms))) -(defun perform-return (query mode) - (ecase mode - (:all (let ((*results* nil)) - (run-query *database* query - :result-function - #'return-results-all) - (values *results* (ensure-boolean *results*)))) - (:one (let* ((no-results (gensym)) - (*results* no-results)) - (run-query *database* query - :result-function - #'return-results-one) - (if (eql *results* no-results) - (values nil nil) - (values *results* t)))))) - - -(defun perform-prove (query) - (nth-value 1 (perform-return query :one))) - - -(defmacro query (&body body) - `(perform-query ',body :interactive)) - -(defmacro query-all (&body body) - `(perform-query ',body :all)) - -(defmacro query-one (&body body) - `(perform-query ',body :one)) - - -(defmacro return-all (&body body) - `(perform-return ',body :all)) - -(defmacro return-one (&body body) - `(perform-return ',body :one)) - -(defmacro prove (&body body) - `(perform-prove ',body)) - - +;;;; Debugging (defun dump (&optional full-code) (dump-wam-full *database*) (when full-code (dump-wam-code *database*))) + +(defmacro bytecode (&body body) + `(with-fresh-database + (push-logic-frame-with ,@body) + (dump-wam-code *database*))) + diff -r be83cfc938fb -r 0955ab257fef test/wam.lisp --- a/test/wam.lisp Wed Jul 06 13:49:47 2016 +0000 +++ b/test/wam.lisp Wed Jul 06 18:30:31 2016 +0000 @@ -69,7 +69,7 @@ (set-equal r1 r2 :test #'result=)) (defmacro q (&body query) - `(return-all ,@query)) + `(query-all ,@query)) (defmacro should-fail (&body queries) @@ -307,7 +307,7 @@ ;; Check that we can unify against unbound vars that turn into lists (is ((lambda (result) (eql (car (getf result '?anything)) 'a)) - (return-one (member a ?anything)))))) + (query (member a ?anything)))))) (test cut (with-fresh-database