--- a/examples/bench.lisp Thu May 19 14:13:37 2016 +0000
+++ b/examples/bench.lisp Thu Jun 02 10:36:29 2016 +0000
@@ -1,8 +1,9 @@
(ql:quickload 'bones)
(ql:quickload 'paiprolog)
-(load "examples/ggp-paip.lisp")
-(load "examples/ggp.lisp")
+(load "examples/ggp-paip-compiled.lisp")
+(load "examples/ggp-paip-interpreted.lisp")
+(load "examples/ggp-wam.lisp")
(in-package :bones)
@@ -13,34 +14,28 @@
(*error-output* (make-broadcast-stream)))
(asdf:load-system 'bones :force t)
(asdf:load-system 'paiprolog :force t)
- (load "examples/ggp-paip.lisp")
- (load "examples/ggp.lisp")))
+ (load "examples/ggp-paip-compiled.lisp")
+ (load "examples/ggp-paip-interpreted.lisp")
+ (load "examples/ggp-wam.lisp")))
-(defun run-test ()
- (reload)
-
- (format t "PAIP ------------------------------~%")
+(defun run-test% ()
+ (format t "PAIP (Compiled) --------------------~%")
(time (paiprolog-test::dfs-exhaust))
- (format t "WAM -------------------------------~%")
+ (format t "PAIP (Interpreted) -----------------~%")
+ (time (bones.paip::dfs-exhaust))
+
+ (format t "WAM --------------------------------~%")
(time (bones.wam::dfs-exhaust)))
-; (format t "~%~%====================================~%")
-; (format t "(speed 0) (safety 3) (debug 3)~%")
-; (declaim (optimize (speed 0) (safety 3) (debug 3)))
-; (run-test)
-
-(format t "~%~%====================================~%")
-(format t "(speed 3) (safety 1) (debug 1)~%")
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
-(run-test)
+(defmacro run-test (&rest settings)
+ `(progn
+ (declaim (optimize ,@settings))
+ (format t "~%~%========================================================~%")
+ (format t "~S~%" ',settings)
+ (format t "--------------------------------------------------------~%")
+ (reload)
+ (run-test%)))
-; (format t "~%~%====================================~%")
-; (format t "(speed 3) (safety 1) (debug 0)~%")
-; (declaim (optimize (speed 3) (safety 1) (debug 0)))
-; (run-test)
-
-(format t "~%~%====================================~%")
-(format t "(speed 3) (safety 0) (debug 0)~%")
-(declaim (optimize (speed 3) (safety 0) (debug 0)))
-(run-test)
+(run-test (speed 3) (safety 1) (debug 1))
+(run-test (speed 3) (safety 0) (debug 0))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/ggp-paip-compiled.lisp Thu Jun 02 10:36:29 2016 +0000
@@ -0,0 +1,281 @@
+(defpackage #:paiprolog-test
+ (:use #:cl #:paiprolog))
+
+(in-package #:paiprolog-test)
+
+
+(defvar *state* nil)
+(defvar *actions* nil)
+
+(defun paiprolog::true/1 (?thing cont)
+ (loop :with tr = (fill-pointer paiprolog::*trail*)
+ :for item :in *state*
+ :when (paiprolog::unify! ?thing item)
+ :do
+ (funcall cont)
+ (paiprolog::undo-bindings! tr)))
+
+(defun paiprolog::does/1 (?action cont)
+ (loop :with tr = (fill-pointer paiprolog::*trail*)
+ :for action :in *actions*
+ :when (paiprolog::unify! ?action action)
+ :do
+ (funcall cont)
+ (paiprolog::undo-bindings! tr)))
+
+(<-- (member ?x (?x . ?)))
+(<- (member ?x (?y . ?rest))
+ (member ?x ?rest))
+
+(<-- (role robot))
+
+(<-- (init (off p)))
+(<- (init (off q)))
+(<- (init (off r)))
+(<- (init (off s)))
+(<- (init (step num1)))
+
+(<-- (next (on p))
+ (does (robot a))
+ (true (off p)))
+(<- (next (on q))
+ (does (robot a))
+ (true (on q)))
+(<- (next (on r))
+ (does (robot a))
+ (true (on r)))
+(<- (next (off p))
+ (does (robot a))
+ (true (on p)))
+(<- (next (off q))
+ (does (robot a))
+ (true (off q)))
+(<- (next (off r))
+ (does (robot a))
+ (true (off r)))
+
+(<- (next (on p))
+ (does (robot b))
+ (true (on q)))
+(<- (next (on q))
+ (does (robot b))
+ (true (on p)))
+(<- (next (on r))
+ (does (robot b))
+ (true (on r)))
+(<- (next (off p))
+ (does (robot b))
+ (true (off q)))
+(<- (next (off q))
+ (does (robot b))
+ (true (off p)))
+(<- (next (off r))
+ (does (robot b))
+ (true (off r)))
+
+(<- (next (on p))
+ (does (robot c))
+ (true (on p)))
+(<- (next (on q))
+ (does (robot c))
+ (true (on r)))
+(<- (next (on r))
+ (does (robot c))
+ (true (on q)))
+(<- (next (off p))
+ (does (robot c))
+ (true (off p)))
+(<- (next (off q))
+ (does (robot c))
+ (true (off r)))
+(<- (next (off r))
+ (does (robot c))
+ (true (off q)))
+
+(<- (next (off s))
+ (does (robot a))
+ (true (off s)))
+(<- (next (off s))
+ (does (robot b))
+ (true (off s)))
+(<- (next (off s))
+ (does (robot c))
+ (true (off s)))
+(<- (next (on s))
+ (does (robot a))
+ (true (on s)))
+(<- (next (on s))
+ (does (robot b))
+ (true (on s)))
+(<- (next (on s))
+ (does (robot c))
+ (true (on s)))
+(<- (next (off s))
+ (does (robot d))
+ (true (on s)))
+(<- (next (on s))
+ (does (robot d))
+ (true (off s)))
+
+(<- (next (on p))
+ (does (robot d))
+ (true (on p)))
+(<- (next (off p))
+ (does (robot d))
+ (true (off p)))
+
+(<- (next (on q))
+ (does (robot d))
+ (true (on q)))
+(<- (next (off q))
+ (does (robot d))
+ (true (off q)))
+
+(<- (next (on r))
+ (does (robot d))
+ (true (on r)))
+(<- (next (off r))
+ (does (robot d))
+ (true (off r)))
+
+(<- (next (step ?y))
+ (true (step ?x))
+ (succ ?x ?y))
+
+(<-- (succ num1 num2))
+(<- (succ num2 num3))
+(<- (succ num3 num4))
+(<- (succ num4 num5))
+(<- (succ num5 num6))
+(<- (succ num6 num7))
+(<- (succ num7 num8))
+
+(<-- (legal robot a))
+(<- (legal robot b))
+(<- (legal robot c))
+(<- (legal robot d))
+
+(<-- (goal robot num100)
+ (true (on p))
+ (true (on q))
+ (true (on r))
+ (true (on s)))
+(<- (goal robot num0)
+ (true (off p)))
+(<- (goal robot num0)
+ (true (off q)))
+(<- (goal robot num0)
+ (true (off r)))
+(<- (goal robot num0)
+ (true (off s)))
+
+(<-- (terminal)
+ (true (step num8)))
+(<- (terminal)
+ (true (on p))
+ (true (on q))
+ (true (on r))
+ (true (on s)))
+
+(<-- (lol 1))
+
+
+(defvar *count* 0)
+
+(defun initial-state ()
+ (prolog-collect (?what) (init ?what)))
+
+
+(defun terminalp ()
+ (not (null (prolog-first (?lol)
+ (terminal)
+ (lol ?lol)))))
+
+(defun legal-moves (state)
+ (declare (ignore state))
+ (prolog-collect (?role ?move) (legal ?role ?move)))
+
+(defun roles ()
+ (prolog-collect (?role) (role ?role)))
+
+(defun goal-value ()
+ (prolog-first (?goal) (goal robot ?goal)))
+
+(defun next-state (move)
+ (setf *actions* (list move))
+ (prolog-collect (?what) (next ?what)))
+
+
+(defstruct search-path state (path nil) (previous nil))
+
+(defun tree-search (states goal-p children combine)
+ (labels
+ ((recur (states)
+ (if (null states)
+ nil
+ (destructuring-bind (state . remaining) states
+ (incf *count*)
+ ; (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))))))
+
+
+(defun buttons-goal-p (search-path)
+ (setf *state* (search-path-state search-path))
+ (and (terminalp)
+ (eql (goal-value) 'num100)))
+
+(defun buttons-children (search-path)
+ (let ((state (search-path-state search-path))
+ (path (search-path-path search-path)))
+ (setf *state* state)
+ (when (not (terminalp))
+ (loop :for move :in (legal-moves state)
+ :collect (make-search-path :state (next-state move)
+ :path (cons move path)
+ :previous search-path)))))
+
+(defun never (&rest args)
+ (declare (ignore args))
+ nil)
+
+(defun dfs ()
+ (tree-search (list (make-search-path :state (initial-state)))
+ #'buttons-goal-p
+ #'buttons-children
+ #'append))
+
+(defun dfs-exhaust ()
+ (let ((*count* 0))
+ (prog1
+ (tree-search (list (make-search-path :state (initial-state)))
+ #'never
+ #'buttons-children
+ #'append)
+ (format t "Searched ~D nodes.~%" *count*))))
+
+(defun bfs ()
+ (tree-search (list (make-search-path :state (initial-state)))
+ #'buttons-goal-p
+ #'buttons-children
+ (lambda (x y)
+ (append y x))))
+
+
+(declaim (sb-ext:muffle-conditions sb-ext:compiler-note))
+
+#+no
+(progn
+ (require :sb-sprof)
+ (sb-sprof:with-profiling (:max-samples 10000
+ :sample-interval 0.01
+ :loop nil)
+ (dfs-exhaust))
+
+ (sb-sprof:report :type :flat :max 100))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/ggp-paip-interpreted.lisp Thu Jun 02 10:36:29 2016 +0000
@@ -0,0 +1,274 @@
+(in-package #:bones.paip)
+
+(clear-db)
+
+(rule (member ?thing (cons ?thing ?rest)))
+
+(rule (member ?thing (cons ?other ?rest))
+ (member ?thing ?rest))
+
+(rule (true ?state ?thing)
+ (member ?thing ?state))
+
+(rule (does ?performed ?role ?move)
+ (member (does ?role ?move) ?performed))
+
+(rule (role robot))
+
+(rule (init (off p)))
+(rule (init (off q)))
+(rule (init (off r)))
+(rule (init (off s)))
+(rule (init (step num1)))
+
+(rule (next ?state ?performed (on p))
+ (does ?performed robot a)
+ (true ?state (off p)))
+(rule (next ?state ?performed (on q))
+ (does ?performed robot a)
+ (true ?state (on q)))
+(rule (next ?state ?performed (on r))
+ (does ?performed robot a)
+ (true ?state (on r)))
+(rule (next ?state ?performed (off p))
+ (does ?performed robot a)
+ (true ?state (on p)))
+(rule (next ?state ?performed (off q))
+ (does ?performed robot a)
+ (true ?state (off q)))
+(rule (next ?state ?performed (off r))
+ (does ?performed robot a)
+ (true ?state (off r)))
+
+(rule (next ?state ?performed (on p))
+ (does ?performed robot b)
+ (true ?state (on q)))
+(rule (next ?state ?performed (on q))
+ (does ?performed robot b)
+ (true ?state (on p)))
+(rule (next ?state ?performed (on r))
+ (does ?performed robot b)
+ (true ?state (on r)))
+(rule (next ?state ?performed (off p))
+ (does ?performed robot b)
+ (true ?state (off q)))
+(rule (next ?state ?performed (off q))
+ (does ?performed robot b)
+ (true ?state (off p)))
+(rule (next ?state ?performed (off r))
+ (does ?performed robot b)
+ (true ?state (off r)))
+
+(rule (next ?state ?performed (on p))
+ (does ?performed robot c)
+ (true ?state (on p)))
+(rule (next ?state ?performed (on q))
+ (does ?performed robot c)
+ (true ?state (on r)))
+(rule (next ?state ?performed (on r))
+ (does ?performed robot c)
+ (true ?state (on q)))
+(rule (next ?state ?performed (off p))
+ (does ?performed robot c)
+ (true ?state (off p)))
+(rule (next ?state ?performed (off q))
+ (does ?performed robot c)
+ (true ?state (off r)))
+(rule (next ?state ?performed (off r))
+ (does ?performed robot c)
+ (true ?state (off q)))
+
+(rule (next ?state ?performed (off s))
+ (does ?performed robot a)
+ (true ?state (off s)))
+(rule (next ?state ?performed (off s))
+ (does ?performed robot b)
+ (true ?state (off s)))
+(rule (next ?state ?performed (off s))
+ (does ?performed robot c)
+ (true ?state (off s)))
+(rule (next ?state ?performed (on s))
+ (does ?performed robot a)
+ (true ?state (on s)))
+(rule (next ?state ?performed (on s))
+ (does ?performed robot b)
+ (true ?state (on s)))
+(rule (next ?state ?performed (on s))
+ (does ?performed robot c)
+ (true ?state (on s)))
+(rule (next ?state ?performed (off s))
+ (does ?performed robot d)
+ (true ?state (on s)))
+(rule (next ?state ?performed (on s))
+ (does ?performed robot d)
+ (true ?state (off s)))
+
+(rule (next ?state ?performed (on p))
+ (does ?performed robot d)
+ (true ?state (on p)))
+(rule (next ?state ?performed (off p))
+ (does ?performed robot d)
+ (true ?state (off p)))
+
+(rule (next ?state ?performed (on q))
+ (does ?performed robot d)
+ (true ?state (on q)))
+(rule (next ?state ?performed (off q))
+ (does ?performed robot d)
+ (true ?state (off q)))
+
+(rule (next ?state ?performed (on r))
+ (does ?performed robot d)
+ (true ?state (on r)))
+(rule (next ?state ?performed (off r))
+ (does ?performed robot d)
+ (true ?state (off r)))
+
+(rule (next ?state ?performed (step ?y))
+ (true ?state (step ?x))
+ (succ ?x ?y))
+
+(rule (succ num1 num2))
+(rule (succ num2 num3))
+(rule (succ num3 num4))
+(rule (succ num4 num5))
+(rule (succ num5 num6))
+(rule (succ num6 num7))
+(rule (succ num7 num8))
+
+(rule (legal robot a))
+(rule (legal robot b))
+(rule (legal robot c))
+(rule (legal robot d))
+
+(rule (goal ?state robot num100)
+ (true ?state (on p))
+ (true ?state (on q))
+ (true ?state (on r))
+ (true ?state (on s)))
+(rule (goal ?state robot num0)
+ (true ?state (off p)))
+(rule (goal ?state robot num0)
+ (true ?state (off q)))
+(rule (goal ?state robot num0)
+ (true ?state (off r)))
+(rule (goal ?state robot num0)
+ (true ?state (off s)))
+
+(rule (terminal ?state)
+ (true ?state (step num8)))
+(rule (terminal ?state)
+ (true ?state (on p))
+ (true ?state (on q))
+ (true ?state (on r))
+ (true ?state (on s)))
+
+
+(defvar *count* 0)
+
+(defun extract (key results)
+ (mapcar (lambda (result) (cdr (assoc key result))) results))
+
+(defun to-fake-list (l)
+ (if (null l)
+ 'nil
+ `(cons ,(car l) ,(to-fake-list (cdr l)))))
+
+
+(defun initial-state ()
+ (to-fake-list
+ (extract '?what (return-all (init ?what)))))
+
+(defun terminalp (state)
+ (raw-provable-p `(terminal ,state)))
+
+(defun legal-moves (state)
+ (declare (ignore state))
+ (return-all (legal ?role ?move)))
+
+(defun roles ()
+ (extract '?role (return-all (role ?role))))
+
+(defun goal-value (state role)
+ (cdr (assoc '?goal
+ (raw-return-one `(goal ,state ,role ?goal)))))
+
+(defun goal-values (state)
+ (raw-return-all `(goal ,state ?role ?goal)))
+
+(defun next-state (current-state move)
+ (let ((does (to-fake-list `((does
+ ,(cdr (assoc '?role move))
+ ,(cdr (assoc '?move move)))))))
+ (to-fake-list
+ (extract
+ '?what
+ (raw-return-all `(next ,current-state ,does ?what))))))
+
+
+(defstruct search-path state (path nil) (previous nil))
+
+(defun tree-search (states goal-p children combine)
+ (labels
+ ((recur (states)
+ (if (null states)
+ nil
+ (destructuring-bind (state . remaining) states
+ (incf *count*)
+ ; (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))))))
+
+
+(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)
+
+(defun dfs ()
+ (tree-search (list (make-search-path :state (initial-state)))
+ #'buttons-goal-p
+ #'buttons-children
+ #'append))
+
+(defun dfs-exhaust ()
+ (let ((*count* 0))
+ (prog1
+ (tree-search (list (make-search-path :state (initial-state)))
+ #'never
+ #'buttons-children
+ #'append)
+ (format t "Searched ~D nodes.~%" *count*))))
+
+(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/examples/ggp-paip.lisp Thu May 19 14:13:37 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,281 +0,0 @@
-(defpackage #:paiprolog-test
- (:use #:cl #:paiprolog))
-
-(in-package #:paiprolog-test)
-
-
-(defvar *state* nil)
-(defvar *actions* nil)
-
-(defun paiprolog::true/1 (?thing cont)
- (loop :with tr = (fill-pointer paiprolog::*trail*)
- :for item :in *state*
- :when (paiprolog::unify! ?thing item)
- :do
- (funcall cont)
- (paiprolog::undo-bindings! tr)))
-
-(defun paiprolog::does/1 (?action cont)
- (loop :with tr = (fill-pointer paiprolog::*trail*)
- :for action :in *actions*
- :when (paiprolog::unify! ?action action)
- :do
- (funcall cont)
- (paiprolog::undo-bindings! tr)))
-
-(<-- (member ?x (?x . ?)))
-(<- (member ?x (?y . ?rest))
- (member ?x ?rest))
-
-(<-- (role robot))
-
-(<-- (init (off p)))
-(<- (init (off q)))
-(<- (init (off r)))
-(<- (init (off s)))
-(<- (init (step num1)))
-
-(<-- (next (on p))
- (does (robot a))
- (true (off p)))
-(<- (next (on q))
- (does (robot a))
- (true (on q)))
-(<- (next (on r))
- (does (robot a))
- (true (on r)))
-(<- (next (off p))
- (does (robot a))
- (true (on p)))
-(<- (next (off q))
- (does (robot a))
- (true (off q)))
-(<- (next (off r))
- (does (robot a))
- (true (off r)))
-
-(<- (next (on p))
- (does (robot b))
- (true (on q)))
-(<- (next (on q))
- (does (robot b))
- (true (on p)))
-(<- (next (on r))
- (does (robot b))
- (true (on r)))
-(<- (next (off p))
- (does (robot b))
- (true (off q)))
-(<- (next (off q))
- (does (robot b))
- (true (off p)))
-(<- (next (off r))
- (does (robot b))
- (true (off r)))
-
-(<- (next (on p))
- (does (robot c))
- (true (on p)))
-(<- (next (on q))
- (does (robot c))
- (true (on r)))
-(<- (next (on r))
- (does (robot c))
- (true (on q)))
-(<- (next (off p))
- (does (robot c))
- (true (off p)))
-(<- (next (off q))
- (does (robot c))
- (true (off r)))
-(<- (next (off r))
- (does (robot c))
- (true (off q)))
-
-(<- (next (off s))
- (does (robot a))
- (true (off s)))
-(<- (next (off s))
- (does (robot b))
- (true (off s)))
-(<- (next (off s))
- (does (robot c))
- (true (off s)))
-(<- (next (on s))
- (does (robot a))
- (true (on s)))
-(<- (next (on s))
- (does (robot b))
- (true (on s)))
-(<- (next (on s))
- (does (robot c))
- (true (on s)))
-(<- (next (off s))
- (does (robot d))
- (true (on s)))
-(<- (next (on s))
- (does (robot d))
- (true (off s)))
-
-(<- (next (on p))
- (does (robot d))
- (true (on p)))
-(<- (next (off p))
- (does (robot d))
- (true (off p)))
-
-(<- (next (on q))
- (does (robot d))
- (true (on q)))
-(<- (next (off q))
- (does (robot d))
- (true (off q)))
-
-(<- (next (on r))
- (does (robot d))
- (true (on r)))
-(<- (next (off r))
- (does (robot d))
- (true (off r)))
-
-(<- (next (step ?y))
- (true (step ?x))
- (succ ?x ?y))
-
-(<-- (succ num1 num2))
-(<- (succ num2 num3))
-(<- (succ num3 num4))
-(<- (succ num4 num5))
-(<- (succ num5 num6))
-(<- (succ num6 num7))
-(<- (succ num7 num8))
-
-(<-- (legal robot a))
-(<- (legal robot b))
-(<- (legal robot c))
-(<- (legal robot d))
-
-(<-- (goal robot num100)
- (true (on p))
- (true (on q))
- (true (on r))
- (true (on s)))
-(<- (goal robot num0)
- (true (off p)))
-(<- (goal robot num0)
- (true (off q)))
-(<- (goal robot num0)
- (true (off r)))
-(<- (goal robot num0)
- (true (off s)))
-
-(<-- (terminal)
- (true (step num8)))
-(<- (terminal)
- (true (on p))
- (true (on q))
- (true (on r))
- (true (on s)))
-
-(<-- (lol 1))
-
-
-(defvar *count* 0)
-
-(defun initial-state ()
- (prolog-collect (?what) (init ?what)))
-
-
-(defun terminalp ()
- (not (null (prolog-first (?lol)
- (terminal)
- (lol ?lol)))))
-
-(defun legal-moves (state)
- (declare (ignore state))
- (prolog-collect (?role ?move) (legal ?role ?move)))
-
-(defun roles ()
- (prolog-collect (?role) (role ?role)))
-
-(defun goal-value ()
- (prolog-first (?goal) (goal robot ?goal)))
-
-(defun next-state (move)
- (setf *actions* (list move))
- (prolog-collect (?what) (next ?what)))
-
-
-(defstruct search-path state (path nil) (previous nil))
-
-(defun tree-search (states goal-p children combine)
- (labels
- ((recur (states)
- (if (null states)
- nil
- (destructuring-bind (state . remaining) states
- (incf *count*)
- ; (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))))))
-
-
-(defun buttons-goal-p (search-path)
- (setf *state* (search-path-state search-path))
- (and (terminalp)
- (eql (goal-value) 'num100)))
-
-(defun buttons-children (search-path)
- (let ((state (search-path-state search-path))
- (path (search-path-path search-path)))
- (setf *state* state)
- (when (not (terminalp))
- (loop :for move :in (legal-moves state)
- :collect (make-search-path :state (next-state move)
- :path (cons move path)
- :previous search-path)))))
-
-(defun never (&rest args)
- (declare (ignore args))
- nil)
-
-(defun dfs ()
- (tree-search (list (make-search-path :state (initial-state)))
- #'buttons-goal-p
- #'buttons-children
- #'append))
-
-(defun dfs-exhaust ()
- (let ((*count* 0))
- (prog1
- (tree-search (list (make-search-path :state (initial-state)))
- #'never
- #'buttons-children
- #'append)
- (format t "Searched ~D nodes.~%" *count*))))
-
-(defun bfs ()
- (tree-search (list (make-search-path :state (initial-state)))
- #'buttons-goal-p
- #'buttons-children
- (lambda (x y)
- (append y x))))
-
-
-(declaim (sb-ext:muffle-conditions sb-ext:compiler-note))
-
-#+no
-(progn
- (require :sb-sprof)
- (sb-sprof:with-profiling (:max-samples 10000
- :sample-interval 0.01
- :loop nil)
- (dfs-exhaust))
-
- (sb-sprof:report :type :flat :max 100))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/ggp-wam.lisp Thu Jun 02 10:36:29 2016 +0000
@@ -0,0 +1,285 @@
+(in-package #:bones.wam)
+
+(defparameter *d* (make-database))
+
+(with-database *d*
+ (rules ((member :thing (cons :thing :rest)))
+ ((member :thing (cons :other :rest))
+ (member :thing :rest)))
+
+ (rule (true :state :thing)
+ (member :thing :state))
+
+ (rule (does :performed :role :move)
+ (member (does :role :move) :performed))
+
+ (fact (role robot))
+
+ (facts (init (off p))
+ (init (off q))
+ (init (off r))
+ (init (off s))
+ (init (step num1))))
+
+(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)))
+
+ ((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)))
+
+ ((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)))
+
+ ((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)))
+
+ ((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)))
+
+ ((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)))
+
+ ((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)))
+
+ ((next :state :performed (step :y))
+ (true :state (step :x))
+ (succ :x :y))))
+
+(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))
+
+ (facts (legal robot a)
+ (legal robot b)
+ (legal robot c)
+ (legal robot d)))
+
+(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)))
+ )
+
+ (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))
+ )))
+
+
+(defun extract (key results)
+ (mapcar (lambda (result) (getf result key)) results))
+
+(defun to-fake-list (l)
+ (if (null l)
+ 'nil
+ `(cons ,(car l) ,(to-fake-list (cdr l)))))
+
+(defun initial-state ()
+ (to-fake-list
+ (with-database *d*
+ (extract :what (return-all (init :what))))))
+
+(defun terminalp (state)
+ (with-database *d*
+ (perform-prove `((terminal ,state)))))
+
+(defun legal-moves (state)
+ (declare (ignore state))
+ (with-database *d*
+ (return-all (legal :role :move))))
+
+(defun roles ()
+ (with-database *d*
+ (extract :role (return-all (role :role)))))
+
+(defun goal-value (state role)
+ (with-database *d*
+ (getf (perform-return `((goal ,state ,role :goal)) :one) :goal)))
+
+(defun goal-values (state)
+ (with-database *d*
+ (perform-return `((goal ,state :role :goal)) :all)))
+
+(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))))))
+
+
+
+(defvar *count* 0)
+
+(defstruct search-path state (path nil) (previous nil))
+
+(defun tree-search (states goal-p children combine)
+ (labels
+ ((recur (states)
+ (if (null states)
+ nil
+ (destructuring-bind (state . remaining) states
+ (incf *count*)
+ ; (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))))))
+
+
+(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)
+
+(defun dfs ()
+ (tree-search (list (make-search-path :state (initial-state)))
+ #'buttons-goal-p
+ #'buttons-children
+ #'append))
+
+(defun dfs-exhaust ()
+ (let ((*count* 0))
+ (prog1
+ (tree-search (list (make-search-path :state (initial-state)))
+ #'never
+ #'buttons-children
+ #'append)
+ (format t "Searched ~D nodes.~%" *count*))))
+
+(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/examples/ggp.lisp Thu May 19 14:13:37 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,285 +0,0 @@
-(in-package #:bones.wam)
-
-(defparameter *d* (make-database))
-
-(with-database *d*
- (rules ((member :thing (cons :thing :rest)))
- ((member :thing (cons :other :rest))
- (member :thing :rest)))
-
- (rule (true :state :thing)
- (member :thing :state))
-
- (rule (does :performed :role :move)
- (member (does :role :move) :performed))
-
- (fact (role robot))
-
- (facts (init (off p))
- (init (off q))
- (init (off r))
- (init (off s))
- (init (step num1))))
-
-(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)))
-
- ((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)))
-
- ((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)))
-
- ((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)))
-
- ((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)))
-
- ((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)))
-
- ((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)))
-
- ((next :state :performed (step :y))
- (true :state (step :x))
- (succ :x :y))))
-
-(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))
-
- (facts (legal robot a)
- (legal robot b)
- (legal robot c)
- (legal robot d)))
-
-(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)))
- )
-
- (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))
- )))
-
-
-(defun extract (key results)
- (mapcar (lambda (result) (getf result key)) results))
-
-(defun to-fake-list (l)
- (if (null l)
- 'nil
- `(cons ,(car l) ,(to-fake-list (cdr l)))))
-
-(defun initial-state ()
- (to-fake-list
- (with-database *d*
- (extract :what (return-all (init :what))))))
-
-(defun terminalp (state)
- (with-database *d*
- (perform-prove `((terminal ,state)))))
-
-(defun legal-moves (state)
- (declare (ignore state))
- (with-database *d*
- (return-all (legal :role :move))))
-
-(defun roles ()
- (with-database *d*
- (extract :role (return-all (role :role)))))
-
-(defun goal-value (state role)
- (with-database *d*
- (getf (perform-return `((goal ,state ,role :goal)) :one) :goal)))
-
-(defun goal-values (state)
- (with-database *d*
- (perform-return `((goal ,state :role :goal)) :all)))
-
-(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))))))
-
-
-
-(defvar *count* 0)
-
-(defstruct search-path state (path nil) (previous nil))
-
-(defun tree-search (states goal-p children combine)
- (labels
- ((recur (states)
- (if (null states)
- nil
- (destructuring-bind (state . remaining) states
- (incf *count*)
- ; (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))))))
-
-
-(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)
-
-(defun dfs ()
- (tree-search (list (make-search-path :state (initial-state)))
- #'buttons-goal-p
- #'buttons-children
- #'append))
-
-(defun dfs-exhaust ()
- (let ((*count* 0))
- (prog1
- (tree-search (list (make-search-path :state (initial-state)))
- #'never
- #'buttons-children
- #'append)
- (format t "Searched ~D nodes.~%" *count*))))
-
-(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/examples/profile.lisp Thu May 19 14:13:37 2016 +0000
+++ b/examples/profile.lisp Thu Jun 02 10:36:29 2016 +0000
@@ -2,7 +2,7 @@
(require :sb-sprof)
-(load "examples/ggp.lisp")
+(load "examples/ggp-wam.lisp")
(in-package :bones)