# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1469287180 0
# Node ID f872f5b60d7386050953b343d943ad2923ddc980
# Parent  4abb7eda96cb634f0ac3d907d5354d32b2a12e08
ACTUALLY add some tests from TAOP

diff -r 4abb7eda96cb -r f872f5b60d73 package-test.lisp
--- a/package-test.lisp	Sat Jul 23 13:51:06 2016 +0000
+++ b/package-test.lisp	Sat Jul 23 15:19:40 2016 +0000
@@ -14,6 +14,7 @@
     #:results=
     #:should-fail
     #:should-return
+    #:define-test
     #:%=
     #:%not
     #:%append))
@@ -97,4 +98,5 @@
   (:use
     #:cl
     #:1am
+    #:bones-test.utils
     #:bones.circle))
diff -r 4abb7eda96cb -r f872f5b60d73 test/99.lisp
--- a/test/99.lisp	Sat Jul 23 13:51:06 2016 +0000
+++ b/test/99.lisp	Sat Jul 23 15:19:40 2016 +0000
@@ -6,7 +6,7 @@
 ;;; Solutions to at least a few of these, for testing purposes.
 
 
-(test p1
+(define-test p1
   ;; Find the last element of a list.
   (with-fresh-database
     (push-logic-frame-with
@@ -30,7 +30,7 @@
        (?what (foo))))))
 
 
-(test p2
+(define-test p2
   ;; Find the last but one element of a list.
   (with-fresh-database
     (push-logic-frame-with
@@ -65,7 +65,7 @@
     (rule (reverse ?l ?r)
       (reverse-acc ?l nil ?r))))
 
-(test p5
+(define-test p5
   ;; Reverse a list.
   (with-fresh-database
     (%reverse)
@@ -83,7 +83,7 @@
        (?x 1 ?y 4)))))
 
 
-(test p6
+(define-test p6
   ;; Find out whether a list is a palindrome.
   (with-fresh-database
     (%reverse)
@@ -101,7 +101,7 @@
        (?what (f foo))))))
 
 
-(test p7
+(define-test p7
   ;; Flatten a nested list structure.
   (with-fresh-database
     (%not)
@@ -144,7 +144,7 @@
        (?what (a b c))))))
 
 
-(test p8
+(define-test p8
   ;; Eliminate consecutive duplicates of list elements.
   (with-fresh-database
     (%=)
@@ -178,7 +178,7 @@
                  (list ?))
        (?what (f cats dogs))))))
 
-; (test p9
+; (define-test p9
 ;   (with-fresh-database
 ;     (%=)
 ;     (%not)
diff -r 4abb7eda96cb -r f872f5b60d73 test/circle.lisp
--- a/test/circle.lisp	Sat Jul 23 13:51:06 2016 +0000
+++ b/test/circle.lisp	Sat Jul 23 15:19:40 2016 +0000
@@ -5,12 +5,12 @@
               (circle-to-list ,circle))))
 
 
