# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1494333461 0
# Node ID a3e8fc8cad533951e32fd0c26dc8d029a1b3b3e8
# Parent  77a187682a5d44f26afd22b1eafbc5d8c22baafd
Improve sprouting by sorting the does layer and constructing the ZDD manually

diff -r 77a187682a5d -r a3e8fc8cad53 src/reasoners/zdd.lisp
--- a/src/reasoners/zdd.lisp	Sun May 07 16:05:34 2017 +0000
+++ b/src/reasoners/zdd.lisp	Tue May 09 12:37:41 2017 +0000
@@ -211,18 +211,28 @@
 
 
 ;;;; Sprouting ----------------------------------------------------------------
+(defun build-role-move-zdd (next-zdd role-moves)
+  (reduce (lambda (prev move)
+            (zdd-node move next-zdd prev))
+          (sort role-moves #'>)
+          :initial-value (sink nil)))
+
+(defun sprout-extend% (legal-moves-by-role)
+  (reduce #'build-role-move-zdd legal-moves-by-role :initial-value (sink t)))
+
 (defun sprout-extend (reasoner legal-moves)
-  (let* ((moves (-<> legal-moves
-                  (group-by #'second <>)
-                  hash-table-values
-                  (mapcar (lambda (role-moves)
-                            (mapcar (curry #'term-to-number reasoner) role-moves))
-                          <>)))
-         (combinations (gathering
-                         (apply #'map-product
-                                (compose #'gather #'list)
-                                moves))))
-    (apply #'zdd-family combinations)))
+  (sprout-extend%
+    (-<> legal-moves
+      (group-by #'second <>) ; go role by role
+      hash-table-values
+      (sort <> #'scully.terms::symbol< ; sort by role 
+            :key (lambda (moves)
+                   (second (first moves))))
+      nreverse ; go bottom up
+      (mapcar (lambda (role-moves) ; convert to integers
+                (mapcar (curry #'term-to-number reasoner) role-moves))
+              <>))))
+
 
 (defun sprout-traverse (reasoner iset)
   (recursively ((z iset)
@@ -569,12 +579,13 @@
 
 ;;;; Scratch ------------------------------------------------------------------
 (defparameter *rules* (scully.gdl::read-gdl "gdl/meier-grounded.gdl"))
-(defparameter *rules* (scully.gdl::read-gdl "gdl/montyhall-grounded.gdl"))
-(defparameter *rules* (scully.gdl::read-gdl "gdl/mastermind-grounded.gdl"))
 (defparameter *rules* (scully.gdl::read-gdl "gdl/kriegTTT_5x5-grounded.gdl"))
 (defparameter *rules* (scully.gdl::read-gdl "gdl/pennies-grounded.gdl"))
+(defparameter *rules* (scully.gdl::read-gdl "gdl/mastermind-grounded.gdl"))
+(defparameter *rules* (scully.gdl::read-gdl "gdl/montyhall-grounded.gdl"))
 
-(defparameter *r* nil)
+(defparameter *i* nil)
+;; (defparameter *r* nil)
 (defparameter *r* (make-zdd-reasoner *rules*))
 
 
@@ -596,8 +607,11 @@
         '((ggp-rules::does ggp-rules::player ggp-rules::wait)))
       (compute-next-iset *r* <>)
 
-      (dump-iset *r* <>)
-      ;; (pr (scully.zdd::zdd-node-count <>))
-      ;; (no <>)
-      (draw-zdd *r* <>)
+      (apply-possible *r* <>)
+      (sprout *r* <>)
+
+      ;; (dump-iset *r* <>)
+      (pr (scully.zdd::zdd-node-count <>))
+      ;; (draw-zdd *r* <>)
+      (no <>)
       )))
diff -r 77a187682a5d -r a3e8fc8cad53 src/terms.lisp
--- a/src/terms.lisp	Sun May 07 16:05:34 2017 +0000
+++ b/src/terms.lisp	Tue May 09 12:37:41 2017 +0000
@@ -210,6 +210,11 @@
 
 
 ;;;; Intra-Layer Ordering -----------------------------------------------------
+(defun symbol< (a b)
+  (string< (symbol-name a)
+           (symbol-name b)))
+
+
 (defun sort-and-flatten-strata (strata)
   "Take `strata` and turn it into a sorted list of rule heads."
   (flet ((heads-in-stratum (stratum)
@@ -252,6 +257,10 @@
                     -1))
                (_ -2))))
 
+(defun sort-does-layer (does-terms)
+  "Return a fresh list of the does terms, sorted correctly."
+  (sort (copy-seq does-terms) #'symbol< :key #'second))
+
 
 (defun order-terms (rules)
   "Find a linear ordering of all terms in `rules`.
@@ -275,7 +284,7 @@
       (let* ((possible-terms (order-layer (gethash :possible layers) possible-strata))
              (happens-terms (order-layer (gethash :happens layers) happens-strata))
              (base-terms (sort-base-layer (gethash :base layers) happens-terms))
-             (does-terms (gethash :does layers)))
+             (does-terms (sort-does-layer (gethash :does layers))))
         ;; And finally we concatenate the layer orderings into one bigass order:
         ;; base < possible < does < happens
         (values (append base-terms possible-terms does-terms happens-terms)
diff -r 77a187682a5d -r a3e8fc8cad53 src/zdd.lisp
--- a/src/zdd.lisp	Sun May 07 16:05:34 2017 +0000
+++ b/src/zdd.lisp	Tue May 09 12:37:41 2017 +0000
@@ -20,7 +20,6 @@
 (defparameter *cache*
   (tg:make-weak-hash-table :weakness :value :test #'equalp))
 
-
 (defmacro with-zdd (&body body)
   "Execute `body` with the ZDD settings properly initialized."
   `(with-odd-context (:operation #'zdd-apply :node-cache *cache*)