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