# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1462057029 0
# Node ID 4d33f11b074fce50c477224b72be067057e7a88e
# Parent  3c8bbc73e9e1b7155580ddb6ce2e5ee45619d815
Add a barebones GGP test case so we can start poking at performance

diff -r 3c8bbc73e9e1 -r 4d33f11b074f examples/ggp.lisp
--- a/examples/ggp.lisp	Thu Apr 28 18:02:52 2016 +0000
+++ b/examples/ggp.lisp	Sat Apr 30 22:57:09 2016 +0000
@@ -1,239 +1,281 @@
-(in-package #:bones.paip)
+(in-package #:bones.wam)
 
-;;;; Games
-(defun dont-press-the-button ()
-  (clear-db)
-  (fact role you)
+(declaim (optimize (speed 1) (safety 3) (debug 1)))
+; (declaim (optimize (speed 3) (safety 1) (debug 0)))
 
-  (fact init (button off))
-  (fact init (turn 0))
-
-  (fact always) ; work around broken gamestepper
+(defparameter *d* (make-database))
 
-  (rule (legal you press) (always))
-  (rule (legal you wait) (always))
-
-  (rule (next (button on))
-        (does you press))
+(with-database *d*
+  (rules ((member :thing (cons :thing :rest)))
+         ((member :thing (cons :other :rest))
+          (member :thing :rest)))
 
-  (rule (next (button off))
-        (does you wait))
+  (rule (true :state :thing)
+        (member :thing :state))
 
-  (rule (next (turn ?x))
-        (true (turn ?current))
-        (succ ?current ?x))
+  (rule (does :performed :role :move)
+        (member (does :role :move) :performed))
 
-  (rule (terminal)
-        (true (button on)))
-
-  (rule (terminal)
-        (true (turn 4)))
+  (fact (role robot))
 
-  (rule (goal you 100)
-        (true (button off)))
-
-  (rule (goal you 0)
-        (true (button on)))
+  (facts (init (off p))
+         (init (off q))
+         (init (off r))
+         (init (off s))
+         (init (step num1))))
 
-  (fact succ 0 1)
-  (fact succ 1 2)
-  (fact succ 2 3)
-  (fact succ 3 4))
-
-(defun tic-tac-toe ()
-  (clear-db)
-
-  (fact role xplayer)
-  (fact role oplayer)
-
-  (fact index 1)
-  (fact index 2)
-  (fact index 3)
-  (rule (base (cell ?x ?y b)) (index ?x) (index ?y))
-  (rule (base (cell ?x ?y x)) (index ?x) (index ?y))
-  (rule (base (cell ?x ?y o)) (index ?x) (index ?y))
-  (rule (base (control ?p)) (role ?p))
+(with-database *d*
+  (rules ((next :state :performed (on p))
+          (does :performed robot a)
+          (true :state (off p)))
+         ((next :state :performed (on q))
+          (does :performed robot a)
+          (true :state (on q)))
+         ((next :state :performed (on r))
+          (does :performed robot a)
+          (true :state (on r)))
+         ((next :state :performed (off p))
+          (does :performed robot a)
+          (true :state (on p)))
+         ((next :state :performed (off q))
+          (does :performed robot a)
+          (true :state (off q)))
+         ((next :state :performed (off r))
+          (does :performed robot a)
+          (true :state (off r)))
 
-  (rule (input ?p (mark ?x ?y)) (index ?x) (index ?y) (role ?p))
-  (rule (input ?p noop) (role ?p))
+         ((next :state :performed (on p))
+          (does :performed robot b)
+          (true :state (on q)))
+         ((next :state :performed (on q))
+          (does :performed robot b)
+          (true :state (on p)))
+         ((next :state :performed (on r))
+          (does :performed robot b)
+          (true :state (on r)))
+         ((next :state :performed (off p))
+          (does :performed robot b)
+          (true :state (off q)))
+         ((next :state :performed (off q))
+          (does :performed robot b)
+          (true :state (off p)))
+         ((next :state :performed (off r))
+          (does :performed robot b)
+          (true :state (off r)))
 
-  (fact init (cell 1 1 b))
-  (fact init (cell 1 2 b))
-  (fact init (cell 1 3 b))
-  (fact init (cell 2 1 b))
-  (fact init (cell 2 2 b))
-  (fact init (cell 2 3 b))
-  (fact init (cell 3 1 b))
-  (fact init (cell 3 2 b))
-  (fact init (cell 3 3 b))
-  (fact init (control xplayer))
-
-  (rule (next (cell ?m ?n x))
-        (does xplayer (mark ?m ?n))
-        (true (cell ?m ?n b)))
-
-  (rule (next (cell ?m ?n o))
-        (does oplayer (mark ?m ?n))
-        (true (cell ?m ?n b)))
+         ((next :state :performed (on p))
+          (does :performed robot c)
+          (true :state (on p)))
+         ((next :state :performed (on q))
+          (does :performed robot c)
+          (true :state (on r)))
+         ((next :state :performed (on r))
+          (does :performed robot c)
+          (true :state (on q)))
+         ((next :state :performed (off p))
+          (does :performed robot c)
+          (true :state (off p)))
+         ((next :state :performed (off q))
+          (does :performed robot c)
+          (true :state (off r)))
+         ((next :state :performed (off r))
+          (does :performed robot c)
+          (true :state (off q)))
 
-  (rule (next (cell ?m ?n ?w))
-        (true (cell ?m ?n ?w))
-        (distinct ?w b))
-
-  (rule (next (cell ?m ?n b))
-        (does ?w (mark ?j ?k))
-        (true (cell ?m ?n b))
-        (or (distinct ?m ?j) (distinct ?n ?k)))
-
-  (rule (next (control xplayer))
-        (true (control oplayer)))
-
-  (rule (next (control oplayer))
-        (true (control xplayer)))
+         ((next :state :performed (off s))
+          (does :performed robot a)
+          (true :state (off s)))
+         ((next :state :performed (off s))
+          (does :performed robot b)
+          (true :state (off s)))
+         ((next :state :performed (off s))
+          (does :performed robot c)
+          (true :state (off s)))
+         ((next :state :performed (on s))
+          (does :performed robot a)
+          (true :state (on s)))
+         ((next :state :performed (on s))
+          (does :performed robot b)
+          (true :state (on s)))
+         ((next :state :performed (on s))
+          (does :performed robot c)
+          (true :state (on s)))
+         ((next :state :performed (off s))
+          (does :performed robot d)
+          (true :state (on s)))
+         ((next :state :performed (on s))
+          (does :performed robot d)
+          (true :state (off s)))
 
-  (rule (row ?m ?x)
-        (true (cell ?m 1 ?x))
-        (true (cell ?m 2 ?x))
-        (true (cell ?m 3 ?x)))
-
-  (rule (column ?n ?x)
-        (true (cell 1 ?n ?x))
-        (true (cell 2 ?n ?x))
-        (true (cell 3 ?n ?x)))
+         ((next :state :performed (on p))
+          (does :performed robot d)
+          (true :state (on p)))
+         ((next :state :performed (off p))
+          (does :performed robot d)
+          (true :state (off p)))
 
-  (rule (diagonal ?x)
-        (true (cell 1 1 ?x))
-        (true (cell 2 2 ?x))
-        (true (cell 3 3 ?x)))
-
-  (rule (diagonal ?x)
-        (true (cell 1 3 ?x))
-        (true (cell 2 2 ?x))
-        (true (cell 3 1 ?x)))
-
-  (rule (line ?x) (row ?m ?x))
-  (rule (line ?x) (column ?m ?x))
-  (rule (line ?x) (diagonal ?x))
+         ((next :state :performed (on q))
+          (does :performed robot d)
+          (true :state (on q)))
+         ((next :state :performed (off q))
+          (does :performed robot d)
+          (true :state (off q)))
 
-  (rule (open)
-        (true (cell ?m ?n b)))
+         ((next :state :performed (on r))
+          (does :performed robot d)
+          (true :state (on r)))
+         ((next :state :performed (off r))
+          (does :performed robot d)
+          (true :state (off r)))
 
-  (rule (legal ?w (mark ?x ?y))
-        (true (cell ?x ?y b))
-        (true (control ?w)))
-
-  (rule (legal xplayer noop)
-        (true (control oplayer)))
+         ((next :state :performed (step :y))
+          (true :state (step :x))
+          (succ :x :y))))
 
-  (rule (legal oplayer noop)
-        (true (control xplayer)))
+(with-database *d*
+  (facts (succ num1 num2)
+         (succ num2 num3)
+         (succ num3 num4)
+         (succ num4 num5)
+         (succ num5 num6)
+         (succ num6 num7)
+         (succ num7 num8))
 
-  (rule (goal xplayer 100)
-        (line x))
-
-  (rule (goal xplayer 50)
-        (not (line x))
-        (not (line o))
-        (not open))
+  (facts (legal robot a)
+         (legal robot b)
+         (legal robot c)
+         (legal robot d)))
 
-  (rule (goal xplayer 0)
-        (line o))
-
-  (rule (goal oplayer 100)
-        (line o))
-
-  (rule (goal oplayer 50)
-        (not (line x))
-        (not (line o))
-        (not open))
+(with-database *d*
+  (rules ((goal :state robot num100)
+          (true :state (on p))
+          (true :state (on q))
+          (true :state (on r))
+          (true :state (on s))
+          )
+         ((goal :state robot num0)
+          (true :state (off p)))
+         ((goal :state robot num0)
+          (true :state (off q)))
+         ((goal :state robot num0)
+          (true :state (off r)))
+         ((goal :state robot num0)
+          (true :state (off s)))
+         )
 
-  (rule (goal oplayer 0)
-        (line x))
-
-  (rule (terminal)
-        (line x))
-
-  (rule (terminal)
-        (line o))
-
-  (rule (terminal)
-        (not open)))
+  (rules ((terminal :state)
+          (true :state (step num8)))
+         ((terminal :state)
+          (true :state (on p))
+          (true :state (on q))
+          (true :state (on r))
+          (true :state (on s))
+          )))
 
 
-;;;; GGP
-(defun random-elt (seq)
-  (elt seq (random (length seq))))
+(defun extract (key results)
+  (mapcar (lambda (result) (getf result key)) results))
 
-(defun clear-state! ()
-  (clear-predicate 'true)
-  (clear-predicate 'does))
-
-(defun extract-results (bindings)
-  (loop :for binding-list :in bindings
-        :collect (cdar binding-list)))
+(defun to-fake-list (l)
+  (if (null l)
+    'nil
+    `(cons ,(car l) ,(to-fake-list (cdr l)))))
 
-(defun build-init! ()
-  (let ((initial-state (return-all (init ?state))))
-    (loop :for state :in (extract-results initial-state)
-          :do (add-fact `(true ,state))))
-  (values))
+(defun initial-state ()
+  (to-fake-list
+    (with-database *d*
+      (extract :what (return-all (init :what))))))
 
-(defun legal-moves (role)
-  (extract-results (return-all-for `((legal ,role ?move)))))
+(defun terminalp (state)
+  (with-database *d*
+    (perform-prove `((terminal ,state)))))
 
-(defun make-move! (role move)
-  (add-fact `(does ,role ,move)))
-
-(defun advance-state! ()
-  (let ((next-facts (extract-results (return-all-for '((next ?state))))))
-    (clear-state!)
-    (mapc (lambda (n) (add-fact `(true ,n))) next-facts)))
+(defun legal-moves (state)
+  (declare (ignore state))
+  (with-database *d*
+    (return-all (legal :role :move))))
 
 (defun roles ()
-  (extract-results (return-all (role ?r))))
-
-(defun random-moves ()
-  (loop :for role :in (roles)
-        :collect (cons role (random-elt (legal-moves role)))))
+  (with-database *d*
+    (extract :role (return-all (role :role)))))
 
