--- 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)
--- 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")))))
--- 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))
--- 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
+ ))
--- 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")
--- 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 ;;;;
--- 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)
--- 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.