# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1465084871 0
# Node ID e244881864f7f73206569b7c173da8f09fcfe53b
# Parent  e8934091b7bba1ac1612e58d17874d3cc8f314e9
Implement cut

This was way easier than the book's version.

diff -r e8934091b7bb -r e244881864f7 examples/bench.lisp
--- 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))
diff -r e8934091b7bb -r e244881864f7 package-test.lisp
--- 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))
diff -r e8934091b7bb -r e244881864f7 src/wam/bytecode.lisp
--- 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")
diff -r e8934091b7bb -r e244881864f7 src/wam/cells.lisp
--- 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))
diff -r e8934091b7bb -r e244881864f7 src/wam/compiler.lisp
--- 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
diff -r e8934091b7bb -r e244881864f7 src/wam/constants.lisp
--- 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
diff -r e8934091b7bb -r e244881864f7 src/wam/dump.lisp
--- 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)
diff -r e8934091b7bb -r e244881864f7 src/wam/types.lisp
--- 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
diff -r e8934091b7bb -r e244881864f7 src/wam/vm.lisp
--- 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)))
diff -r e8934091b7bb -r e244881864f7 src/wam/wam.lisp
--- 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
diff -r e8934091b7bb -r e244881864f7 test/wam.lisp
--- 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))))