# HG changeset patch # User Steve Losh # Date 1487008471 0 # Node ID c3a62419fa6f9d3192e4e3c5b5a38dfba2521980 # Parent f135daf29471bed992a1361c34a1a3e9b7aa44f4 Fix universe matching diff -r f135daf29471 -r c3a62419fa6f gdl/pennies.gdl --- /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)))) diff -r f135daf29471 -r c3a62419fa6f src/grounders/fluxplayer.lisp --- 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") diff -r f135daf29471 -r c3a62419fa6f src/reasoners/zdd.lisp --- 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* diff -r f135daf29471 -r c3a62419fa6f src/zdd.lisp --- 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))))))