# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1468716625 0
# Node ID aacf9ee4fddc98ee3bd5ce3d397541dd71e983ea
# Parent  62c76cc272e7fab9cf59178c786bdf451c2dcec0
Port some of the '99 Prolog Problems' to Bones as unit tests

Also fixes a bug that they uncovered.

diff -r 62c76cc272e7 -r aacf9ee4fddc bones-test.asd
--- 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")))))
 
diff -r 62c76cc272e7 -r aacf9ee4fddc package-test.lisp
--- 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))
diff -r 62c76cc272e7 -r aacf9ee4fddc src/wam/compiler/0-data.lisp
--- 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)
diff -r 62c76cc272e7 -r aacf9ee4fddc test/99.lisp
--- /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))))))
diff -r 62c76cc272e7 -r aacf9ee4fddc test/utils.lisp
--- /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))))))
+
diff -r 62c76cc272e7 -r aacf9ee4fddc test/wam.lisp
--- 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*