-(defun make-random-moves! ()
-  (loop :for (role . move) :in (random-moves)
-        :do (make-move! role move)))
+(defun goal-value (state role)
+  (with-database *d*
+    (getf (perform-return `((goal ,state ,role :goal)) :one) :goal)))
 
-(defun terminal-p ()
-  (provable-p (terminal)))
+(defun goal-values (state)
+  (with-database *d*
+    (perform-return `((goal ,state :role :goal)) :all)))
 
-(defun goals ()
-  (loop :for result :in (return-all (goal ?role ?val))
-        :collect (cons (cdr (assoc '?role result))
-                       (cdr (assoc '?val result)))))
+(defun next-state (current-state move)
+  (let ((does (to-fake-list `((does
+                                ,(getf move :role)
+                                ,(getf move :move))))))
+    (with-database *d*
+      (to-fake-list
+        (extract :what
+               (perform-return `((next ,current-state ,does :what)) :all))))))
+
+
+(defstruct search-path state (path nil) (previous nil))
 
-(defun depth-charge! ()
-  (if (terminal-p)
-    (goals)
-    (progn
-      (make-random-moves!)
-      (advance-state!)
-      (depth-charge!))))
-
-(defun fresh-depth-charge! ()
-  (progn (clear-state!)
-         (build-init!)
-         (depth-charge!)))
+(defun tree-search (states goal-p children combine)
+  (labels
+      ((recur (states)
+         (if (null states)
+           nil
+           (destructuring-bind (state . remaining) states
+             ; (format t "Searching: ~S (~D remaining)~%" state (length remaining))
+             (if (funcall goal-p state)
+               state
+               (recur (funcall combine
+                               (funcall children state)
+                               remaining)))))))
+    (let ((result (recur states)))
+      (when result
+        (reverse (search-path-path result))))))
 
 
-;;;; Run
-(dont-press-the-button)
-(tic-tac-toe)
-(clear-state!)
-(build-init!)
-(advance-state!)
-(make-random-moves!)
-(query-all (next ?x))
-(query-all (true ?x))
-(query-all (does ?r ?m))
+(defun buttons-goal-p (search-path)
+  (let ((state (search-path-state search-path)))
+    (and (terminalp state)
+         (eql (goal-value state 'robot) 'num100))))
+
+(defun buttons-children (search-path)
+  (let ((state (search-path-state search-path))
+        (path (search-path-path search-path)))
+    (when (not (terminalp state))
+      (loop :for move :in (legal-moves state)
+            :collect (make-search-path :state (next-state state move)
+                                       :path (cons move path)
+                                       :previous search-path)))))
+
+(defun never (&rest args)
+  (declare (ignore args))
+  nil)
 
-(fresh-depth-charge!)
-(time
-  (dotimes (i 100000)
-    (fresh-depth-charge!)))
+(defun dfs ()
+  (tree-search (list (make-search-path :state (initial-state)))
+               #'buttons-goal-p
+               #'buttons-children
+               #'append))
+
+(defun dfs-exhaust ()
+  (tree-search (list (make-search-path :state (initial-state)))
+               #'never
+               #'buttons-children
+               #'append))
+
+(defun bfs ()
+  (tree-search (list (make-search-path :state (initial-state)))
+               #'buttons-goal-p
+               #'buttons-children
+               (lambda (x y)
+                 (append y x))))
+
+(sb-sprof:with-profiling
+    (:report :flat
+     :sample-interval 0.001
+     :loop nil)
+  (dfs-exhaust)
+  )
diff -r 3c8bbc73e9e1 -r 4d33f11b074f src/wam/constants.lisp
--- a/src/wam/constants.lisp	Thu Apr 28 18:02:52 2016 +0000
+++ b/src/wam/constants.lisp	Sat Apr 30 22:57:09 2016 +0000
@@ -41,13 +41,6 @@
   :documentation "A functor.")
 
 
-(define-constant +functor-arity-width+ 4
-  :documentation "Number of bits dedicated to functor arity.")
-
-(define-constant +functor-arity-bitmask+ #b1111
-  :documentation "Bitmask for the functor arity bits.")
-
-
 (define-constant +register-count+ 2048
   :documentation "The number of registers the WAM has available.")
 
@@ -55,7 +48,7 @@
   :documentation "The maximum allowed arity of functors.")
 
 
-(define-constant +maximum-query-size+ 48
+(define-constant +maximum-query-size+ 1024
   :documentation
   "The maximum size (in bytes of bytecode) a query may compile to.")
 
@@ -121,4 +114,3 @@
 
 ;;;; Debug Config
 (defparameter *off-by-one* nil)
-
diff -r 3c8bbc73e9e1 -r 4d33f11b074f src/wam/dump.lisp
--- a/src/wam/dump.lisp	Thu Apr 28 18:02:52 2016 +0000
+++ b/src/wam/dump.lisp	Sat Apr 30 22:57:09 2016 +0000
@@ -333,6 +333,10 @@
   (dump-labels wam)
   (dump-code wam))
 
+(defun dump-wam-query-code (wam)
+  (with-slots (code) wam
+    (dump-code-store wam code 0 +maximum-query-size+)))
+
 (defun dump-wam-code (wam)
   (with-slots (code) wam
     (dump-code-store wam code +maximum-query-size+ (length code))))
diff -r 3c8bbc73e9e1 -r 4d33f11b074f src/wam/ui.lisp
--- a/src/wam/ui.lisp	Thu Apr 28 18:02:52 2016 +0000
+++ b/src/wam/ui.lisp	Sat Apr 30 22:57:09 2016 +0000
@@ -82,17 +82,24 @@
 
 
 (defun perform-return (query mode)
-  (let ((*results* nil)
-        (success nil))
-    (run-query *database* query
-               :status-function
-               (lambda (failp)
-                 (setf success (not failp)))
-               :result-function
-               (ecase mode
-                 (:all #'return-results-all)
-                 (:one #'return-results-one)))
-    (values *results* success)))
+  (ecase mode
+    (:all (let ((*results* nil))
+            (run-query *database* query
+                       :result-function
+                       #'return-results-all)
+            (values *results* (ensure-boolean *results*))))
+    (:one (let* ((no-results (gensym))
+                 (*results* no-results))
+            (run-query *database* query
+                       :result-function
+                       #'return-results-one)
+            (if (eql *results* no-results)
+              (values nil nil)
+              (values *results* t))))))
+
+
+(defun perform-prove (query)
+  (nth-value 1 (perform-return query :one)))
 
 
 (defmacro query (&body body)
@@ -104,12 +111,16 @@
 (defmacro query-one (&body body)
   `(perform-query ',body :one))
 
+
 (defmacro return-all (&body body)
   `(perform-return ',body :all))
 
 (defmacro return-one (&body body)
   `(perform-return ',body :one))
 
+(defmacro prove (&body body)
+  `(perform-prove ',body))
+
 
 (defun dump (&optional full-code)
   (dump-wam-full *database*)
diff -r 3c8bbc73e9e1 -r 4d33f11b074f src/wam/vm.lisp
--- a/src/wam/vm.lisp	Thu Apr 28 18:02:52 2016 +0000
+++ b/src/wam/vm.lisp	Sat Apr 30 22:57:09 2016 +0000
@@ -172,7 +172,7 @@
               (if (functors-match-p functor-1 functor-2)
                 ;; If the functors match, push their pairs of arguments onto
                 ;; the stack to be unified.
-                (loop :with arity = (cdr (wam-functor-lookup wam functor-1))
+                (loop :with arity = (cdr (wam-functor-lookup wam (cell-value functor-1)))
                       :for i :from 1 :to arity :do
                       (wam-unification-stack-push! wam (+ structure-1-addr i))
                       (wam-unification-stack-push! wam (+ structure-2-addr i)))
diff -r 3c8bbc73e9e1 -r 4d33f11b074f src/wam/wam.lisp
--- a/src/wam/wam.lisp	Thu Apr 28 18:02:52 2016 +0000
+++ b/src/wam/wam.lisp	Sat Apr 30 22:57:09 2016 +0000
@@ -434,7 +434,11 @@
   (setf (wam-program-counter wam) 0
         (wam-continuation-pointer wam) 0
         (wam-environment-pointer wam) 0
+        (wam-backtrack-pointer wam) 0
+        (wam-heap-backtrack-pointer wam) 0
+        (wam-backtracked wam) nil
         (wam-fail wam) nil
+        (wam-subterm wam) nil
         (wam-mode wam) nil))