4520c6449f48

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/ggp-wam-hanoi.lisp	Thu Jun 30 17:53:20 2016 +0000
@@ -0,0 +1,272 @@
+(in-package #:bones.wam)
+
+(declaim (optimize (speed 3) (debug 0) (safety 0)))
+
+(defparameter *d* (make-database))
+
+(with-database *d*
+  (rules ((member :thing (list* :thing :rest)))
+         ((member :thing (list* :other :rest))
+          (member :thing :rest)))
+
+  (rule (true :state :thing)
+    (member :thing :state))
+
+  (rule (does :performed :role :move)
+    (member (does :role :move) :performed))
+
+  (rules ((not :x) (call :x) ! fail)
+         ((not :x)))
+
+  (fact (role player))
+
+  (facts (init (on disc7 pillar1))
+         (init (on disc6 disc7))
+         (init (on disc5 disc6))
+         (init (on disc4 disc5))
+         (init (on disc3 disc4))
+         (init (on disc2 disc3))
+         (init (on disc1 disc2))
+         (init (clear disc1))
+         (init (clear pillar2))
+         (init (clear pillar3))
+         (init (step s0)))
+
+  (rule (legal :state player (puton :x :y))
+    (true :state (clear :x))
+    (true :state (clear :y))
+    (smallerdisc :x :y))
+
+  (rules ((next :state :performed (step :y))
+          (true :state (step :x))
+          (successor :x :y))
+         ((next :state :performed (on :x :y))
+          (does :performed player (puton :x :y)))
+         ((next :state :performed (on :x :y))
+          (true :state (on :x :y))
+          (not (put_on_any :performed :x)))
+         ((next :state :performed (clear :y))
+          (true :state (on :x :y))
+          (put_on_any :performed :x))
+         ((next :state :performed (clear :y))
+          (true :state (clear :y))
+          (not (put_any_on :performed :y))))
+
+  (rule (put_on_any :performed :x)
+    (does :performed player (puton :x :y)))
+
+  (rule (put_any_on :performed :y)
+    (does :performed player (puton :x :y)))
+
+  (rules ((goal :state player num100)
+          (tower :state pillar3 s7))
+         ((goal :state player num80)
+          (tower :state pillar3 s6))
+         ((goal :state player num60)
+          (tower :state pillar3 s5))
+         ((goal :state player num40)
+          (tower :state pillar3 s4))
+         ((goal :state player num0)
+          (tower :state pillar3 :height)
+          (smaller :height s4)))
+
+  (rule (terminal :state)
+    (true :state (step s127)))
+
+  (rules ((tower :state :x s0)
+          (true :state (clear :x)))
+         ((tower :state :x :height)
+          (true :state (on :y :x))
+          (disc_or_pillar :y)
+          (tower :state :y :height1)
+          (successor :height1 :height)))
+
+  (facts (pillar pillar1)
+         (pillar pillar2)
+         (pillar pillar3))
+
+  (rules ((nextsize disc1 disc2))
+         ((nextsize disc2 disc3))
+         ((nextsize disc3 disc4))
+         ((nextsize disc4 disc5))
+         ((nextsize disc5 disc6))
+         ((nextsize disc6 disc7))
+         ((nextsize disc7 :pillar)
+          (pillar :pillar)))
+
+  (rules ((disc_or_pillar :p) (pillar :p))
+         ((disc_or_pillar disc1))
+         ((disc_or_pillar disc2))
+         ((disc_or_pillar disc3))
+         ((disc_or_pillar disc4))
+         ((disc_or_pillar disc5))
+         ((disc_or_pillar disc6))
+         ((disc_or_pillar disc7)))
+
+  (rules ((smallerdisc :a :b)
+          (nextsize :a :b))
+         ((smallerdisc :a :b)
+          (nextsize :a :c)
+          (smallerdisc :c :b)))
+
+  (facts (successor s0 s1) (successor s1 s2) (successor s2 s3)
+         (successor s3 s4) (successor s4 s5) (successor s5 s6)
+         (successor s6 s7) (successor s7 s8) (successor s8 s9)
+         (successor s9 s10) (successor s10 s11) (successor s11 s12)
+         (successor s12 s13) (successor s13 s14) (successor s14 s15)
+         (successor s15 s16) (successor s16 s17) (successor s17 s18)
+         (successor s18 s19) (successor s19 s20) (successor s20 s21)
+         (successor s21 s22) (successor s22 s23) (successor s23 s24)
+         (successor s24 s25) (successor s25 s26) (successor s26 s27)
+         (successor s27 s28) (successor s28 s29) (successor s29 s30)
+         (successor s30 s31) (successor s31 s32) (successor s32 s33)
+         (successor s33 s34) (successor s34 s35) (successor s35 s36)
+         (successor s36 s37) (successor s37 s38) (successor s38 s39)
+         (successor s39 s40) (successor s40 s41) (successor s41 s42)
+         (successor s42 s43) (successor s43 s44) (successor s44 s45)
+         (successor s45 s46) (successor s46 s47) (successor s47 s48)
+         (successor s48 s49) (successor s49 s50) (successor s50 s51)
+         (successor s51 s52) (successor s52 s53) (successor s53 s54)
+         (successor s54 s55) (successor s55 s56) (successor s56 s57)
+         (successor s57 s58) (successor s58 s59) (successor s59 s60)
+         (successor s60 s61) (successor s61 s62) (successor s62 s63)
+         (successor s63 s64) (successor s64 s65) (successor s65 s66)
+         (successor s66 s67) (successor s67 s68) (successor s68 s69)
+         (successor s69 s70) (successor s70 s71) (successor s71 s72)
+         (successor s72 s73) (successor s73 s74) (successor s74 s75)
+         (successor s75 s76) (successor s76 s77) (successor s77 s78)
+         (successor s78 s79) (successor s79 s80) (successor s80 s81)
+         (successor s81 s82) (successor s82 s83) (successor s83 s84)
+         (successor s84 s85) (successor s85 s86) (successor s86 s87)
+         (successor s87 s88) (successor s88 s89) (successor s89 s90)
+         (successor s90 s91) (successor s91 s92) (successor s92 s93)
+         (successor s93 s94) (successor s94 s95) (successor s95 s96)
+         (successor s96 s97) (successor s97 s98) (successor s98 s99)
+         (successor s99 s100) (successor s100 s101) (successor s101 s102)
+         (successor s102 s103) (successor s103 s104) (successor s104 s105)
+         (successor s105 s106) (successor s106 s107) (successor s107 s108)
+         (successor s108 s109) (successor s109 s110) (successor s110 s111)
+         (successor s111 s112) (successor s112 s113) (successor s113 s114)
+         (successor s114 s115) (successor s115 s116) (successor s116 s117)
+         (successor s117 s118) (successor s118 s119) (successor s119 s120)
+         (successor s120 s121) (successor s121 s122) (successor s122 s123)
+         (successor s123 s124) (successor s124 s125) (successor s125 s126)
+         (successor s126 s127))
+
+  (rules ((smaller :x :y)
+          (successor :x :y))
+         ((smaller :x :y)
+          (successor :x :z)
+          (smaller :z :y))))
+
+
+(defun extract (key results)
+  (mapcar (lambda (result) (getf result key)) results))
+
+(defun to-prolog-list (l)
+  (if (null l)
+    nil
+    (list* 'list l)))
+
+(defun initial-state ()
+  (to-prolog-list
+    (with-database *d*
+      (extract :what (return-all (init :what))))))
+
+(defun terminalp (state)
+  (with-database *d*
+    (perform-prove `((terminal ,state)))))
+
+(defun legal-moves (state)
+  (with-database *d*
+    (perform-return `((legal ,state :role :move)) :all)))
+
+(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 `(list (does
+                       ,(getf move :role)
+                       ,(getf move :move)))))
+    (with-database *d*
+      (to-prolog-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*)
+             (when (zerop (rem *count* 1000))
+               (format t "~D...~%" *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 game-goal-p (search-path)
+  (let ((state (search-path-state search-path)))
+    (and (terminalp state)
+         (eql (goal-value state 'player) 'num100))))
+
+(defun game-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 ()
+  (let ((*count* 0))
+    (tree-search (list (make-search-path :state (initial-state)))
+               #'game-goal-p
+               #'game-children
+               #'append)))
+
+(defun dfs-exhaust ()
+  (let ((*count* 0))
+    (prog1
+        (tree-search (list (make-search-path :state (initial-state)))
+                     #'never
+                     #'game-children
+                     #'append)
+      (format t "Searched ~D nodes.~%" *count*))))
+
+(defun bfs ()
+  (tree-search (list (make-search-path :state (initial-state)))
+               #'game-goal-p
+               #'game-children
+               (lambda (x y)
+                 (append y x))))