-(test empty-circles
+(define-test empty-circles
   (is (circle-empty-p (make-empty-circle)))
   (is (circle-empty-p (make-circle-with nil)))
   (is (not (circle-empty-p (make-circle-with (list 1))))))
 
-(test making-circle-with
+(define-test making-circle-with
   (is-circle-contents
     (make-circle-with (list))
     nil)
@@ -25,7 +25,7 @@
     (list (list 'foo))))
 
 
-(test prepending
+(define-test prepending
   (let ((c (make-empty-circle)))
     (is-circle-contents c nil)
 
@@ -38,7 +38,7 @@
     (circle-prepend c nil)
     (is-circle-contents c '(2 3 1))))
 
-(test appending
+(define-test appending
   (let ((c (make-empty-circle)))
     (is-circle-contents c nil)
 
@@ -51,7 +51,7 @@
     (circle-append c nil)
     (is-circle-contents c '(1 2 3))))
 
-(test appending-and-prepending
+(define-test appending-and-prepending
   (let ((c (make-empty-circle)))
     (is-circle-contents c nil)
 
@@ -65,7 +65,7 @@
     (is-circle-contents c '(a b 1 p q))))
 
 
-(test moving-forward
+(define-test moving-forward
   (let ((c (make-circle-with (list 1 2 3 4))))
     (is (equal
           '(1 2 3 4)
@@ -73,7 +73,7 @@
                 :while node
                 :collect (circle-value node))))))
 
-(test moving-backward
+(define-test moving-backward
   (let ((c (make-circle-with (list 1 2 3 4))))
     (is (equal
           '(4 3 2 1)
@@ -82,7 +82,7 @@
                 :collect (circle-value node))))))
 
 
-(test rotating
+(define-test rotating
   (let ((c (make-circle-with (list 1 2 3 4))))
     (is-circle-contents (circle-rotate c 0)
                         '(1 2 3 4))
@@ -116,7 +116,7 @@
                         '(2 3 4 1))))
 
 
-(test retrieving-nth
+(define-test retrieving-nth
   (let* ((data (list 'a 'b 'c 'd))
          (c (make-circle-with data)))
     (loop :for i :from 0 :below 4
@@ -124,7 +124,7 @@
           :do (is (eql v (circle-value (circle-nth c i)))))))
 
 
-(test inserting-before
+(define-test inserting-before
   (let ((c (make-circle-with (list 1 2 3))))
     (circle-insert-before c 'a)
     (is-circle-contents c '(1 2 3 a))
@@ -141,7 +141,7 @@
     (circle-insert-before (circle-nth c -1) 'e)
     (is-circle-contents c '(b c d 1 2 3 e a))))
 
-(test inserting-after
+(define-test inserting-after
   (let ((c (make-circle-with (list 1 2 3))))
     (circle-insert-after c 'a)
     (is-circle-contents c '(a 1 2 3))
@@ -159,7 +159,7 @@
     (is-circle-contents c '(a b c d 1 2 3 x))))
 
 
-(test checking-sentinel
+(define-test checking-sentinel
   (let ((c (make-circle-with (list 1 2 3))))
     (is (circle-sentinel-p c))
     (is (not (circle-sentinel-p (circle-nth c 0))))
@@ -171,7 +171,7 @@
   (is (circle-sentinel-p (circle-nth (make-empty-circle) -1))))
 
 
-(test removing
+(define-test removing
   (let ((c (make-circle-with (list 1 2 3))))
     (signals simple-error (circle-remove c))
     (is-circle-contents c '(1 2 3))
@@ -185,7 +185,7 @@
     (circle-remove (circle-nth c 0))
     (is-circle-contents c '())))
 
-(test removing-backward
+(define-test removing-backward
   (let ((c (make-circle-with (list 1 2 3 4 5 6))))
     (is-circle-contents c '(1 2 3 4 5 6))
 
@@ -200,7 +200,7 @@
 
     (is-circle-contents c '(3 4 5))))
 
-(test removing-forward
+(define-test removing-forward
   (let ((c (make-circle-with (list 1 2 3 4 5 6))))
     (is-circle-contents c '(1 2 3 4 5 6))
 
@@ -211,7 +211,7 @@
     (is-circle-contents c '(1 3 4 5))))
 
 
-(test replacing
+(define-test replacing
   (let ((c (make-circle-with (list 1 2 3 4 5 6))))
     (is-circle-contents c '(1 2 3 4 5 6))
 
@@ -230,7 +230,7 @@
     (circle-replace (circle-nth c -1) 'c)
     (is-circle-contents c '(bar a b 4 5 c))))
 
-(test replacing-backward
+(define-test replacing-backward
   (let ((c (make-circle-with (list 1 2 3 4 5 6))))
     (is-circle-contents c '(1 2 3 4 5 6))
 
@@ -246,7 +246,7 @@
     (is (not (circle-backward-replace (circle-nth c 0) 'dogs)))
     (is-circle-contents c '(dogs bar a 4 5 6))))
 
-(test replacing-forward
+(define-test replacing-forward
   (let ((c (make-circle-with (list 1 2 3 4 5 6))))
     (is-circle-contents c '(1 2 3 4 5 6))
 
@@ -260,7 +260,7 @@
     (is-circle-contents c '(1 bar 3 4 5 cats))))
 
 
-(test splicing
+(define-test splicing
   (let ((c (make-circle-with (list 1 2 3 4 5 6))))
     (is-circle-contents c '(1 2 3 4 5 6))
 
@@ -276,7 +276,7 @@
     (circle-splice (circle-nth c 3) nil)
     (is-circle-contents c '(a c 2 4 5 dogs cats))))
 
-(test splicing-backward
+(define-test splicing-backward
   (let ((c (make-circle-with (list 1 2 3 4 5 6))))
     (is-circle-contents c '(1 2 3 4 5 6))
 
@@ -289,7 +289,7 @@
     (is (not (circle-backward-splice (circle-nth c 0) '(first second))))
     (is-circle-contents c '(first second 2 a b 4 5))))
 
-(test splicing-forward
+(define-test splicing-forward
   (let ((c (make-circle-with (list 1 2 3 4 5 6))))
     (is-circle-contents c '(1 2 3 4 5 6))
 
diff -r 4abb7eda96cb -r f872f5b60d73 test/taop.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/taop.lisp	Sat Jul 23 15:19:40 2016 +0000
@@ -0,0 +1,168 @@
+(in-package #:bones-test.taop)
+
+;; Examples and exercises from The Art of Prolog
+
+(define-test families
+  (with-fresh-database
+    (%=)
+    (%not)
+    (push-logic-frame-with
+      (facts (father abraham isaac)
+             (father haran lot)
+             (father haran milcah)
+             (father haran yiscah)
+             (father terach abraham)
+             (father terach nachor)
+             (father terach haran)
+             (mother sarah isaac)
+             (male isaac)
+             (male lot)
+             (male terach)
+             (male nachor)
+             (male haran)
+             (male abraham)
+             (female sarah)
+             (female milcah)
+             (female yiscah))
+
+      (rule (parent ?person ?kid) (father ?person ?kid))
+      (rule (parent ?person ?kid) (mother ?person ?kid))
+
+      (rule (father ?person) (father ?person ?))
+      (rule (mother ?person) (mother ?person ?))
+      (rule (parent ?person) (father ?person))
+      (rule (parent ?person) (mother ?person))
+
+      (rule (grandparent ?person ?grandkid)
+        (parent ?person ?kid)
+        (parent ?kid ?grandkid))
+
+      (rule (grandmother ?person ?grandkid)
+        (grandparent ?person ?grandkid)
+        (female ?person))
+
+      (rule (grandfather ?person ?grandkid)
+        (grandparent ?person ?grandkid)
+        (male ?person))
+
+      (rule (son ?parent ?kid)
+        (parent ?parent ?kid)
+        (male ?kid))
+
+      (rule (daughter ?parent ?kid)
+        (parent ?parent ?kid)
+        (female ?kid))
+
+      (rule (siblings ?x ?y)
+        (parent ?p ?x)
+        (parent ?p ?y)
+        (not (= ?x ?y)))
+
+      (rule (brother ?bro ?person)
+        (siblings ?bro ?person)
+        (male ?bro))
+
+      (rule (sister ?sis ?person)
+        (siblings ?sis ?person)
+        (female ?sis))
+
+      (rule (uncle ?unc ?kid)
+        (brother ?unc ?parent)
+        (parent ?parent ?kid))
+
+      (rule (aunt ?unc ?kid)
+        (sister ?unc ?parent)
+        (parent ?parent ?kid))
+
+      (rule (cousins ?x ?y)
+        (parent ?px ?x)
+        (parent ?py ?y)
+        (siblings ?px ?py)))
+
+    (should-return
+      ((father ?who)
+       (?who abraham)
+       (?who haran)
+       (?who terach))
+      ((grandfather ?who ?kid)
+       (?who terach ?kid isaac)
+       (?who terach ?kid lot)
+       (?who terach ?kid milcah)
+       (?who terach ?kid yiscah))
+      ((brother ?who abraham)
+       (?who nachor)
+       (?who haran))
+      ((cousins isaac ?who)
+       (?who lot)
+       (?who milcah)
+       (?who yiscah))
+      ((uncle ?who lot)
+       (?who abraham)
+       (?who nachor))
+      ((uncle ?who isaac)
+       (?who haran)
+       (?who nachor)))))
+
+(define-test circuits
+  (with-fresh-database
+    (%=)
+    (%not)
+
+    (push-logic-frame-with
+      ;; and gate
+      (facts (resistor power n1)
+             (resistor power n2)
+             (transistor n2 ground n1)
+             (transistor n3 n4 n2)
+             (transistor n5 ground n4))
+
+      (rule (inverter ?input ?output)
+        (transistor ?input ground ?output)
+        (resistor power ?output))
+
+      (rule (nand ?a ?b ?output)
+        (transistor ?a ?x ?output)
+        (transistor ?b ground ?x)
+        (resistor power ?output))
+
+      (rule (and ?a ?b ?output)
+        (nand ?a ?b ?x)
+        (inverter ?x ?output)))
+    (should-return
+      ((and ?a ?b ?out)
+       (?a n3 ?b n5 ?out n1)))
+
+    (pop-logic-frame)
+
+    (push-logic-frame-with
+      ;; nor gate
+      (facts (resistor power o)
+             (transistor i1 ground o)
+             (transistor i2 ground o)
+             (resistor power no)
+             (transistor o ground no))
+
+      (rule (inverter ?input ?output)
+        (transistor ?input ground ?output)
+        (resistor power ?output))
+
+      (rule (or ?a ?b ?output)
+        (transistor ?a ground ?output)
+        (transistor ?b ground ?output)
+        (not (= ?a ?b))
+        (resistor power ?output))
+
+      (rule (nor ?a ?b ?output)
+        (or ?a ?b ?x)
+        (inverter ?x ?output)))
+
+    (should-return
+      ((or ?a ?b ?out)
+       (?a i1 ?b i2 ?out o)
+       (?a i2 ?b i1 ?out o))
+      ((nor ?a ?b ?out)
+       (?a i1 ?b i2 ?out no)
+       (?a i2 ?b i1 ?out no)))
+
+    )
+  )
diff -r 4abb7eda96cb -r f872f5b60d73 test/utils.lisp
--- a/test/utils.lisp	Sat Jul 23 13:51:06 2016 +0000
+++ b/test/utils.lisp	Sat Jul 23 15:19:40 2016 +0000
@@ -2,6 +2,17 @@
 
 
 ;;;; Utils
+(defmacro define-test (name &body body)
+  "Define a 1am test that uses the correct package.
+
+  This makes the test output less of an unreadable mess.
+
+  "
+  `(test ,name
+    (let ((*package* ,*package*))
+      ,@body)))
+
+
 (defun result= (x y)
   (set-equal (plist-alist x)
              (plist-alist y)
diff -r 4abb7eda96cb -r f872f5b60d73 test/wam.lisp
--- a/test/wam.lisp	Sat Jul 23 13:51:06 2016 +0000
+++ b/test/wam.lisp	Sat Jul 23 15:19:40 2016 +0000
@@ -56,14 +56,14 @@
 
 
 ;;;; Tests
-(test facts-literal
+(define-test facts-literal
   (with-database *test-database*
     (should-return
       ((always) empty)
       ((fuzzy cats) empty)
       ((fuzzy snakes) fail))))
 
-(test facts-variables
+(define-test facts-variables
   (with-database *test-database*
     (should-return
       ((fuzzy ?what)
@@ -80,7 +80,7 @@
 
       ((listens ?who metal) fail))))
 
-(test facts-conjunctions
+(define-test facts-conjunctions
   (with-database *test-database*
     (is (results= '((?who alice))
                   (query-all (listens ?who blues)
@@ -94,7 +94,7 @@
                   (query-all (listens ?who blues)
                              (drinks ?who ?what))))))
 
-(test simple-unification
+(define-test simple-unification
   (with-fresh-database
     (push-logic-frame-with
       (rule (= ?x ?x)))
@@ -108,7 +108,7 @@
       ((= (f ?x cats) (f dogs ?y)) (?x dogs ?y cats))
       ((= (f ?x ?x) (f dogs ?y)) (?x dogs ?y dogs)))))
 
-(test dynamic-call
+(define-test dynamic-call
   (with-fresh-database
     (push-logic-frame-with
       (facts (g cats)
@@ -134,7 +134,7 @@
        (?x cats)
        (?x (f dogs))))))
 
-(test negation
+(define-test negation
   (with-fresh-database
     (push-logic-frame-with
       (fact (yes ?anything))
@@ -147,7 +147,7 @@
       ((not (yes x)) fail)
       ((not (no x)) empty))))
 
-(test backtracking
+(define-test backtracking
   (with-fresh-database
     (push-logic-frame-with
       (facts (b))
@@ -203,7 +203,7 @@
     (should-return
       ((f foo) fail))))
 
-(test basic-rules
+(define-test basic-rules
   (with-database *test-database*
     (should-fail
       (pets candace ?what))
@@ -231,7 +231,7 @@
       ((narcissist ?person)
        (?person kim)))))
 
-(test register-allocation
+(define-test register-allocation
   ;; test for tricky register allocation bullshit
   (with-fresh-database
     (push-logic-frame-with
@@ -247,7 +247,7 @@
     (should-return
       ((foo dogs) empty))))
 
-(test lists
+(define-test lists
   (with-fresh-database
     (push-logic-frame-with
       (rule (member ?x (list* ?x ?)))
@@ -278,7 +278,7 @@
            (eql (car (getf result '?anything)) 'a))
          (query (member a ?anything))))))
 
-(test cut
+(define-test cut
   (with-fresh-database
     (push-logic-frame-with
       (facts (a))
@@ -372,7 +372,7 @@
       (f ?what)
       (g ?what))))
 
-(test anonymous-variables
+(define-test anonymous-variables
   (with-fresh-database
     (push-logic-frame-with
       (fact (following (s ? ? ? a)))
@@ -380,7 +380,7 @@
       (rule (bar (baz ?x ?y ?z ?thing))
         (foo ?thing))
       (fact (wild ? ? ?))
-      
+
       (fact (does x move))
       (rule (next z)
         (does ? move)))
@@ -392,7 +392,7 @@
       ((next z) empty)
       )))
 
-(test normalization-ui
+(define-test normalization-ui
   (with-fresh-database
     (push-logic-frame-with
       (fact a)
@@ -412,7 +412,7 @@
       ((d) fail)
       (dogs empty))))
 
-(test nested-constants
+(define-test nested-constants
   (with-fresh-database
     (push-logic-frame-with
       (fact (foo (s a b c))))
@@ -420,12 +420,12 @@
       ((foo (s ?x ?y ?z))
        (?x a ?y b ?z c)))))
 
-(test dump
+(define-test dump
   (is (not (string= ""
                     (with-output-to-string (*standard-output*)
                       (dump-wam-full *test-database*))))))
 
-(test last-call-optimization
+(define-test last-call-optimization
   (let* ((big-ass-list (loop :repeat 1000 :collect 'a))
          (big-ass-result (reverse (cons 'x big-ass-list))))
     (with-fresh-database
@@ -440,7 +440,7 @@
                     (query-all (big-ass-list ?bal)
                                (append ?bal (list x) ?bar)))))))
 
-(test hanoi
+(define-test hanoi
   ;; From The Art of Prolog
   (with-fresh-database
     (push-logic-frame-with
@@ -465,7 +465,7 @@
                (move a b)
                (move c a) (move c b) (move a b)))))))
 
-(test numbers
+(define-test numbers
   (with-fresh-database
     (push-logic-frame-with
       (rule (= ?x ?x))