Improve sprouting by sorting the does layer and constructing the ZDD manually
author |
Steve Losh <steve@stevelosh.com> |
date |
Tue, 09 May 2017 12:37:41 +0000 |
parents |
77a187682a5d
|
children |
4c2306e08ed1
|
branches/tags |
(none) |
files |
src/reasoners/zdd.lisp src/terms.lisp src/zdd.lisp |
Changes
--- 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 <>)
)))
--- 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)
--- 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*)