--- a/src/reasoners/zdd.lisp Thu Dec 15 13:03:18 2016 -0500
+++ b/src/reasoners/zdd.lisp Thu Dec 15 15:20:07 2016 -0500
@@ -1,5 +1,8 @@
(in-package :scully.reasoners.zdd)
+(defparameter *reasoner* nil)
+
+
;;;; Utils --------------------------------------------------------------------
(defmacro defclass* (name-and-options direct-superclasses slots &rest options)
(flet ((slot-definition (conc-name slot)
@@ -23,6 +26,18 @@
,@options))))
+(defun find-ggp-symbol (atom)
+ (if (symbolp atom)
+ (values (intern (symbol-name atom)
+ (find-package :ggp-rules)))
+ atom))
+
+(defun make-iset (reasoner contents)
+ ; (print-hash-table (zr-term->number reasoner))
+ (zdd-set (mapcar (curry #'term-to-number reasoner)
+ (map-tree #'find-ggp-symbol contents))))
+
+
;;;; Rule Forests -------------------------------------------------------------
(defclass* (rule-forest :conc-name rf-) ()
(strata
@@ -167,7 +182,10 @@
(defun label (reasoner n)
(let ((*package* (find-package :ggp-rules)))
(-<> n
- (number-to-term reasoner <>)
+ (number-to-term (if (eq t reasoner)
+ *reasoner*
+ reasoner)
+ <>)
(structural-string <>))))
(defun draw-zdd (reasoner zdd)
@@ -178,6 +196,7 @@
;;;; Logic Application --------------------------------------------------------
+;;;; Utils
(defun tree-to-result (tree)
(adt:match scully.rule-trees::rule-tree tree
((scully.rule-trees::top head) (values nil head))
@@ -218,6 +237,7 @@
(finally (return (values (make-forest-with forest new-strata) heads)))))
+;;;; Phase 1: Information Set Traversal
(defun advance-tree (tree term)
"Advance the rule tree up to (but not beyond) `term`.
@@ -270,15 +290,8 @@
(process-forest (rcurry #'split-tree-lo term) forest))
-(defun finalize-heads (reasoner forest heads)
- "Finalize the set of heads to add and return the appropriate ZDD."
- (prl reasoner forest heads)
- (zdd-set heads))
-
-
-(defun traverse-iset (reasoner iset forest)
+(defun traverse-iset (iset forest)
"Walk down the information set and rule forest in parallel."
- (declare (ignorable reasoner))
(recursively ((iset iset)
(forest forest)
(heads '()))
@@ -289,7 +302,7 @@
;; If we hit a unit sink we're done with the state-walking portion of this
;; algorithm and can move on the the fixed-pointing of the heads.
- ((sink t) (finalize-heads reasoner forest heads))
+ ((sink t) (finalize-heads forest heads))
;; Otherwise we need to build a new ZDD node with the recursive results.
((node term hi lo)
@@ -303,11 +316,71 @@
(recur lo forest-lo (append heads advanced-heads lo-heads))))))))
+;;;; Phase 2: Head Finalization
+(defun walk-tree-positive (rule-tree heads)
+ ; (pr "Walking positive rule tree with heads"
+ ; (mapcar (curry #'number-to-term *reasoner*) heads))
+ ; (draw-rule-tree t rule-tree)
+ ; (break)
+ (adt:match scully.rule-trees::rule-tree rule-tree
+ ((scully.rule-trees::node term hi _)
+ (if (member term heads)
+ (walk-tree-positive hi heads)
+ (tree-to-result rule-tree)))
+ (_ (tree-to-result rule-tree))))
+
+(defun walk-tree-negative (rule-tree heads)
+ ; (pr "Walking negative rule tree with heads"
+ ; (mapcar (curry #'number-to-term *reasoner*) heads))
+ ; (draw-rule-tree t rule-tree)
+ ; (break)
+ (adt:match scully.rule-trees::rule-tree rule-tree
+ ((scully.rule-trees::node term hi lo)
+ (if (member term heads)
+ (walk-tree-negative hi heads)
+ (walk-tree-negative lo heads)))
+ (_ (tree-to-result rule-tree))))
+
+
+(defun walk-stratum-positive (stratum heads)
+ (iterate
+ ; (pr "Beginning stratum walk, starthing with heads" heads)
+ (for (values new-stratum new-heads) =
+ (process-stratum (rcurry #'walk-tree-positive heads) stratum))
+ ; (pr "Found new heads:" new-heads)
+ ; (break)
+ (appending new-heads :into all-new-heads)
+ (setf stratum new-stratum
+ heads (append heads new-heads))
+ (while new-heads)
+ (finally (return (values stratum all-new-heads)))))
+
+(defun walk-stratum-negative (stratum heads)
+ (process-stratum (rcurry #'walk-tree-negative heads) stratum))
+
+
+(defun finalize-heads (forest heads)
+ "Finalize the set of heads to add and return the appropriate ZDD."
+ (multiple-value-bind (f h) (advance-forest forest (rf-lower-bound forest))
+ (setf heads (append heads h)
+ forest f))
+ (iterate
+ (for stratum :in (rf-strata forest))
+ (multiple-value-bind (s h) (walk-stratum-positive stratum heads)
+ (setf heads (append heads h)
+ stratum s))
+ (multiple-value-bind (s h) (walk-stratum-negative stratum heads)
+ (setf heads (append heads h)
+ stratum s))
+ (finally (return (zdd-set heads)))))
+
+
+;;;; API
(defun apply-rule-forest (reasoner iset forest)
"Apply `forest` to the given information set for `reasoner`."
- (declare (ignorable reasoner))
(with-zdd
- (traverse-iset reasoner iset forest)))
+ (let ((*reasoner* reasoner))
+ (traverse-iset iset forest))))
;;;; Scratch ------------------------------------------------------------------
@@ -318,11 +391,40 @@
; (scully.gdl::read-gdl "gdl/roshambo2-grounded.gdl")
)
(defparameter *l* (make-zdd-reasoner *rules*))
+(defparameter *i* (initial-iset *l*))
+(defparameter *j* (initial-iset *l*))
-; (draw-zdd *l* (initial-iset *l*))
+(with-zdd
+ (-<> *l*
+ (make-iset '(
+ (true (control oplayer))
+ (true (cell 1 1 o)) (true (cell 1 2 x)) (true (cell 1 3 o))
+ (true (cell 2 1 x)) (true (cell 2 2 o)) (true (cell 2 3 o))
+ (true (cell 3 1 x)) (true (cell 3 2 x)) (true (cell 3 3 x))
+ ))
+ (apply-rule-forest *l* <> (zr-possible-forest *l*))
+ (draw-zdd *l* <>)
+ ))
-; (-<> *l*
-; (apply-rule-forest <> (initial-iset *l*) (zr-possible-forest *l*))
-; (draw-zdd *l* <>)
-; (no <>)
-; )
+(with-zdd
+ (-<>
+ (zdd-union (make-iset *l* '(
+ (true (control xplayer))
+ (true (cell 1 1 o)) (true (cell 1 2 x)) (true (cell 1 3 B))
+ (true (cell 2 1 x)) (true (cell 2 2 o)) (true (cell 2 3 o))
+ (true (cell 3 1 x)) (true (cell 3 2 o)) (true (cell 3 3 x))
+ ))
+ (make-iset *l* '(
+ (true (control xplayer))
+ (true (cell 1 1 o)) (true (cell 1 2 B)) (true (cell 1 3 x))
+ (true (cell 2 1 x)) (true (cell 2 2 o)) (true (cell 2 3 o))
+ (true (cell 3 1 x)) (true (cell 3 2 o)) (true (cell 3 3 x))
+ ))
+ (make-iset *l* '(
+ (true (control xplayer))
+ (true (cell 1 1 o)) (true (cell 1 2 x)) (true (cell 1 3 x))
+ (true (cell 2 1 x)) (true (cell 2 2 o)) (true (cell 2 3 o))
+ (true (cell 3 1 x)) (true (cell 3 2 o)) (true (cell 3 3 B))
+ )))
+ (apply-rule-forest *l* <> (zr-possible-forest *l*))
+ (draw-zdd *l* <>)))
--- a/src/terms.lisp Thu Dec 15 13:03:18 2016 -0500
+++ b/src/terms.lisp Thu Dec 15 15:20:07 2016 -0500
@@ -94,7 +94,15 @@
(_ (collect term))))))
(defun extract-does (layers terms)
- (extract-simple '(ggp-rules::does) :does layers terms))
+ (prog1
+ (extract-simple '(ggp-rules::does) :does layers terms)
+ ;; In addition to the simple things, we need to make sure we've got
+ ;; a corresponding `(does *)` term for any `(legal *)` term.
+ (iterate (for term :in terms)
+ (match term
+ (`(ggp-rules::legal ,@contents)
+ (mark layers :does `(ggp-rules::does ,@contents)))
+ (_ (collect term))))))
(defun extract-possible% (layers dependencies terms)
--- a/vendor/make-quickutils.lisp Thu Dec 15 13:03:18 2016 -0500
+++ b/vendor/make-quickutils.lisp Thu Dec 15 15:20:07 2016 -0500
@@ -16,6 +16,7 @@
:hash-table-keys
:hash-table-values
:map-product
+ :map-tree
:mkstr
:once-only
:rcurry
--- a/vendor/quickutils.lisp Thu Dec 15 13:03:18 2016 -0500
+++ b/vendor/quickutils.lisp Thu Dec 15 15:20:07 2016 -0500
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :EXTREMUM :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :SUBDIVIDE :SYMB :WITH-GENSYMS :WITH-OUTPUT-TO-FILE :WRITE-STRING-INTO-FILE :YES-NO) :ensure-package T :package "SCULLY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MAP-TREE :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :SUBDIVIDE :SYMB :WITH-GENSYMS :WITH-OUTPUT-TO-FILE :WRITE-STRING-INTO-FILE :YES-NO) :ensure-package T :package "SCULLY.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SCULLY.QUICKUTILS")
@@ -20,10 +20,11 @@
:HASH-TABLE-ALIST :MAPHASH-KEYS
:HASH-TABLE-KEYS :MAPHASH-VALUES
:HASH-TABLE-VALUES :MAPPEND
- :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY
- :SET-EQUAL :SUBDIVIDE :SYMB
- :STRING-DESIGNATOR :WITH-GENSYMS
- :WITH-OPEN-FILE* :WITH-OUTPUT-TO-FILE
+ :MAP-PRODUCT :MAP-TREE :MKSTR
+ :ONCE-ONLY :RCURRY :SET-EQUAL
+ :SUBDIVIDE :SYMB :STRING-DESIGNATOR
+ :WITH-GENSYMS :WITH-OPEN-FILE*
+ :WITH-OUTPUT-TO-FILE
:WRITE-STRING-INTO-FILE :YES-NO))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
@@ -270,6 +271,19 @@
(%map-product (ensure-function function) (cons list more-lists))))
+ (defun map-tree (function tree)
+ "Map `function` to each of the leave of `tree`."
+ (check-type tree cons)
+ (labels ((rec (tree)
+ (cond
+ ((null tree) nil)
+ ((atom tree) (funcall function tree))
+ ((consp tree)
+ (cons (rec (car tree))
+ (rec (cdr tree)))))))
+ (rec tree)))
+
+
(defun mkstr (&rest args)
"Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
@@ -475,8 +489,8 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(compose copy-hash-table curry ensure-boolean ensure-gethash
ensure-list extremum flatten-once hash-table-alist hash-table-keys
- hash-table-values map-product mkstr once-only rcurry set-equal
- subdivide symb with-gensyms with-unique-names with-output-to-file
- write-string-into-file yes no)))
+ hash-table-values map-product map-tree mkstr once-only rcurry
+ set-equal subdivide symb with-gensyms with-unique-names
+ with-output-to-file write-string-into-file yes no)))
;;;; END OF quickutils.lisp ;;;;