# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1461333042 0
# Node ID 678ab674bd3341521f21e5bea84b193af1e3fd05
# Parent  53d629a6aa6988a51dc4dd7e3c4c7ee0cecd215a
Add result returning

Might refuckulate how the final functions are called to match PAIP's idea
later...

diff -r 53d629a6aa69 -r 678ab674bd33 src/make-quickutils.lisp
--- a/src/make-quickutils.lisp	Fri Apr 22 13:27:41 2016 +0000
+++ b/src/make-quickutils.lisp	Fri Apr 22 13:50:42 2016 +0000
@@ -15,6 +15,7 @@
                :zip
                :alist-to-hash-table
                :map-tree
+               :weave
                :range
                )
   :package "BONES.QUICKUTILS")
diff -r 53d629a6aa69 -r 678ab674bd33 src/quickutils.lisp
--- a/src/quickutils.lisp	Fri Apr 22 13:27:41 2016 +0000
+++ b/src/quickutils.lisp	Fri Apr 22 13:50:42 2016 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :RANGE) :ensure-package T :package "BONES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :RANGE) :ensure-package T :package "BONES.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "BONES.QUICKUTILS")
@@ -20,7 +20,7 @@
                                          :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
                                          :TREE-MEMBER-P :TREE-COLLECT
                                          :TRANSPOSE :ZIP :ALIST-TO-HASH-TABLE
-                                         :MAP-TREE :RANGE))))
+                                         :MAP-TREE :WEAVE :RANGE))))
 
   (defun %reevaluate-constant (name value test)
     (if (not (boundp name))
@@ -289,6 +289,12 @@
       (rec tree)))
   
 
+  (defun weave (&rest lists)
+    "Return a list whose elements alternate between each of the lists
+`lists`. Weaving stops when any of the lists has been exhausted."
+    (apply #'mapcan #'list lists))
+  
+
   (defun range (start end &key (step 1) (key 'identity))
     "Return the list of numbers `n` such that `start <= n < end` and
 `n = start + k*step` for suitable integers `k`. If a function `key` is
@@ -299,6 +305,6 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(define-constant set-equal curry switch eswitch cswitch
             ensure-boolean while until tree-member-p tree-collect with-gensyms
-            with-unique-names zip alist-to-hash-table map-tree range)))
+            with-unique-names zip alist-to-hash-table map-tree weave range)))
 
 ;;;; END OF quickutils.lisp ;;;;
diff -r 53d629a6aa69 -r 678ab674bd33 src/wam/ui.lisp
--- a/src/wam/ui.lisp	Fri Apr 22 13:27:41 2016 +0000
+++ b/src/wam/ui.lisp	Fri Apr 22 13:50:42 2016 +0000
@@ -2,6 +2,7 @@
 
 
 (defparameter *database* nil)
+(defvar *results* nil)
 
 (defmacro with-database (&body body)
   `(let ((*database* (make-wam)))
@@ -27,18 +28,18 @@
 
 (defun display-results (results)
   (format t "~%")
-  (loop :for (var . result) :in results :do
+  (loop :for (var result . more) :on results :by #'cddr :do
         (format t "~S = ~S~%" var result)))
 
-(defun result-one (results)
+(defun display-results-one (results)
   (display-results results)
   t)
 
-(defun result-all (results)
+(defun display-results-all (results)
   (display-results results)
   nil)
 
-(defun result-interactive (results)
+(defun display-results-interactive (results)
   (display-results results)
   (format t "~%More? [Yn] ")
   (force-output)
@@ -51,10 +52,36 @@
 
 (defun perform-query (query mode)
   (run-query *database* query
+             :result-function
              (ecase mode
-               (:interactive #'result-interactive)
-               (:all #'result-all)
-               (:one #'result-one))))
+               (:interactive #'display-results-interactive)
+               (:all #'display-results-all)
+               (:one #'display-results-one))
+             :status-function
+             (lambda (fail-p)
+               (if fail-p
+                 (princ "No.")
+                 (princ "Yes."))))
+  (values))
+
+
+(defun return-results-one (results)
+  (setf *results* results)
+  t)
+
+(defun return-results-all (results)
+  (push results *results*)
+  nil)
+
+
+(defun perform-return (query mode)
+  (let ((*results* nil))
+    (run-query *database* query
+               :result-function
+               (ecase mode
+                 (:all #'return-results-all)
+                 (:one #'return-results-one)))
+    *results*))
 
 
 (defmacro query (&body body)
@@ -66,6 +93,12 @@
 (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))
+
 
 (defun dump (&optional full-code)
   (dump-wam-full *database*)
diff -r 53d629a6aa69 -r 678ab674bd33 src/wam/vm.lisp
--- a/src/wam/vm.lisp	Fri Apr 22 13:27:41 2016 +0000
+++ b/src/wam/vm.lisp	Fri Apr 22 13:50:42 2016 +0000
@@ -525,7 +525,7 @@
                           :for i :from 0
                           :collect (wam-stack-frame-arg wam i)))
          (results (extract-things wam addresses)))
-    (pairlis vars results)))
+    (weave vars results)))
 
 
 (defun run (wam done-thunk)
@@ -591,7 +591,10 @@
             (error "Fell off the end of the program code store!")))))
     (values)))
 
-(defun run-query (wam term result-function)
+(defun run-query (wam term
+                  &key
+                  (result-function (lambda (results) (declare (ignore results))))
+                  (status-function (lambda (fail-p) (declare (ignore fail-p)))))
   "Compile query `term` and run the instructions on the `wam`.
 
   Resets the heap, etc before running.
@@ -612,9 +615,8 @@
     (run wam (lambda ()
                (funcall result-function
                         (extract-query-results wam vars))))
-    (if (wam-fail wam)
-      (princ "No.")
-      (princ "Yes.")))
+    (when status-function
+      (funcall status-function (wam-fail wam))))
   (values))