--- 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)
--- 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
#:!))
--- 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*)))
+
--- 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