--- a/examples/bench.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/examples/bench.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -38,4 +38,4 @@
(run-test%)))
(run-test (speed 3) (safety 1) (debug 1))
-(run-test (speed 3) (safety 0) (debug 0))
+; (run-test (speed 3) (safety 0) (debug 0))
--- a/package-test.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/package-test.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -23,10 +23,13 @@
(:import-from #:bones.wam
#:with-database
#:make-database
+ #:with-fresh-database
#:rules
#:facts
#:return-one
- #:return-all))
+ #:return-all)
+ (:shadowing-import-from #:bones.wam
+ #:!))
(defpackage #:bones-test.circle
(:use :cl :5am :bones.circle))
--- a/src/wam/bytecode.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/src/wam/bytecode.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -40,6 +40,7 @@
(+opcode-try+ 2)
(+opcode-retry+ 2)
(+opcode-trust+ 1)
+ (+opcode-cut+ 1)
(+opcode-get-constant+ 3)
(+opcode-set-constant+ 2)
@@ -82,6 +83,7 @@
(+opcode-try+ "TRY")
(+opcode-retry+ "RETRY")
(+opcode-trust+ "TRUST")
+ (+opcode-cut+ "CUT")
(+opcode-get-constant+ "GET-CONSTANT")
(+opcode-set-constant+ "SET-CONSTANT")
@@ -124,6 +126,7 @@
(+opcode-try+ "TRYM")
(+opcode-retry+ "RTRY")
(+opcode-trust+ "TRST")
+ (+opcode-cut+ "CUTT")
(+opcode-get-constant+ "GCON")
(+opcode-set-constant+ "SCON")
--- a/src/wam/cells.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/src/wam/cells.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -44,7 +44,8 @@
(+tag-structure+ "STRUCTURE")
(+tag-reference+ "REFERENCE")
(+tag-functor+ "FUNCTOR")
- (+tag-constant+ "CONSTANT")))
+ (+tag-constant+ "CONSTANT")
+ (+tag-list+ "LIST")))
(defun* cell-type-short-name ((cell cell))
(:returns string)
@@ -53,7 +54,8 @@
(+tag-structure+ "STR")
(+tag-reference+ "REF")
(+tag-functor+ "FUN")
- (+tag-constant+ "CON")))
+ (+tag-constant+ "CON")
+ (+tag-list+ "LST")))
(defun* cell-aesthetic ((cell cell))
--- a/src/wam/compiler.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/src/wam/compiler.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -558,6 +558,18 @@
;;;
;;; The opcodes are keywords and the register arguments remain register objects.
;;; They get converted down to the raw bytes in the final "rendering" step.
+;;;
+;;; A quick note on cut (!): the book and original WAM do some nutty things to
+;;; save one stack word per frame. They store the cut register for non-neck
+;;; cuts in a "pseudovariable" on the stack, so they only have to allocate that
+;;; extra stack word for things that actually *use* non-neck cuts
+;;;
+;;; We're going to just eat the extra stack word and store the cut register in
+;;; every frame instead. This massively simplifies the implementation and lets
+;;; me keep my sanity, and it *might* even end up being faster because there's
+;;; one fewer opcode, less fucking around in the compiler, etc. But regardless:
+;;; I don't want to go insane, and my laptop has sixteen gigabytes of RAM, so
+;;; let's just store the damn word.
(defun find-opcode (opcode newp mode &optional register)
(flet ((find-variant (register)
@@ -623,6 +635,8 @@
(push register seen)
(push-instruction (find-opcode :list nil mode register)
register))
+ (handle-cut ()
+ (push-instruction :cut))
(handle-call (functor arity)
;; CALL functor
(push-instruction :call
@@ -646,6 +660,8 @@
(handle-structure destination-register functor arity))
(`(:list ,register)
(handle-list register))
+ (`(:cut)
+ (handle-cut))
(`(:call ,functor ,arity)
(handle-call functor arity))
((guard register
@@ -705,18 +721,20 @@
Returns a circle of instructions and the permanent variables.
"
- (let* ((permanent-variables
+ (let* ((basic-clause
+ (remove '! (cons head body)))
+ (permanent-variables
(if (null head)
;; For query clauses we cheat a bit and make ALL variables
;; permanent, so we can extract their bindings as results later.
(find-variables body)
- (find-permanent-variables (cons head body))))
+ (find-permanent-variables basic-clause)))
(head-variables
- (set-difference (find-head-variables (cons head body))
+ (set-difference (find-head-variables basic-clause)
permanent-variables))
(head-arity
(max (1- (length head))
- (1- (length (car body)))))
+ (1- (length (second basic-clause)))))
(head-tokens
(when head
(tokenize-program-term head
@@ -725,14 +743,21 @@
head-arity)))
(body-tokens
(when body
- (append
- (tokenize-query-term (first body)
- permanent-variables
- head-variables
- head-arity)
- (loop :for term :in (rest body) :append
- (tokenize-query-term term
- permanent-variables))))))
+ (loop
+ :with first = t
+ :for goal :in body :append
+ (cond
+ ;; cut just gets emitted straight, but DOESN'T flip `first`...
+ ((eql goal '!) ; gross
+ (list (list :cut)))
+ (first
+ (setf first nil)
+ (tokenize-query-term goal
+ permanent-variables
+ head-variables
+ head-arity))
+ (t
+ (tokenize-query-term goal permanent-variables)))))))
(let ((instructions (precompile-tokens wam head-tokens body-tokens))
(variable-count (length permanent-variables)))
;; We need to compile facts and rules differently. Facts end with
@@ -931,7 +956,8 @@
(:done +opcode-done+)
(:try +opcode-try+)
(:retry +opcode-retry+)
- (:trust +opcode-trust+)))
+ (:trust +opcode-trust+)
+ (:cut +opcode-cut+)))
(defun render-argument (argument)
(etypecase argument
--- a/src/wam/constants.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/src/wam/constants.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -136,17 +136,18 @@
(define-constant +opcode-try+ 24)
(define-constant +opcode-retry+ 25)
(define-constant +opcode-trust+ 26)
+(define-constant +opcode-cut+ 27)
;;; Constants
-(define-constant +opcode-get-constant+ 27)
-(define-constant +opcode-set-constant+ 28)
-(define-constant +opcode-put-constant+ 29)
-(define-constant +opcode-unify-constant+ 30)
+(define-constant +opcode-get-constant+ 28)
+(define-constant +opcode-set-constant+ 29)
+(define-constant +opcode-put-constant+ 30)
+(define-constant +opcode-unify-constant+ 31)
;;; Lists
-(define-constant +opcode-get-list+ 31)
-(define-constant +opcode-put-list+ 32)
+(define-constant +opcode-get-list+ 32)
+(define-constant +opcode-put-list+ 33)
;;;; Debug Config
--- a/src/wam/dump.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/src/wam/dump.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -91,7 +91,8 @@
((= addr +stack-start+) "")
((= offset 0) "CE ===========================")
((= offset 1) "CP")
- ((= offset 2)
+ ((= offset 2) "CUT")
+ ((= offset 3)
(if (zerop cell)
(progn
(setf currently-in nil)
@@ -344,6 +345,7 @@
(defun dump-wam (wam from to highlight)
(format t " FAIL: ~A~%" (wam-fail wam))
+ (format t " BACKTRACKED?: ~A~%" (wam-backtracked wam))
(format t " MODE: ~S~%" (wam-mode wam))
(dump-wam-functors wam)
(format t " HEAP SIZE: ~A~%" (- (wam-heap-pointer wam) +heap-start+))
@@ -351,6 +353,7 @@
(format t "CONTINUATION PTR: ~4,'0X~%" (wam-continuation-pointer wam))
(format t " ENVIRONMENT PTR: ~4,'0X~%" (wam-environment-pointer wam))
(format t " BACKTRACK PTR: ~4,'0X~%" (wam-backtrack-pointer wam))
+ (format t " CUT PTR: ~4,'0X~%" (wam-cut-pointer wam))
(format t "HEAP BCKTRCK PTR: ~4,'0X~%" (wam-heap-backtrack-pointer wam))
(dump-wam-trail wam)
(dump-wam-registers wam)
--- a/src/wam/types.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/src/wam/types.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -45,11 +45,11 @@
(deftype opcode ()
- '(integer 0 32))
+ '(integer 0 33))
(deftype stack-frame-size ()
- `(integer 3 ,+stack-frame-size-limit+))
+ `(integer 4 ,+stack-frame-size-limit+))
(deftype stack-choice-size ()
;; TODO: is this actually right? check on frame size limit vs choice point
--- a/src/wam/vm.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/src/wam/vm.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -127,6 +127,31 @@
(unbind! wam (wam-trail-value wam i)))
(values))
+(defun* tidy-trail! ((wam wam))
+ (with-accessors ((tr wam-trail-pointer)
+ (h wam-heap-pointer)
+ (hb wam-heap-backtrack-pointer)
+ (b wam-backtrack-pointer))
+ wam
+ (loop
+ ;; The book is, yet again, fucked. It just sets `i` to be the trail
+ ;; pointer from the choice point frame. But what if we just popped off
+ ;; the last choice point? If that's the case We need to look over the
+ ;; entire trail.
+ :with i = (if (wam-backtrack-pointer-unset-p wam b)
+ 0
+ (wam-stack-choice-tr wam))
+ :for target = (wam-trail-value wam i)
+ :while (< i tr) :do
+ (if (or (< target hb)
+ (and (< h target)
+ (< target b)))
+ (incf i)
+ (progn
+ (setf (wam-trail-value wam i)
+ (wam-trail-value wam (1- tr)))
+ (decf tr))))))
+
(defun* deref ((wam wam) (address store-index))
(:returns store-index)
"Dereference the address in the WAM store to its eventual destination.
@@ -440,6 +465,9 @@
(wam-number-of-arguments wam) ; set NARGS
(wam-functor-arity wam functor)
+ (wam-cut-pointer wam) ; set B0 in case we have a cut
+ (wam-backtrack-pointer wam)
+
(wam-program-counter wam) ; jump
target)
;; Trying to call an unknown procedure.
@@ -452,20 +480,39 @@
(define-instruction %allocate ((wam wam) (n stack-frame-argcount))
(let ((old-e (wam-environment-pointer wam))
(new-e (wam-stack-top wam)))
- (wam-stack-ensure-size wam (+ new-e 3 n))
+ (wam-stack-ensure-size wam (+ new-e 4 n))
(setf (wam-stack-word wam new-e) old-e ; CE
(wam-stack-word wam (+ new-e 1)) (wam-continuation-pointer wam) ; CP
- (wam-stack-word wam (+ new-e 2)) n ; N
+ (wam-stack-word wam (+ new-e 2)) (wam-cut-pointer wam) ; B0
+ (wam-stack-word wam (+ new-e 3)) n ; N
(wam-environment-pointer wam) new-e))) ; E <- new-e
(define-instruction %deallocate ((wam wam))
- (setf (wam-program-counter wam)
- (wam-stack-frame-cp wam)
- (wam-environment-pointer wam)
- (wam-stack-frame-ce wam)))
+ (setf (wam-program-counter wam) (wam-stack-frame-cp wam)
+ (wam-environment-pointer wam) (wam-stack-frame-ce wam)
+ (wam-cut-pointer wam) (wam-stack-frame-cut wam)))
;;;; Choice Instructions
+(defun* reset-choice-point! ((wam wam)
+ (b backtrack-pointer))
+ (setf (wam-backtrack-pointer wam) b
+
+ ;; The book is wrong here: when resetting HB we use the NEW value of B,
+ ;; so the heap backtrack pointer gets set to the heap pointer saved in
+ ;; the PREVIOUS choice point. Thanks to the errata at
+ ;; https://github.com/a-yiorgos/wambook/blob/master/wamerratum.txt for
+ ;; pointing this out.
+ ;;
+ ;; ... well, almost. The errata is also wrong here. If we're popping
+ ;; the FIRST choice point, then just using the HB from the "previous
+ ;; choice point" is going to give us garbage, so we should check for
+ ;; that edge case too. Please kill me.
+ (wam-heap-backtrack-pointer wam)
+ (if (wam-backtrack-pointer-unset-p wam b)
+ +heap-start+
+ (wam-stack-choice-h wam b))))
+
(define-instruction %try ((wam wam) (next-clause code-index))
(let ((new-b (wam-stack-top wam))
(nargs (wam-number-of-arguments wam)))
@@ -509,23 +556,15 @@
(setf (wam-environment-pointer wam) (wam-stack-choice-ce wam b)
(wam-continuation-pointer wam) (wam-stack-choice-cp wam b)
(wam-trail-pointer wam) (wam-stack-choice-tr wam b)
- (wam-heap-pointer wam) (wam-stack-choice-h wam b)
- (wam-backtrack-pointer wam) old-b
+ (wam-heap-pointer wam) (wam-stack-choice-h wam b))
+ (reset-choice-point! wam old-b)))
- ;; The book is wrong here: this last one uses the NEW value of b, so
- ;; the heap backtrack pointer gets set to the heap pointer saved in
- ;; the PREVIOUS choice point. Thanks to the errata at
- ;; https://github.com/a-yiorgos/wambook/blob/master/wamerratum.txt for
- ;; pointing this out.
- ;;
- ;; ... well, almost. The errata is also wrong here. If we're popping
- ;; the FIRST choice point, then just using the HB from the "previous
- ;; choice point" is going to give us garbage, so we should check for
- ;; that edge case too. Please kill me.
- (wam-heap-backtrack-pointer wam)
- (if (wam-backtrack-pointer-unset-p wam old-b)
- +heap-start+
- (wam-stack-choice-h wam old-b)))))
+(define-instruction %cut ((wam wam))
+ (let ((current-choice-point (wam-backtrack-pointer wam))
+ (previous-choice-point (wam-stack-frame-cut wam)))
+ (when (< previous-choice-point current-choice-point)
+ (reset-choice-point! wam previous-choice-point)
+ (tidy-trail! wam))))
;;;; Constant Instructions
@@ -625,7 +664,7 @@
(defun extract-query-results (wam vars)
(let* ((addresses (loop :for var :in vars
;; TODO: make this suck less
- :for i :from (+ (wam-environment-pointer wam) 3)
+ :for i :from (+ (wam-environment-pointer wam) 4)
:collect i))
(results (extract-things wam addresses)))
(weave vars results)))
@@ -637,6 +676,7 @@
(macrolet ((instruction (inst args)
`(instruction-call wam ,inst code pc ,args)))
(loop
+ :with increment-pc = t
:while (and (not (wam-fail wam)) ; failure
(not (= pc +code-sentinel+))) ; finished
:for opcode = (aref code pc)
@@ -678,27 +718,32 @@
(+opcode-try+ (instruction %try 1))
(+opcode-retry+ (instruction %retry 1))
(+opcode-trust+ (instruction %trust 0))
+ (+opcode-cut+ (instruction %cut 0))
;; Control
(+opcode-allocate+ (instruction %allocate 1))
;; need to skip the PC increment for PROC/CALL/DEAL/DONE
- ;; TODO: this is ugly
+ ;; TODO: this is still ugly
(+opcode-deallocate+
(instruction %deallocate 0)
- (return-from op))
+ (setf increment-pc nil))
(+opcode-proceed+
(instruction %proceed 0)
- (return-from op))
+ (setf increment-pc nil))
(+opcode-call+
(instruction %call 1)
- (return-from op))
+ (setf increment-pc nil))
(+opcode-done+
(if (funcall done-thunk)
(return-from run)
(backtrack! wam))))
- ;; Only increment the PC when we didn't backtrack
- (if (wam-backtracked wam)
- (setf (wam-backtracked wam) nil)
+ ;; Only increment the PC when we didn't backtrack.
+ ;;
+ ;; If we backtracked, the PC will have been filled in from the
+ ;; choice point.
+ (when (and increment-pc (not (wam-backtracked wam)))
(incf pc (instruction-size opcode)))
+ (setf (wam-backtracked wam) nil
+ increment-pc t)
(when (>= pc (fill-pointer code))
(error "Fell off the end of the program code store!"))))))
(values)))
--- a/src/wam/wam.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/src/wam/wam.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -17,6 +17,7 @@
wam-continuation-pointer
wam-environment-pointer
wam-backtrack-pointer
+ wam-cut-pointer
wam-heap-backtrack-pointer
wam-mode))
@@ -91,6 +92,7 @@
(continuation-pointer 0 :type code-index) ; CP
(environment-pointer +stack-start+ :type environment-pointer) ; E
(backtrack-pointer +stack-start+ :type backtrack-pointer) ; B
+ (cut-pointer +stack-start+ :type backtrack-pointer) ; B0
(heap-backtrack-pointer +heap-start+ :type heap-index) ; HB
;; Other global "registers"
@@ -204,6 +206,9 @@
"Return the element (a heap index) in the WAM trail at `address`."
(aref (wam-trail wam) address))
+(defun (setf wam-trail-value) (new-value wam address)
+ (setf (aref (wam-trail wam) address) new-value))
+
;;;; Stack
;;; The stack is stored as a fixed-length hunk of the main WAM store array,
@@ -276,6 +281,7 @@
;;; |PREV|
;;; | CE | <-- environment-pointer
;;; | CP |
+;;; | B0 |
;;; | N |
;;; | Y0 |
;;; | .. |
@@ -284,6 +290,7 @@
(declaim (inline wam-stack-frame-ce
wam-stack-frame-cp
+ wam-stack-frame-cut
wam-stack-frame-n
wam-stack-frame-arg
(setf wam-stack-frame-arg)
@@ -305,13 +312,21 @@
(:returns continuation-pointer)
(wam-stack-word wam (1+ e)))
+(defun* wam-stack-frame-cut
+ ((wam wam)
+ &optional
+ ((e environment-pointer)
+ (wam-environment-pointer wam)))
+ (:returns backtrack-pointer)
+ (wam-stack-word wam (+ 2 e)))
+
(defun* wam-stack-frame-n
((wam wam)
&optional
((e environment-pointer)
(wam-environment-pointer wam)))
(:returns stack-frame-argcount)
- (wam-stack-word wam (+ 2 e)))
+ (wam-stack-word wam (+ 3 e)))
(defun* wam-stack-frame-arg
@@ -321,14 +336,14 @@
((e environment-pointer)
(wam-environment-pointer wam)))
(:returns cell)
- (wam-stack-word wam (+ 3 n e)))
+ (wam-stack-word wam (+ 4 n e)))
(defun* (setf wam-stack-frame-arg)
((new-value cell)
(wam wam)
(n register-index)
&optional ((e environment-pointer) (wam-environment-pointer wam)))
- (setf (wam-stack-word wam (+ e 3 n))
+ (setf (wam-stack-word wam (+ e 4 n))
new-value))
@@ -339,7 +354,7 @@
(wam-environment-pointer wam)))
(:returns stack-frame-size)
"Return the size of the stack frame starting at environment pointer `e`."
- (+ (wam-stack-frame-n wam e) 3))
+ (+ (wam-stack-frame-n wam e) 4))
;;; Choice point frames are laid out like so:
@@ -501,6 +516,7 @@
(wam-continuation-pointer wam) 0
(wam-environment-pointer wam) +stack-start+
(wam-backtrack-pointer wam) +stack-start+
+ (wam-cut-pointer wam) +stack-start+
(wam-heap-backtrack-pointer wam) +heap-start+
(wam-backtracked wam) nil
(wam-fail wam) nil
--- a/test/wam.lisp Thu Jun 02 13:42:58 2016 +0000
+++ b/test/wam.lisp Sun Jun 05 00:01:11 2016 +0000
@@ -70,8 +70,7 @@
(set-equal r1 r2 :test #'result=))
(defmacro q (&body query)
- `(with-database *test-database*
- (return-all ,@query)))
+ `(return-all ,@query))
(defmacro should-fail (&body queries)
@@ -87,77 +86,213 @@
;;;; Tests
(test facts-literal
- (is (results= '(nil) (q (always))))
- (is (results= '(nil) (q (fuzzy cats))))
- (is (results= nil (q (fuzzy snakes)))))
+ (with-database *test-database*
+ (is (results= '(nil) (q (always))))
+ (is (results= '(nil) (q (fuzzy cats))))
+ (is (results= nil (q (fuzzy snakes))))))
(test facts-variables
- (is (results= '((:what cats))
- (q (fuzzy :what))))
- (is (results= '((:what blues)
- (:what rock))
- (q (listens bob :what))))
- (is (results= '((:who alice)
- (:who bob)
- (:who candace))
- (q (listens :who blues))))
- (is (results= '()
- (q (listens :who metal)))))
+ (with-database *test-database*
+ (is (results= '((:what cats))
+ (q (fuzzy :what))))
+ (is (results= '((:what blues)
+ (:what rock))
+ (q (listens bob :what))))
+ (is (results= '((:who alice)
+ (:who bob)
+ (:who candace))
+ (q (listens :who blues))))
+ (is (results= '()
+ (q (listens :who metal))))))
(test facts-conjunctions
- (is (results= '((:who alice))
- (q (listens :who blues)
- (listens :who jazz))))
- (is (results= '((:who alice))
- (q (listens :who blues)
- (drinks :who bourbon))))
- (is (results= '((:what bourbon :who alice)
- (:what genny-cream :who bob)
- (:what birch-beer :who candace))
- (q (listens :who blues)
- (drinks :who :what)))))
+ (with-database *test-database*
+ (is (results= '((:who alice))
+ (q (listens :who blues)
+ (listens :who jazz))))
+ (is (results= '((:who alice))
+ (q (listens :who blues)
+ (drinks :who bourbon))))
+ (is (results= '((:what bourbon :who alice)
+ (:what genny-cream :who bob)
+ (:what birch-beer :who candace))
+ (q (listens :who blues)
+ (drinks :who :what))))))
+
+(test backtracking
+ (with-fresh-database
+ (facts (a))
+ (facts (b))
+ (facts (c))
+ (facts (d))
+ (rules ((f :x) (a))
+ ((f :x) (b) (c))
+ ((f :x) (d)))
+ (should-return
+ ((f foo)
+ (nil))))
+ (with-fresh-database
+ ; (facts (a))
+ (facts (b))
+ (facts (c))
+ (facts (d))
+ (rules ((f :x) (a))
+ ((f :x) (b) (c))
+ ((f :x) (d)))
+ (should-return
+ ((f foo)
+ (nil))))
+ (with-fresh-database
+ ; (facts (a))
+ (facts (b))
+ (facts (c))
+ ; (facts (d))
+ (rules ((f :x) (a))
+ ((f :x) (b) (c))
+ ((f :x) (d)))
+ (should-return
+ ((f foo)
+ (nil))))
+ (with-fresh-database
+ ; (facts (a))
+ ; (facts (b))
+ (facts (c))
+ ; (facts (d))
+ (rules ((f :x) (a))
+ ((f :x) (b) (c))
+ ((f :x) (d)))
+ (should-return
+ ((f foo)
+ nil)))
+ (with-fresh-database
+ ; (facts (a))
+ (facts (b))
+ ; (facts (c))
+ ; (facts (d))
+ (rules ((f :x) (a))
+ ((f :x) (b) (c))
+ ((f :x) (d)))
+ (should-return
+ ((f foo)
+ nil))))
(test basic-rules
- (should-fail
- (pets candace :what))
+ (with-database *test-database*
+ (should-fail
+ (pets candace :what))
- (should-return
- ((pets alice :what)
- ((:what snakes) (:what cats)))
+ (should-return
+ ((pets alice :what)
+ ((:what snakes) (:what cats)))
- ((pets bob :what)
- ((:what cats)))
+ ((pets bob :what)
+ ((:what cats)))
- ((pets :who snakes)
- ((:who alice)))
+ ((pets :who snakes)
+ ((:who alice)))
- ((likes kim :who)
- ((:who tom)
- (:who alice)
- (:who kim)
- (:who cats)))
+ ((likes kim :who)
+ ((:who tom)
+ (:who alice)
+ (:who kim)
+ (:who cats)))
- ((likes sally :who)
- ((:who tom)))
+ ((likes sally :who)
+ ((:who tom)))
- ((narcissist :person)
- ((:person kim)))))
+ ((narcissist :person)
+ ((:person kim))))))
(test lists
- (should-fail
- (member :anything nil)
- (member a nil)
- (member b '(a))
- (member '(a) '(a))
- (member a '('(a))))
- (should-return
- ((member :m '(a))
- ((:m a)))
- ((member :m '(a b))
- ((:m a) (:m b)))
- ((member :m '(a b a))
- ((:m a) (:m b)))
- ((member a '(a))
- (nil))
- ((member '(foo) '(a '(foo) b))
- (nil))))
+ (with-database *test-database*
+ (should-fail
+ (member :anything nil)
+ (member a nil)
+ (member b '(a))
+ (member '(a) '(a))
+ (member a '('(a))))
+ (should-return
+ ((member :m '(a))
+ ((:m a)))
+ ((member :m '(a b))
+ ((:m a) (:m b)))
+ ((member :m '(a b a))
+ ((:m a) (:m b)))
+ ((member a '(a))
+ (nil))
+ ((member '(foo) '(a '(foo) b))
+ (nil)))))
+
+
+(test cut
+ (with-fresh-database
+ (facts (a))
+ (facts (b))
+ (facts (c))
+ (facts (d))
+ (rules ((f a) (a))
+ ((f bc) (b) ! (c))
+ ((f d) (d)))
+ (rules ((g :what) (never))
+ ((g :what) (f :what)))
+ (should-return
+ ((f :what) ((:what a)
+ (:what bc)))
+ ((g :what) ((:what a)
+ (:what bc)))))
+
+ (with-fresh-database
+ ; (facts (a))
+ (facts (b))
+ (facts (c))
+ (facts (d))
+ (rules ((f a) (a))
+ ((f bc) (b) ! (c))
+ ((f d) (d)))
+ (rules ((g :what) (never))
+ ((g :what) (f :what)))
+ (should-return
+ ((f :what) ((:what bc)))
+ ((g :what) ((:what bc)))))
+
+ (with-fresh-database
+ ; (facts (a))
+ ; (facts (b))
+ (facts (c))
+ (facts (d))
+ (rules ((f a) (a))
+ ((f bc) (b) ! (c))
+ ((f d) (d)))
+ (rules ((g :what) (never))
+ ((g :what) (f :what)))
+ (should-return
+ ((f :what) ((:what d)))
+ ((g :what) ((:what d)))))
+
+ (with-fresh-database
+ ; (facts (a))
+ (facts (b))
+ ; (facts (c))
+ (facts (d))
+ (rules ((f a) (a))
+ ((f bc) (b) ! (c))
+ ((f d) (d)))
+ (rules ((g :what) (never))
+ ((g :what) (f :what)))
+ (should-fail
+ (f :what)
+ (g :what)))
+
+ (with-fresh-database
+ ; (facts (a))
+ ; (facts (b))
+ (facts (c))
+ ; (facts (d))
+ (rules ((f a) (a))
+ ((f bc) (b) ! (c))
+ ((f d) (d)))
+ (rules ((g :what) (never))
+ ((g :what) (f :what)))
+ (should-fail
+ (f :what)
+ (g :what))))