--- 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))
--- 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)
--- 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))
--- /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)))
+
+ )
+ )
--- 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)
--- 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))