Improve the testing infrastructure, rename find-all
author |
Steve Losh <steve@stevelosh.com> |
date |
Fri, 18 Mar 2016 12:09:36 +0000 |
parents |
d280326feecc
|
children |
2daf5fb2fe92
|
branches/tags |
(none) |
files |
examples/zebra.lisp package.lisp src/paip.lisp test/paip.lisp test/run.lisp |
Changes
--- a/examples/zebra.lisp Mon Mar 14 23:01:26 2016 +0000
+++ b/examples/zebra.lisp Fri Mar 18 12:09:36 2016 +0000
@@ -50,5 +50,5 @@
(member (house ?water-drinker ? ? water ?) ?houses)
(member (house ?zebra-owner zebra ? ? ?) ?houses))
-(time
- (query-all (zebra ?houses ?water ?zebra)))
+(time (query-all (zebra ?houses ?water ?zebra)))
+; (declaim (optimize (speed 3) (safety 0)))
--- a/package.lisp Mon Mar 14 23:01:26 2016 +0000
+++ b/package.lisp Fri Mar 18 12:09:36 2016 +0000
@@ -4,10 +4,25 @@
(defpackage #:bones.paip
(:use #:cl #:defstar #:bones.utils)
- (:export #:unify
- #:fail #:no-bindings
- #:*check-occurs*
- #:clear-db
- #:fact #:rule
- #:find-all #:query))
+ (:export
+
+ ;; Unification, constants
+ #:unify
+ #:fail #:no-bindings
+ #:*check-occurs*
+ ;; Database management
+ #:clear-db
+ #:fact
+ #:rule
+
+ ;; Lisp data structures as results
+ #:return-one
+ #:return-all
+
+ ;; Interactive queries
+ #:query
+ #:query-one
+ #:query-all
+ ))
+
--- a/src/paip.lisp Mon Mar 14 23:01:26 2016 +0000
+++ b/src/paip.lisp Fri Mar 18 12:09:36 2016 +0000
@@ -221,6 +221,8 @@
(cond
((wildcard-variable-p form) (gensym "?"))
((atom form) form)
+ ((consp form) (cons (replace-wildcard-variables (car form))
+ (replace-wildcard-variables (cdr form))))
(t (mapcar #'replace-wildcard-variables form))))
@@ -312,10 +314,10 @@
(case (read-char)
(#\; t)
(#\. nil)
- (#\newline (continue-p))
+ (#\newline (continue-ask))
(otherwise
(format t " Type ; to see more or . to stop")
- (continue-p))))
+ (continue-ask))))
(defun show-prolog-vars (variables bindings other-goals continue-p)
@@ -369,17 +371,17 @@
(defparameter *results* nil)
-(defun find-one-result (variables bindings other-goals)
+(defun return-one-result (variables bindings other-goals)
(setf *results* (clean-variables variables bindings))
(prove-all other-goals bindings))
-(defun find-all-results (variables bindings other-goals)
+(defun return-all-results (variables bindings other-goals)
(declare (ignore other-goals))
(push (clean-variables variables bindings) *results*)
fail)
-(setf (get 'find-one-result clause-key) 'find-one-result)
-(setf (get 'find-all-results clause-key) 'find-all-results)
+(setf (get 'return-one-result clause-key) 'return-one-result)
+(setf (get 'return-all-results clause-key) 'return-all-results)
(defun top-level-find (goals primitive)
@@ -391,9 +393,9 @@
*results*))
-(defmacro find-one (&rest goals)
- `(top-level-find ',goals 'find-one-result))
+(defmacro return-one (&rest goals)
+ `(top-level-find ',goals 'return-one-result))
-(defmacro find-all (&rest goals)
- `(top-level-find ',goals 'find-all-results))
+(defmacro return-all (&rest goals)
+ `(top-level-find ',goals 'return-all-results))
--- a/test/paip.lisp Mon Mar 14 23:01:26 2016 +0000
+++ b/test/paip.lisp Fri Mar 18 12:09:36 2016 +0000
@@ -26,15 +26,16 @@
(defmacro proves (query)
- `(is-true (find-all ,query)))
+ `(is-true (return-all ,query)))
(defmacro not-proves (query)
- `(is-false (find-all ,query)))
+ `(is-false (return-all ,query)))
(defmacro proves-with (query results)
- `(is (set-equal ',results (find-all ,query)
+ `(is (set-equal ',results (return-all ,query)
:test #'alist-equal)))
+
;;;; Unification
(test constant-unification
(unifies 1 1 no-bindings)
--- a/test/run.lisp Mon Mar 14 23:01:26 2016 +0000
+++ b/test/run.lisp Fri Mar 18 12:09:36 2016 +0000
@@ -2,5 +2,15 @@
(ql:quickload "bones-test"))
-(5am:run! :bones)
-(5am:run! :bones.paip)
+(defvar *passed* t)
+
+(defun test (spec)
+ (let ((result (5am:run spec)))
+ (5am:explain! result)
+ (when (not (5am:results-status result))
+ (setf *passed* nil))))
+
+(test :bones)
+(test :bones.paip)
+
+(sb-ext:exit :code (if *passed* 0 1))