--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gdl/pennies.gdl Mon Feb 13 17:54:31 2017 +0000
@@ -0,0 +1,59 @@
+(role alice)
+(role random)
+
+(side tails)
+(side heads)
+
+(init (coin unset))
+(init (coins unset unset))
+(init (control random))
+
+(<= (legal random (choose ?s1 ?s2))
+ (true (control random))
+ (side ?s1) (side ?s2))
+
+(<= (legal ?p noop)
+ (role ?p)
+ (not (true (control ?p))))
+
+(<= (legal alice (play ?s))
+ (true (control alice))
+ (side ?s))
+
+(<= (next (control alice))
+ (true (control random)))
+
+(<= (next (coins ?s1 ?s2))
+ (does ?p (choose ?s1 ?s2)))
+
+(<= (next (coin ?s))
+ (does ?p (play ?s)))
+
+(<= (next (coins ?s1 ?s2))
+ (true (coins ?s1 ?s2))
+ (not (true (control random))))
+
+(<= (next (coin ?s))
+ (true (coin ?s))
+ (not (true (control alice))))
+
+(<= (sees alice (coins ?s1))
+ (true (coins ?s1 ?s2)))
+
+(<= (goal alice 100)
+ (true (coins ?s ?s))
+ (true (coin ?s)))
+
+(<= (goal alice 50)
+ (true (coins ?s1 ?s2))
+ (true (coin ?s1))
+ (distinct ?s1 ?s2))
+
+(<= (goal alice 50)
+ (true (coins ?s1 ?s2))
+ (true (coin ?s2))
+ (distinct ?s1 ?s2))
+
+(<= terminal
+ (not (true (coin unset)))
+ (not (true (coins unset unset))))
--- a/src/grounders/fluxplayer.lisp Tue Feb 07 12:29:12 2017 +0000
+++ b/src/grounders/fluxplayer.lisp Mon Feb 13 17:54:31 2017 +0000
@@ -128,13 +128,13 @@
;;;; API ----------------------------------------------------------------------
(defun ground-gdl-string (string)
- (->> (ground-with-fluxplayer string "-")
- parse-raw-grounded
- (apply #'rebuild-rules)))
+ (-<> (ground-with-fluxplayer string "-")
+ (parse-raw-grounded <>)
+ (apply #'rebuild-rules <>)))
(defun ground-gdl-file (filename)
(-<> (ground-with-fluxplayer "" filename)
- parse-raw-grounded
+ (parse-raw-grounded <>)
(apply #'rebuild-rules <>)))
@@ -149,5 +149,4 @@
; (dump-grounded "buttons")
; (dump-grounded "8puzzle")
; (dump-grounded "tictactoe")
-(dump-grounded "roshambo2")
-; (dump-grounded "hanoi")
+(dump-grounded "pennies")
--- a/src/reasoners/zdd.lisp Tue Feb 07 12:29:12 2017 +0000
+++ b/src/reasoners/zdd.lisp Mon Feb 13 17:54:31 2017 +0000
@@ -70,6 +70,16 @@
(make-rule-forest (mapcar #'build-stratum strata-list)))
+;;;; Universes ----------------------------------------------------------------
+(defun make-universe (predicate term->number)
+ (let ((universe (make-array (hash-table-count term->number)
+ :initial-element nil)))
+ (iterate (for (term number) :in-hashtable term->number)
+ (when (funcall predicate term)
+ (setf (aref universe number) t)))
+ universe))
+
+
;;;; Reasoner -----------------------------------------------------------------
(defclass* (zdd-reasoner :conc-name zr-) ()
(rules
@@ -81,7 +91,7 @@
goal-zdd
terminal-zdd
next-zdd
- percept-zdds
+ percept-universes
possible-forest
happens-forest))
@@ -154,12 +164,14 @@
:goal-zdd (make-predicate-zdd '(ggp-rules::goal) term->number)
:terminal-zdd (make-predicate-zdd '(ggp-rules::terminal) term->number)
:next-zdd (make-predicate-zdd '(ggp-rules::next) term->number)
- :percept-zdds (iterate
- (for role :in roles)
- (collect-hash (role . (make-predicate-zdd
- `(ggp-rules::sees ,role)
- term->number))
- :test #'equal))
+ :percept-universes
+ (iterate
+ (for role :in roles)
+ (collect-hash (role (make-universe
+ (lambda (term)
+ (equal (take 2 term)
+ `(ggp-rules::sees ,role)))
+ term->number))))
:term->number term->number
:number->term number->term)))))
@@ -440,24 +452,24 @@
;;;; Scratch ------------------------------------------------------------------
(defparameter *rules*
- (scully.gdl::read-gdl "gdl/tictactoe-grounded.gdl"))
+ (scully.gdl::read-gdl "gdl/pennies-grounded.gdl"))
-(-<> *rules*
- (scully.gdl::normalize-rules <>)
- (scully.terms::integerize-rules <>)
- ; (nth 2 <>)
- ; (make-rule-forest <>)
- ; (scully.terms::print-strata <>)
- ; (no <>)
- ; (rest <>)
- ; (map nil #'print-hash-table <>)
- )
+; (-<> *rules*
+; (scully.gdl::normalize-rules <>)
+; (scully.terms::integerize-rules <>)
+; ; (nth 2 <>)
+; ; (make-rule-forest <>)
+; ; (scully.terms::print-strata <>)
+; ; (no <>)
+; ; (rest <>)
+; ; (map nil #'print-hash-table <>)
+; )
(defparameter *r* (make-zdd-reasoner *rules*))
-(defparameter *i* (initial-iset *r*))
-(defparameter *j* (initial-iset *r*))
+; (defparameter *i* (initial-iset *r*))
+; (defparameter *j* (initial-iset *r*))
; (with-zdd
; (-<> *r*
--- a/src/zdd.lisp Tue Feb 07 12:29:12 2017 +0000
+++ b/src/zdd.lisp Mon Feb 13 17:54:31 2017 +0000
@@ -264,7 +264,7 @@
(zdd-keep-avoiders-of% zdd (sort set #'<)))
-(defun zdd-match% (zdd set lower-bound upper-bound)
+(defun zdd-match% (zdd set universe)
(recursively ((zdd zdd) (set set))
(ematch zdd
;; If Z = ∅, there are no candidates for matching.
@@ -313,11 +313,61 @@
; jeeeeeeeesus
(sink nil))))))))))))
-(defun zdd-match (zdd set lower-bound upper-bound)
+(defun zdd-match% (zdd set universe)
+ (recursively ((zdd zdd) (set set))
+ (ematch zdd
+ ;; If Z = ∅, there are no candidates for matching.
+ ((sink nil) (sink nil))
+
+ ;; If Z = {∅}, the only set ∅ can match is the empty set.
+ ((sink t) (if (null set)
+ (sink t)
+ (sink nil)))
+
+ ;; Otherwise Z is a real node.
+ ((node var hi lo)
+ (if (not (aref universe var))
+ ;; If this node is not in the universe, we don't care about it at all.
+ ;; Recur down both branches.
+ (zdd-node var
+ (recur hi set)
+ (recur lo set))
+
+ ;; Otherwise this node is in the universe. Is it in the set we're
+ ;; looking for?
+ (ematch set
+ ;; If our target is empty, only the lo branch of Z can ever match.
+ (nil (recur lo set))
+
+ ;; Otherwise we've got a target element. Almost there!
+ ((list* element remaining)
+ (cond
+ ;; If we're below the target element, we recur down the lo
+ ;; branch because the hi branch contains something unwanted.
+ ((< var element) (recur lo set))
+ ;; If we're above the target element, we can never match.
+ ((> var element) (sink nil))
+ ;; Otherwise, we recur down the hi branch with the rest of our
+ ;; target (the lo branch is always missing this element).
+ ((= var element) (zdd-node var
+ (recur hi remaining)
+ ; jeeeeeeesus
+ (sink nil)))))))))))
+
+(defun zdd-match (zdd set universe)
"Return a ZDD of members that exactly match `set` within the universe.
{α | α ∈ Z and α ∩ U = S}
+ `universe` should be an array of booleans, one per possible term.
+
"
- (zdd-match% zdd (sort set #'<) lower-bound upper-bound))
+ (zdd-match% zdd (sort set #'<) universe))
+
+;;;; Scratch ------------------------------------------------------------------
+(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))))))