# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1461505953 0
# Node ID f3ed7ce70f3b0106431474cc99d6ab5e3d7c8d0e
# Parent  678ab674bd3341521f21e5bea84b193af1e3fd05
Improve the UI a bit

diff -r 678ab674bd33 -r f3ed7ce70f3b .lispwords
--- a/.lispwords	Fri Apr 22 13:50:42 2016 +0000
+++ b/.lispwords	Sun Apr 24 13:52:33 2016 +0000
@@ -1,3 +1,4 @@
 (2 code-push-instruction!)
 (1 repeat)
 (2 define-instruction define-instructions)
+(1 with-database with-fresh-database)
diff -r 678ab674bd33 -r f3ed7ce70f3b bones-test.asd
--- a/bones-test.asd	Fri Apr 22 13:50:42 2016 +0000
+++ b/bones-test.asd	Sun Apr 24 13:52:33 2016 +0000
@@ -7,6 +7,7 @@
   :serial t
   :components ((:file "package-test")
                (:module "test"
+                :serial t
                 :components ((:file "bones")
                              (:file "paip")))))
 
diff -r 678ab674bd33 -r f3ed7ce70f3b package-test.lisp
--- a/package-test.lisp	Fri Apr 22 13:50:42 2016 +0000
+++ b/package-test.lisp	Sun Apr 24 13:52:33 2016 +0000
@@ -1,12 +1,14 @@
 (defpackage #:bones-test
-  (:use #:cl
-        #:5am
-        #:bones))
+  (:use
+    #:cl
+    #:5am
+    #:bones))
 
 (defpackage #:bones-test.paip
-  (:use #:cl
-        #:5am
-        #:bones.quickutils
-        #:bones.paip)
+  (:use
+    #:cl
+    #:5am
+    #:bones.quickutils
+    #:bones.paip)
   ; kill me
   (:shadowing-import-from #:5am #:fail))
diff -r 678ab674bd33 -r f3ed7ce70f3b package.lisp
--- a/package.lisp	Fri Apr 22 13:50:42 2016 +0000
+++ b/package.lisp	Sun Apr 24 13:52:33 2016 +0000
@@ -3,54 +3,62 @@
   (:export #:hello))
 
 (defpackage #:bones.utils
-  (:use #:cl
-        #:defstar
-        #:bones.quickutils)
+  (:use
+    #:cl
+    #:defstar
+    #:bones.quickutils)
   (:export
     #:repeat
     #:topological-sort
     #:push-if-new))
 
 (defpackage #:bones.wam
-  (:use #:cl
-        #:defstar
-        #:optima
-        #:cl-arrows
-        #:bones.quickutils
-        #:bones.utils)
-  (:import-from #:optima #:match)
-  (:shadowing-import-from #:cl-arrows #:->))
+  (:use
+    #:cl
+    #:defstar
+    #:optima
+    #:cl-arrows
+    #:bones.quickutils
+    #:bones.utils)
+  (:import-from #:optima
+    #:match)
+  (:shadowing-import-from #:cl-arrows
+    #:->))
 
 (defpackage #:bones.paip
-  (:use #:cl #:defstar #:bones.quickutils)
+  (:use
+    #:cl
+    #:defstar
+    #:bones.quickutils)
   (:documentation "Test?")
   (:export
 
-   ;; Unification, constants
-   #:unify
-   #:fail #:no-bindings
-   #:*check-occurs*
+    ;; Unification, constants
+    #:unify
+    #:fail
+    #:no-bindings
+    #:*check-occurs*
 
-   ;; Destructive unification
-   #:unify!
-   #:unbound
-   #:bound-p
+    ;; Destructive unification
+    #:unify!
+    #:unbound
+    #:bound-p
 
-   ;; Database management
-   #:clear-db
-   #:clear-predicate
-   #:fact
-   #:rule
-   #:add-fact
-   #:rule-fact
+    ;; Database management
+    #:clear-db
+    #:clear-predicate
+    #:fact
+    #:rule
+    #:add-fact
+    #:rule-fact
 
-   ;; Lisp data structures as results
-   #:return-one
-   #:return-all
+    ;; Lisp data structures as results
+    #:return-one
+    #:return-all
 
-   ;; Interactive queries
-   #:query
-   #:query-one
-   #:query-all
-   ))
+    ;; Interactive queries
+    #:query
+    #:query-one
+    #:query-all
+    ))
 
diff -r 678ab674bd33 -r f3ed7ce70f3b src/make-quickutils.lisp
--- a/src/make-quickutils.lisp	Fri Apr 22 13:50:42 2016 +0000
+++ b/src/make-quickutils.lisp	Sun Apr 24 13:52:33 2016 +0000
@@ -17,5 +17,6 @@
                :map-tree
                :weave
                :range
+               :alist-plist
                )
   :package "BONES.QUICKUTILS")
diff -r 678ab674bd33 -r f3ed7ce70f3b src/quickutils.lisp
--- a/src/quickutils.lisp	Fri Apr 22 13:50:42 2016 +0000
+++ b/src/quickutils.lisp	Sun Apr 24 13:52:33 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 :WEAVE :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 :ALIST-PLIST) :ensure-package T :package "BONES.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "BONES.QUICKUTILS")
@@ -20,7 +20,8 @@
                                          :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
                                          :TREE-MEMBER-P :TREE-COLLECT
                                          :TRANSPOSE :ZIP :ALIST-TO-HASH-TABLE
-                                         :MAP-TREE :WEAVE :RANGE))))
+                                         :MAP-TREE :WEAVE :RANGE :SAFE-ENDP
+                                         :ALIST-PLIST))))
 
   (defun %reevaluate-constant (name value test)
     (if (not (boundp name))
@@ -302,9 +303,34 @@
     (assert (<= start end))
     (loop :for i :from start :below end :by step :collecting (funcall key i)))
   
+
+  (declaim (inline safe-endp))
+  (defun safe-endp (x)
+    (declare (optimize safety))
+    (endp x))
+  
+
+  (defun alist-plist (alist)
+    "Returns a property list containing the same keys and values as the
+association list ALIST in the same order."
+    (let (plist)
+      (dolist (pair alist)
+        (push (car pair) plist)
+        (push (cdr pair) plist))
+      (nreverse plist)))
+
+  (defun plist-alist (plist)
+    "Returns an association list containing the same keys and values as the
+property list PLIST in the same order."
+    (let (alist)
+      (do ((tail plist (cddr tail)))
+          ((safe-endp tail) (nreverse alist))
+        (push (cons (car tail) (cadr tail)) alist))))
+  
 (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 weave range)))
+            with-unique-names zip alist-to-hash-table map-tree weave range
+            alist-plist plist-alist)))
 
 ;;;; END OF quickutils.lisp ;;;;
diff -r 678ab674bd33 -r f3ed7ce70f3b src/wam/ui.lisp
--- a/src/wam/ui.lisp	Fri Apr 22 13:50:42 2016 +0000
+++ b/src/wam/ui.lisp	Sun Apr 24 13:52:33 2016 +0000
@@ -4,10 +4,17 @@
 (defparameter *database* nil)
 (defvar *results* nil)
 
-(defmacro with-database (&body body)
-  `(let ((*database* (make-wam)))
+
+(defun make-database ()
+  (make-wam))
+
+(defmacro with-database (database &body body)
+  `(let ((*database* ,database))
      ,@body))
 
+(defmacro with-fresh-database (&body body)
+  `(with-database (make-database) ,body))
+
 
 (defun add-rules (rules)
   (compile-rules *database* rules))
@@ -58,8 +65,8 @@
                (:all #'display-results-all)
                (:one #'display-results-one))
              :status-function
-             (lambda (fail-p)
-               (if fail-p
+             (lambda (failp)
+               (if failp
                  (princ "No.")
                  (princ "Yes."))))
   (values))
@@ -75,13 +82,17 @@
 
 
 (defun perform-return (query mode)
-  (let ((*results* nil))
+  (let ((*results* nil)
+        (success nil))
     (run-query *database* query
+               :status-function
+               (lambda (failp)
+                 (setf success (not failp)))
                :result-function
                (ecase mode
                  (:all #'return-results-all)
                  (:one #'return-results-one)))
-    *results*))
+    (values *results* success)))
 
 
 (defmacro query (&body body)
diff -r 678ab674bd33 -r f3ed7ce70f3b src/wam/vm.lisp
--- a/src/wam/vm.lisp	Fri Apr 22 13:50:42 2016 +0000
+++ b/src/wam/vm.lisp	Sun Apr 24 13:52:33 2016 +0000
@@ -594,7 +594,7 @@
 (defun run-query (wam term
                   &key
                   (result-function (lambda (results) (declare (ignore results))))
-                  (status-function (lambda (fail-p) (declare (ignore fail-p)))))
+                  (status-function (lambda (failp) (declare (ignore failp)))))
   "Compile query `term` and run the instructions on the `wam`.
 
   Resets the heap, etc before running.