--- a/bones-test.asd Sat Jul 16 19:34:00 2016 +0000
+++ b/bones-test.asd Sun Jul 17 00:50:25 2016 +0000
@@ -9,7 +9,9 @@
(:module "test"
:serial t
:components ((:file "bones")
+ (:file "utils")
(:file "circle")
(:file "paip")
- (:file "wam")))))
+ (:file "wam")
+ (:file "99")))))
--- a/package-test.lisp Sat Jul 16 19:34:00 2016 +0000
+++ b/package-test.lisp Sun Jul 17 00:50:25 2016 +0000
@@ -1,8 +1,19 @@
(defpackage #:bones-test
+ (:use #:cl #:1am))
+
+(defpackage #:bones-test.utils
(:use
#:cl
#:1am
- ))
+ #:bones.wam
+ #:bones.quickutils)
+ (:export
+ #:fail
+ #:empty
+ #:result=
+ #:results=
+ #:should-fail
+ #:should-return))
(defpackage #:bones-test.paip
(:use
@@ -15,6 +26,7 @@
(:use
#:cl
#:1am
+ #:bones-test.utils
#:bones.quickutils
#:bones.wam)
(:import-from #:bones.wam
@@ -28,12 +40,36 @@
#:call
#:dump-wam-full
#:?
+ #:!
#:query
#:query-all)
(:import-from #:bones.utils
- #:symbolize)
- (:shadowing-import-from #:bones.wam
- #:!))
+ #:symbolize))
+
+(defpackage #:bones-test.99
+ (:use
+ #:cl
+ #:1am
+ #:bones-test.utils
+ #:bones.quickutils
+ #:bones.wam)
+ (:import-from #:bones.wam
+ #:with-fresh-database
+ #:push-logic-frame-with
+ #:rule
+ #:fact
+ #:facts
+ #:call
+ #:dump-wam-full
+ #:?
+ #:!
+ #:query
+ #:query-all)
+ (:import-from #:bones.utils
+ #:symbolize))
(defpackage #:bones-test.circle
- (:use :cl :1am :bones.circle))
+ (:use
+ #:cl
+ #:1am
+ #:bones.circle))
--- a/src/wam/compiler/0-data.lisp Sat Jul 16 19:34:00 2016 +0000
+++ b/src/wam/compiler/0-data.lisp Sun Jul 17 00:50:25 2016 +0000
@@ -178,8 +178,9 @@
(permanent-vars
(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)
+ ;; permanent (except ?, of course), so we can extract their
+ ;; bindings as results later.
+ (remove +wildcard-symbol+ (find-variables body))
(find-permanent-variables clause)))
(anonymous-vars
(if (null head)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/99.lisp Sun Jul 17 00:50:25 2016 +0000
@@ -0,0 +1,195 @@
+(in-package #:bones-test.99)
+
+;;;; 99 Prolog Problems
+;;; http://www.ic.unicamp.br/~meidanis/courses/mc336/2009s2/prolog/problemas/
+;;;
+;;; Solutions to at least a few of these, for testing purposes.
+
+
+(defun %= ()
+ (push-logic-frame-with
+ (fact (= ?x ?x))))
+
+(defun %not ()
+ (push-logic-frame-with
+ (rule (not ?x) (call ?x) ! fail)
+ (fact (not ?x))))
+
+(defun %append ()
+ (push-logic-frame-with
+ (fact (append nil ?l ?l))
+ (rule (append (list* ?x ?rest) ?l (list* ?x ?result))
+ (append ?rest ?l ?result))))
+
+
+(test p1
+ ;; Find the last element of a list.
+ (with-fresh-database
+ (push-logic-frame-with
+ (fact (last ?x (list ?x)))
+ (rule (last ?x (list* ? ?tail))
+ (last ?x ?tail)))
+
+ (should-return
+ ((last a (list a b c)) fail)
+ ((last b (list a b c)) fail)
+ ((last c (list a b c)) empty)
+
+ ((last ?what nil) fail)
+ ((last ?what (list a))
+ (?what a))
+
+ ((last ?what (list (h x) (f (g x))))
+ (?what (f (g x))))
+
+ ((last ?what (list (list foo)))
+ (?what (foo))))))
+
+
+(test p2
+ ;; Find the last but one element of a list.
+ (with-fresh-database
+ (push-logic-frame-with
+ (fact (last-but-one ?x (list ?x ?)))
+ (rule (last-but-one ?x (list* ? ?tail))
+ (last-but-one ?x ?tail)))
+
+ (should-return
+ ((last-but-one a (list a b c)) fail)
+ ((last-but-one b (list a b c)) empty)
+ ((last-but-one c (list a b c)) fail)
+
+ ((last-but-one ?what nil) fail)
+ ((last-but-one c (list a b c d)) empty)
+
+ ((last-but-one ?what (list (h x) (f (g x))))
+ (?what (h x)))
+
+ ((last-but-one ?what (list (list foo) (list bar)))
+ (?what (foo))))))
+
+
+;;; TODO: p3/p4 when we have maths
+
+
+(defun %reverse ()
+ (push-logic-frame-with
+ (fact (reverse-acc nil ?acc ?acc))
+ (rule (reverse-acc (list* ?x ?tail) ?acc ?reversed)
+ (reverse-acc ?tail (list* ?x ?acc) ?reversed))
+
+ (rule (reverse ?l ?r)
+ (reverse-acc ?l nil ?r))))
+
+(test p5
+ ;; Reverse a list.
+ (with-fresh-database
+ (%reverse)
+
+ (should-return
+ ((reverse nil nil) empty)
+ ((reverse (list 1) nil) fail)
+ ((reverse (list 1) (list 1)) empty)
+ ((reverse (list 1 2) (list 2 1)) empty)
+ ((reverse (list (f foo) (f bar))
+ (list (f bar) (f foo)))
+ empty)
+ ((reverse (list ?x 2 3 4)
+ (list ?y 3 2 1))
+ (?x 1 ?y 4)))))
+
+
+(test p6
+ ;; Find out whether a list is a palindrome.
+ (with-fresh-database
+ (%reverse)
+ (push-logic-frame-with
+ (rule (palindrome ?l)
+ (reverse ?l ?l)))
+
+ (should-return
+ ((palindrome nil) empty)
+ ((palindrome (list 1)) empty)
+ ((palindrome (list 1 1)) empty)
+ ((palindrome (list 1 2)) fail)
+ ((palindrome (list 1 2 1)) empty)
+ ((palindrome (list (f foo) ?what))
+ (?what (f foo))))))
+
+
+(test p7
+ ;; Flatten a nested list structure.
+ (with-fresh-database
+ (%not)
+ (%append)
+
+ (push-logic-frame-with
+ (fact (is-list nil))
+ (fact (is-list (list* ? ?)))
+
+ (fact (flatten nil nil))
+
+ (rule (flatten (list* ?atom ?tail)
+ (list* ?atom ?flat-tail))
+ (not (is-list ?atom))
+ (flatten ?tail ?flat-tail))
+
+ (rule (flatten (list* ?head ?tail) ?flattened)
+ (is-list ?head)
+ (flatten ?head ?flat-head)
+ (flatten ?tail ?flat-tail)
+ (append ?flat-head ?flat-tail ?flattened)))
+
+ (should-return
+ ((is-list nil) empty)
+ ((is-list (list a)) empty)
+ ((is-list (list a b)) empty)
+ ((is-list (f x)) fail)
+ ((is-list a) fail)
+
+ ((flatten nil ?what)
+ (?what nil))
+
+ ((flatten (list a) ?what)
+ (?what (a)))
+
+ ((flatten (list (list a)) ?what)
+ (?what (a)))
+
+ ((flatten (list (list a b) (list (list c))) ?what)
+ (?what (a b c))))))
+
+
+(test p8
+ ;; Eliminate consecutive duplicates of list elements.
+ (with-fresh-database
+ (%=)
+ (%not)
+
+ (push-logic-frame-with
+ (fact (compress nil nil))
+ (fact (compress (list ?x) (list ?x)))
+
+ (rule (compress (list* ?x ?x ?rest) ?result)
+ (compress (list* ?x ?rest) ?result))
+
+ (rule (compress (list* ?x ?y ?rest) (list* ?x ?result))
+ (not (= ?x ?y))
+ (compress (list* ?y ?rest) ?result)))
+
+ (should-return
+ ((compress nil ?what)
+ (?what nil))
+
+ ((compress (list a) ?what)
+ (?what (a)))
+
+ ((compress (list a b c) ?what)
+ (?what (a b c)))
+
+ ((compress (list a b b a) ?what)
+ (?what (a b a)))
+
+ ((compress (list (f cats ?) ?what (f ? dogs))
+ (list ?))
+ (?what (f cats dogs))))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/utils.lisp Sun Jul 17 00:50:25 2016 +0000
@@ -0,0 +1,30 @@
+(in-package #:bones-test.utils)
+
+
+;;;; Utils
+(defun result= (x y)
+ (set-equal (plist-alist x)
+ (plist-alist y)
+ :test #'equal))
+
+(defun results= (r1 r2)
+ (set-equal r1 r2 :test #'result=))
+
+
+(defmacro should-fail (&body queries)
+ `(progn
+ ,@(loop :for query :in queries :collect
+ `(is (results= nil (query-all ,query))))))
+
+(defmacro should-return (&body queries)
+ `(progn
+ ,@(loop :for (query . results) :in queries
+ :collect
+ `(is (results= ',(cond
+ ((equal results '(empty))
+ (list nil))
+ ((equal results '(fail))
+ nil)
+ (t results))
+ (query-all ,query))))))
+
--- a/test/wam.lisp Sat Jul 16 19:34:00 2016 +0000
+++ b/test/wam.lisp Sun Jul 17 00:50:25 2016 +0000
@@ -55,34 +55,6 @@
(defparameter *test-database* (make-test-database))
-;;;; Utils
-(defun result= (x y)
- (set-equal (plist-alist x)
- (plist-alist y)
- :test #'equal))
-
-(defun results= (r1 r2)
- (set-equal r1 r2 :test #'result=))
-
-
-(defmacro should-fail (&body queries)
- `(progn
- ,@(loop :for query :in queries :collect
- `(is (results= nil (query-all ,query))))))
-
-(defmacro should-return (&body queries)
- `(progn
- ,@(loop :for (query . results) :in queries
- :collect
- `(is (results= ',(cond
- ((equal results '(empty))
- (list nil))
- ((equal results '(fail))
- nil)
- (t results))
- (query-all ,query))))))
-
-
;;;; Tests
(test facts-literal
(with-database *test-database*