--- /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)
+
--- 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)
--- 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")
--- 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* <>)
- )))
+ ))))
--- 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)
--- 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))