61661613f7b8

Tweak negative term representation
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Thu, 23 Feb 2017 17:43:45 +0000
parents ad00448cd5f9
children b9b27db857cf
branches/tags (none)
files gdl/meier.gdl gdl/pennies.gdl src/grounders/fluxplayer.lisp src/reasoners/zdd.lisp src/rule-trees.lisp src/terms.lisp

Changes

--- /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))