77a187682a5d

--- a/gdl/mastermind.gdl	Tue Mar 14 16:35:43 2017 +0000
+++ b/gdl/mastermind.gdl	Sun May 07 16:05:34 2017 +0000
@@ -468,4 +468,4 @@
     (distinct ?s2 ?c2)
     (distinct ?s3 ?c3)
     (distinct ?s4 ?c4)
-)
\ No newline at end of file
+)

--- a/src/gdl.lisp	Tue Mar 14 16:35:43 2017 +0000
+++ b/src/gdl.lisp	Sun May 07 16:05:34 2017 +0000
@@ -93,3 +93,43 @@
   (funcall predicate (rule-head rule) term))
 
 
+;;;; Rule Splitting -----------------------------------------------------------
+;;; Rules with many terms in their bodies are difficult to make rule trees for,
+;;; because the size of the tree grows exponentially.  We can fix this problem
+;;; by splitting large disjunctions into separate rules.
+(defconstant +max-rule-size+ 8)
+
+(defun split-rule (head bodies)
+  (if (<= (length bodies) +max-rule-size+)
+    (values (mapcar (curry #'cons head) bodies) nil)
+    (iterate
+      (for chunk :in (subdivide bodies +max-rule-size+))
+      (for new-head = (list (gensym-ggp)))
+      (collecting new-head :into new-heads)
+      (appending (mapcar (curry #'cons new-head) chunk)
+                 :into new-rules)
+      (finally
+        (return (values (append new-rules
+                                (mapcar (lambda (new-head)
+                                          (list head new-head))
+                                        new-heads))
+                        t))))))
+
+(defun split-rules% (normalized-rules)
+  (let ((rules (group-by #'rule-head normalized-rules :test #'equal)))
+    (iterate
+      (for (head instances) :in-hashtable rules)
+      (for bodies = (mapcar #'rule-body instances))
+      (for (values new-instances needed-split) = (split-rule head bodies))
+      (oring needed-split :into ever-needed-split)
+      (appending new-instances :into new-rules)
+      (finally (return (values new-rules ever-needed-split))))))
+
+(defun split-rules (normalized-rules)
+  (iterate (for (values rules needed-split)
+                :first (values normalized-rules t)
+                :then (split-rules% rules))
+           (for c :from 0)
+           (while needed-split)
+           (finally (return (values rules c)))))
+

--- a/src/reasoners/zdd.lisp	Tue Mar 14 16:35:43 2017 +0000
+++ b/src/reasoners/zdd.lisp	Sun May 07 16:05:34 2017 +0000
@@ -149,7 +149,10 @@
          (rule-tree-1 rule-tree-2 ...)
 
   "
-  (let* ((rules (scully.gdl::normalize-rules rules))
+  (let* ((rules (-<> rules
+                  scully.gdl::normalize-rules
+                  scully.gdl::split-rules
+                  ))
          (roles (find-roles rules)))
     (destructuring-bind (term->number number->term possible happens)
         (scully.terms::integerize-rules rules)
@@ -265,7 +268,7 @@
 
 
 (defun iset-to-list (reasoner iset)
-  (let ((contents (scully.zdd::enumerate iset)))
+  (let ((contents (scully.zdd::zdd-enumerate iset)))
     (if (null contents)
       nil
       (map-tree (curry #'number-to-term reasoner) contents))))
@@ -566,13 +569,14 @@
 
 ;;;; 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/montyhall-grounded.gdl"))
-(defparameter *rules* (scully.gdl::read-gdl "gdl/meier-grounded.gdl"))
-(defparameter *rules* (scully.gdl::read-gdl "gdl/kriegTTT_5x5-grounded.gdl"))
 
 (defparameter *r* nil)
-;; (defparameter *r* (make-zdd-reasoner *rules*))
+(defparameter *r* (make-zdd-reasoner *rules*))
+
 
 (defun test ()
   (with-zdd
@@ -584,15 +588,16 @@
       (apply-happens *r* <>)
       (filter-iset-for-move
         *r* <>
-        'ggp-rules::candidate
-        '(ggp-rules::choose 3))
+        'ggp-rules::player
+        'ggp-rules::wait)
       (filter-iset-for-percepts
         *r* <>
-        'ggp-rules::candidate
-        '((ggp-rules::does ggp-rules::candidate (ggp-rules::choose 3))))
+        'ggp-rules::player
+        '((ggp-rules::does ggp-rules::player ggp-rules::wait)))
       (compute-next-iset *r* <>)
 
       (dump-iset *r* <>)
-      (no <>)
-      ; (draw-zdd *r* <>)
+      ;; (pr (scully.zdd::zdd-node-count <>))
+      ;; (no <>)
+      (draw-zdd *r* <>)
       )))

--- a/src/zdd.lisp	Tue Mar 14 16:35:43 2017 +0000
+++ b/src/zdd.lisp	Sun May 07 16:05:34 2017 +0000
@@ -27,14 +27,14 @@
     ,@body))
 
 
-(defun enumerate (zdd)
+(defun zdd-enumerate (zdd)
   "Return a list of all members of `zdd`."
   (ematch zdd
     ((sink nil) nil)
     ((sink t) (list nil))
     ((node variable hi lo)
-     (append (mapcar (curry #'cons variable) (enumerate hi))
-             (enumerate lo)))))
+     (append (mapcar (curry #'cons variable) (zdd-enumerate hi))
+             (zdd-enumerate lo)))))
 
 
 (defun zdd-empty-p (zdd)
@@ -372,5 +372,5 @@
 (defun test ()
   (with-zdd
     (let ((z (zdd-set '(2 3 4 5 8))))
-      (enumerate z)
-      (enumerate (zdd-match z '(2 4 8) #(t nil t nil t nil t nil t nil))))))
+      (zdd-enumerate z)
+      )))