# HG changeset patch # User Steve Losh # Date 1487871825 0 # Node ID 61661613f7b891f2a0f6f521faf0a587a02ca9a8 # Parent ad00448cd5f9656ee9eeb1079e668e98fa86cfcf Tweak negative term representation diff -r ad00448cd5f9 -r 61661613f7b8 gdl/meier.gdl --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gdl/meier.gdl Thu Feb 23 17:43:45 2017 +0000 @@ -0,0 +1,241 @@ +(role random) + +(role p1) +(role p2) + + +(init (rolling_for p1)) +(init (previous_claimed_values 0 0)) +; 00: artificial first value, lower than any other + + + + +; rolling phase + +(<= (legal random (roll ?p ?x ?y)) + (true (rolling_for ?p)) + (number ?x) + (number ?y) +) + +(<= (legal ?p noop) + (role ?p) + (distinct ?p random) + (true (rolling_for ?q)) +) + +(<= (next (has_dice ?p ?x ?y)) + (does random (roll ?p ?x1 ?y1)) + (sort ?x1 ?y1 ?x ?y) +) + +(<= (sort ?x ?y ?x ?y) + (leq ?y ?x) +) + +(<= (sort ?y ?x ?x ?y) + (leq ?y ?x) +) + +(<= (sees ?p (my_dice ?x ?y)) + (does random (roll ?p ?x ?y)) +) + +(<= (next (claiming ?p)) ; transition + (true (rolling_for ?p)) +) + + +; claiming phase (bluff or not) + +(<= (legal ?p (claim ?x ?y)) + (true (claiming ?p)) + (true (previous_claimed_values ?mx ?my)) + (better_values ?mx ?my ?x ?y) +) + +(<= (legal ?q noop) + (role ?q) + (true (claiming ?p)) + (distinct ?q ?p) +) + +(<= (sees ?q (does ?p ?m)) + (role ?q) + (does ?p ?m) + (distinct ?p random) + ; (distinct ?q ?p) + ; (distinct ?q random) +) + +(<= (next (guessing ?q)) + (does ?p (claim ?x ?y)) + (next_player ?p ?q) +) + +(<= (next (previous_claimed_values ?x ?y)) + (does ?p (claim ?x ?y)) +) + + +; guessing phase + +(<= (legal ?p you_bluff) + (true (guessing ?p)) +) + +(<= (legal ?p ask_roll) + (true (guessing ?p)) + (not (true (previous_claimed_values 2 1)) ) +) + +(<= (legal ?q noop) + (role ?q) + (true (guessing ?p)) + (distinct ?q ?p) +) + +(<= (next (rolling_for ?p)) + (does ?p ask_roll) +) + +(<= (next (game_over ?p) ) + (does ?p you_bluff) +) + + +; game over + +(<= terminal + (true (game_over ?p)) +) + +(<= (goal ?q 100) + (true (game_over ?q)) + (next_player ?p ?q) + (true (has_dice ?p ?x ?y)) + (not (true (previous_claimed_values ?x ?y)) ) +) + +(<= (goal ?p 100) + (true (game_over ?q)) + (next_player ?p ?q) + (true (has_dice ?p ?x ?y)) + (true (previous_claimed_values ?x ?y)) +) + +(<= (goal ?q 0) + (true (game_over ?q)) + (next_player ?p ?q) + (true (has_dice ?p ?x ?y)) + (true (previous_claimed_values ?x ?y)) +) + +(<= (goal ?p 0) + (true (game_over ?q)) + (next_player ?p ?q) + (true (has_dice ?p ?x ?y)) + (not (true (previous_claimed_values ?x ?y)) ) +) + +(goal random 100) + + + + +; conservation rule + +(<= (next (previous_claimed_values ?x ?y)) + (true (previous_claimed_values ?x ?y)) + (not claims_any) +) + +(<= claims_any + (does ?p (claim ?x ?y)) +) + +(<= (next (has_dice ?p ?x ?y)) + (true (has_dice ?p ?x ?y)) ; stays true until some other dice are rolled + (not any_roll) +) + +(<= any_roll + (role ?p) + (number ?x) + (number ?y) + (does random (roll ?p ?x ?y)) +) + + + + + +(number 1) +(number 2) +(number 3) +(number 4) +(number 5) +(number 6) + +(succ 1 2) +(succ 2 3) +(succ 3 4) +(succ 4 5) +(succ 5 6) + + +(<= (leq ?x ?x) + (number ?x) +) + +(<= (leq ?x ?y) + (succ ?x ?i) + (leq ?i ?y) +) + + + +(succ_values 0 0 3 1) + +(succ_values 3 1 3 2) +(succ_values 3 2 4 1) + +(succ_values 4 1 4 2) +(succ_values 4 2 4 3) +(succ_values 4 3 5 1) + +(succ_values 5 1 5 2) +(succ_values 5 2 5 3) +(succ_values 5 3 5 4) +(succ_values 5 4 6 1) + +(succ_values 6 1 6 2) +(succ_values 6 2 6 3) +(succ_values 6 3 6 4) +(succ_values 6 4 6 5) +(succ_values 6 5 1 1) + +(succ_values 1 1 2 2) +(succ_values 2 2 3 3) +(succ_values 3 3 4 4) +(succ_values 4 4 5 5) +(succ_values 5 5 6 6) +(succ_values 6 6 2 1) + + + +(<= (better_values ?mx ?my ?x ?y) + (succ_values ?mx ?my ?x ?y) +) + +(<= (better_values ?mx ?my ?x ?y) + (succ_values ?mx ?my ?ix ?iy) + (better_values ?ix ?iy ?x ?y) +) + + + +(next_player p1 p2) +(next_player p2 p1) + diff -r ad00448cd5f9 -r 61661613f7b8 gdl/pennies.gdl --- a/gdl/pennies.gdl Fri Feb 17 11:52:25 2017 +0000 +++ b/gdl/pennies.gdl Thu Feb 23 17:43:45 2017 +0000 @@ -10,7 +10,8 @@ (<= (legal random (choose ?s1 ?s2)) (true (control random)) - (side ?s1) (side ?s2)) + (side ?s1) + (side ?s2)) (<= (legal ?p noop) (role ?p) diff -r ad00448cd5f9 -r 61661613f7b8 src/grounders/fluxplayer.lisp --- a/src/grounders/fluxplayer.lisp Fri Feb 17 11:52:25 2017 +0000 +++ b/src/grounders/fluxplayer.lisp Thu Feb 23 17:43:45 2017 +0000 @@ -70,9 +70,9 @@ (id (.whitespace-and (.positive-integer))) (term-count (.whitespace-and (.positive-integer))) (negative-term-count (.whitespace-and (.positive-integer))) - (positive-terms (.repeat (- term-count negative-term-count) + (negative-terms (.repeat negative-term-count (.whitespace-and (.positive-integer)))) - (negative-terms (.repeat negative-term-count + (positive-terms (.repeat (- term-count negative-term-count) (.whitespace-and (.positive-integer)))) (_ (.char= #\newline))) (.identity (make-rule :id id @@ -104,17 +104,22 @@ (setf (gethash (index-entry-id entry) index) (index-entry-term entry))) (flet ((get-rule (id) - (ensure-gethash id index (scully.gdl:gensym-ggp)))) + (ensure-gethash id index (scully.gdl:gensym-ggp))) + (useless-rule-p (has-name pos neg) + (and (not has-name) + (null pos) + (null neg)))) (iterate (for entry :in rule-entries) - (for rule = (get-rule (rule-id entry))) + (for (values rule has-name) = (get-rule (rule-id entry))) (for pos = (mapcar #'get-rule (rule-positive entry))) (for neg = (mapcar #'get-rule (rule-negative entry))) - (collect (if (or pos neg) - `(ggp-rules::<= ,rule - ,@pos - ,@(mapcar (curry #'list 'ggp-rules::not) neg)) - (ensure-list rule))))))) + (unless (useless-rule-p has-name pos neg) + (collect (if (or pos neg) + `(ggp-rules::<= ,rule + ,@pos + ,@(mapcar (curry #'list 'ggp-rules::not) neg)) + (ensure-list rule)))))))) ;;;; Fluxplayer --------------------------------------------------------------- @@ -149,4 +154,7 @@ ; (dump-grounded "buttons") ; (dump-grounded "8puzzle") ; (dump-grounded "tictactoe") + (dump-grounded "pennies") + +;; (dump-grounded "meier") diff -r ad00448cd5f9 -r 61661613f7b8 src/reasoners/zdd.lisp --- a/src/reasoners/zdd.lisp Fri Feb 17 11:52:25 2017 +0000 +++ b/src/reasoners/zdd.lisp Thu Feb 23 17:43:45 2017 +0000 @@ -72,7 +72,7 @@ ;;;; Universes ---------------------------------------------------------------- (defun make-universe (predicate term->number) - (let ((universe (make-array (hash-table-count term->number) + (let ((universe (make-array (1+ (hash-table-count term->number)) :initial-element nil))) (iterate (for (term number) :in-hashtable term->number) (when (funcall predicate term) @@ -240,6 +240,7 @@ (pr percepts) (zdd-match iset percepts universe))) + ;;;; Drawing ------------------------------------------------------------------ (defun label (reasoner n) (let ((*package* (find-package :ggp-rules))) @@ -462,8 +463,8 @@ ;;;; Scratch ------------------------------------------------------------------ -(defparameter *rules* - (scully.gdl::read-gdl "gdl/pennies-grounded.gdl")) +(defparameter *rules* (scully.gdl::read-gdl "gdl/meier-grounded.gdl")) +(defparameter *rules* (scully.gdl::read-gdl "gdl/pennies-grounded.gdl")) ; (-<> *rules* ; (scully.gdl::normalize-rules <>) @@ -477,10 +478,11 @@ ; ) +(defparameter *r* nil) (defparameter *r* (make-zdd-reasoner *rules*)) (defparameter *i* (initial-iset *r*)) -(defun test () +(defun test ( (with-zdd (-<> (initial-iset *r*) @@ -489,16 +491,16 @@ (does alice noop)))) (apply-rule-forest *r* <> (zr-happens-forest *r*)) (filter-iset-for-percepts - *r* <> 'ggp-rules::alice - '((ggp-rules::sees ggp-rules::alice (ggp-rules::coins ggp-rules::unset)) - (ggp-rules::sees ggp-rules::alice (ggp-rules::coins ggp-rules::heads)))) - (pr <>) - (dump-iset *r* <>) + *r* <> + 'ggp-rules::alice + '((ggp-rules::sees ggp-rules::alice (ggp-rules::coins ggp-rules::unset)))) + ;; (pr <>) + ;; (dump-iset *r* <>) ;; (dump-iset *r* <>) ;; (zdd-meet <> (zr-next-zdd *r*)) ;; (dump-iset *r* <>) ;; (convert-next-to-true *r* <>) - ;; (dump-iset *r* <>) + (dump-iset *r* <>) (no <>) ; (draw-zdd *r* <>) - ))) + )))) diff -r ad00448cd5f9 -r 61661613f7b8 src/rule-trees.lisp --- a/src/rule-trees.lisp Fri Feb 17 11:52:25 2017 +0000 +++ b/src/rule-trees.lisp Thu Feb 23 17:43:45 2017 +0000 @@ -2,6 +2,10 @@ (in-readtable :fare-quasiquote) ;;;; Rule Trees --------------------------------------------------------------- +(defun abs< (x y) + (declare (type fixnum x y)) + (< (abs x) (abs y))) + (adt:defdata rule-tree (node t rule-tree rule-tree) (top t) @@ -24,7 +28,9 @@ Each body in `bodies` must already be sorted. No body should be empty. " - (first (extremum bodies #'term< :key #'first))) + (iterate (for body :in bodies) + (for term = (the fixnum (first body))) + (minimizing (abs term)))) (defun partition (bodies) "Partition `bodies` into exclusive groups based on the smallest element. @@ -39,20 +45,16 @@ 4. All bodies that DON'T CARE about that element. " - (let* ((element (bare-term (find-smallest-body-term bodies))) - (negation `(ggp-rules::not ,element))) - (labels - ((disallows (body) - (equal (first body) negation)) - (requires (body) - (equal (first body) element)) - (ignores (body) - (not (or (requires body) - (disallows body))))) - (values element - (remove-if-not #'disallows bodies) - (remove-if-not #'requires bodies) - (remove-if-not #'ignores bodies))))) + (iterate + (with element = (the fixnum (find-smallest-body-term bodies))) + (with negation = (the fixnum (- element))) + (for body :in bodies) + (for term = (the fixnum (first body))) + (cond + ((= term element) (collect body :into requires)) + ((= term negation) (collect body :into disallows)) + (t (collect body :into ignores))) + (finally (return (values element disallows requires ignores))))) (defun make-node (cache term hi lo) diff -r ad00448cd5f9 -r 61661613f7b8 src/terms.lisp --- a/src/terms.lisp Fri Feb 17 11:52:25 2017 +0000 +++ b/src/terms.lisp Thu Feb 23 17:43:45 2017 +0000 @@ -280,7 +280,7 @@ (defun integerize-term (term->number term) (match term (`(ggp-rules::not ,body) - `(ggp-rules::not ,(gethash body term->number))) + (- (gethash body term->number))) (_ (gethash term term->number)))) (defun integerize-rule (term->number rule) @@ -308,7 +308,7 @@ (multiple-value-bind (terms possible happens) (order-terms rules) ;; Generate the mapping tables - (iterate (for i :from 0) + (iterate (for i :from 1) (for term :in terms) (setf (gethash i number->term) term (gethash term term->number) i))