--- a/package.lisp Wed Dec 07 17:52:35 2016 -0500
+++ b/package.lisp Sun Dec 11 16:25:09 2016 -0500
@@ -44,7 +44,9 @@
:trivia
:trivialib.bdd
:scully.quickutils)
- (:export))
+ (:export)
+ (:shadowing-import-from :hamt
+ :hash-set))
(defpackage :scully.rule-trees
(:use
@@ -77,6 +79,7 @@
:cl
:losh
:iterate
+ :trivia
:cl-arrows
:scully.quickutils))
--- a/src/logic.lisp Wed Dec 07 17:52:35 2016 -0500
+++ b/src/logic.lisp Sun Dec 11 16:25:09 2016 -0500
@@ -1,6 +1,5 @@
(in-package :scully.logic)
-
(defparameter *rules*
(scully.gdl::read-gdl "gdl/tictactoe-grounded.gdl")
; (scully.gdl::read-gdl "gdl/hanoi-grounded.gdl")
@@ -9,14 +8,69 @@
)
+(defun slot-definition (conc-name slot)
+ (destructuring-bind (name &key
+ type
+ documentation
+ (accessor (symb conc-name name))
+ (initarg (intern (symbol-name name) :keyword)))
+ (ensure-list slot)
+ `(,name :initarg ,initarg :accessor ,accessor
+ ,@(when type `(:type ,type))
+ ,@(when documentation `(:documentation ,documentation)))))
+
+(defmacro defclass* (name-and-options direct-superclasses slots &rest options)
+ (destructuring-bind (name &key (conc-name (symb name '-)))
+ (ensure-list name-and-options)
+ `(defclass ,name ,direct-superclasses
+ ,(mapcar (curry #'slot-definition conc-name) slots)
+ ,@options)))
+
+(defclass* (logic-manager :conc-name lm-) ()
+ (rules
+ roles
+ term->number
+ number->term
+ initial-zdd
+ legal-zdd
+ goal-zdd
+ terminal-zdd
+ possible-forest
+ happens-forest))
+
+
+(defun find-initial-state (rules term->number)
+ (-<> rules
+ (mapcan (lambda-match
+ ((list (list* 'ggp-rules::init body))
+ `((ggp-rules::true ,@body))))
+ <>)
+ (mapcar (lambda (term) (gethash term term->number)) <>)))
+
+(defun find-roles (rules)
+ (mapcan (lambda-match
+ ((list (list 'ggp-rules::role r))
+ (list r)))
+ rules))
+
+(defun make-predicate-zdd (predicate term->number)
+ (-<> term->number
+ hash-table-alist
+ (remove-if-not (lambda (rule)
+ (eql predicate (first (first rule))))
+ <>)
+ (mapcar #'cdr <>)
+ (scully.zdd::zdd-set <>)))
+
(defun make-stratum-rule-trees (stratum)
(-<> stratum
(group-by #'car <>)
hash-table-values
(mapcar #'scully.rule-trees::make-rule-tree <>)))
-(defun make-rule-forests (rules)
- "Turn a set of grounded GDL rules into rule forests and mapping tables.
+
+(defun make-logic-manager (rules)
+ "Turn a set of grounded GDL rules into a logic manager.
A rule forest is a collection of individual rule trees in a single layer,
stratified as necessary:
@@ -29,29 +83,61 @@
\/
(rule-tree-1 rule-tree-2 ...)
- Returns a list of:
+ "
+ (let ((rules (scully.gdl::normalize-rules rules)))
+ (destructuring-bind (term->number number->term rule-layers)
+ (scully.terms::integerize-rules rules)
+ (flet ((make-forest (layer)
+ (-<> rule-layers
+ (gethash layer <>)
+ scully.terms::stratify-layer
+ (mapcar #'make-stratum-rule-trees <>))))
+ (scully.zdd::with-zdd
+ (make-instance 'logic-manager
+ :rules rules
+ :roles (find-roles rules)
+ :possible-forest (make-forest :possible)
+ :happens-forest (make-forest :happens)
+ :initial-zdd (scully.zdd::zdd-set (find-initial-state rules term->number))
+ :legal-zdd (make-predicate-zdd 'ggp-rules::legal term->number)
+ :goal-zdd (make-predicate-zdd 'ggp-rules::goal term->number)
+ :terminal-zdd (make-predicate-zdd 'ggp-rules::terminal term->number)
+ :term->number term->number
+ :number->term number->term))))))
- * The :possible layer's rule forest.
- * The :happens layer's rule forest.
- * The term->number hash table.
- * The number->term hash table.
+
+(defun initial-iset (logic-manager)
+ "Return the initial information set of the game."
+ (lm-initial-zdd logic-manager))
- "
- (destructuring-bind (term->number number->term rule-layers)
- (-> rules
- scully.gdl::normalize-rules
- scully.terms::integerize-rules)
- (flet ((make-forest (layer)
- (-<> rule-layers
- (gethash layer <>)
- scully.terms::stratify-layer
- (mapcar #'make-stratum-rule-trees <>))))
- (list (make-forest :possible)
- (make-forest :happens)
- term->number
- number->term))))
+(defun number-to-term (logic-manager number)
+ (gethash number (lm-number->term logic-manager)))
+
+(defun term-to-number (logic-manager term)
+ (gethash term (lm-term->number logic-manager)))
+
+(defun rand-state (logic-manager iset)
+ "Select a random member of the given information set."
+ (mapcar (curry #'number-to-term logic-manager)
+ (scully.zdd::zdd-random-member iset)))
-; (make-rule-forest *rules*)
+(defun terminalp (logic-manager iset)
+ "Return whether the given information set is a terminal state."
+ (-<> iset
+ (scully.zdd::zdd-meet <> (lm-terminal-zdd logic-manager))
+ scully.zdd::zdd-unit-p
+ not))
+
+(defun draw-zdd (logic-manager zdd)
+ (flet ((label (n)
+ (let ((*package* (find-package :ggp-rules)))
+ (-<> n
+ (number-to-term logic-manager <>)
+ (structural-string <>)))))
+ (scully.graphviz::draw-zdd zdd :label-fn #'label)))
+
+
+(defparameter *l* (make-logic-manager *rules*))
; (defun apply-rule-tree (zdd rule-tree head-bound)
--- a/src/zdd.lisp Wed Dec 07 17:52:35 2016 -0500
+++ b/src/zdd.lisp Sun Dec 11 16:25:09 2016 -0500
@@ -37,6 +37,18 @@
(enumerate lo)))))
+(defun zdd-empty-p (zdd)
+ (ematch zdd
+ ((sink nil) t)
+ ((sink t) nil)
+ ((node _ _ _) nil)))
+
+(defun zdd-unit-p (zdd)
+ (ematch zdd
+ ((sink nil) nil)
+ ((sink t) t)
+ ((node _ _ _) nil)))
+
(defun zdd-count (zdd)
"Return the number of members of `zdd`."
(ematch zdd
@@ -93,45 +105,44 @@
(make-set elements))
-(defun zdd-union% (a b)
- (ematch* (a b)
- (((node) (sink)) (zdd-union% b a))
+(defun-ematch* zdd-union% (a b)
+ (((node) (sink)) (zdd-union% b a))
- (((sink nil) b) b)
- (((sink t) b) (unit-patch b))
+ (((sink nil) b) b)
+ (((sink t) b) (unit-patch b))
- (((node var-a hi-a lo-a)
- (node var-b hi-b lo-b))
- (cond
- ((< var-a var-b) (zdd-node var-a hi-a (zdd-union% lo-a b)))
- ((> var-a var-b) (zdd-node var-b hi-b (zdd-union% lo-b a)))
- ((= var-a var-b) (zdd-node var-a
- (zdd-union% hi-a hi-b)
- (zdd-union% lo-a lo-b)))))))
+ (((node var-a hi-a lo-a)
+ (node var-b hi-b lo-b))
+ (cond
+ ((< var-a var-b) (zdd-node var-a hi-a (zdd-union% lo-a b)))
+ ((> var-a var-b) (zdd-node var-b hi-b (zdd-union% lo-b a)))
+ ((= var-a var-b) (zdd-node var-a
+ (zdd-union% hi-a hi-b)
+ (zdd-union% lo-a lo-b))))))
(defun zdd-union (&rest zdds)
"Return the union of ZDDs: {α | α ∈ Z₁ or α ∈ Z₂}."
(if zdds
(reduce #'zdd-union% zdds)
(sink nil)))
-(defun zdd-intersection% (a b)
- (ematch* (a b)
- (((node) (sink)) (zdd-intersection% b a))
- (((sink nil) _) (sink nil))
- ((_ (sink nil)) (sink nil))
+(defun-ematch* zdd-intersection% (a b)
+ (((node) (sink)) (zdd-intersection% b a))
+
+ (((sink nil) _) (sink nil))
+ ((_ (sink nil)) (sink nil))
- (((sink t) (sink _)) b)
- (((sink t) (node _ _ lo)) (zdd-intersection% a lo))
+ (((sink t) (sink _)) b)
+ (((sink t) (node _ _ lo)) (zdd-intersection% a lo))
- (((node var-a hi-a lo-a)
- (node var-b hi-b lo-b))
- (cond
- ((< var-a var-b) (zdd-intersection% lo-a b))
- ((> var-a var-b) (zdd-intersection% lo-b a))
- ((= var-a var-b) (zdd-node var-a
- (zdd-intersection% hi-a hi-b)
- (zdd-intersection% lo-a lo-b)))))))
+ (((node var-a hi-a lo-a)
+ (node var-b hi-b lo-b))
+ (cond
+ ((< var-a var-b) (zdd-intersection% lo-a b))
+ ((> var-a var-b) (zdd-intersection% lo-b a))
+ ((= var-a var-b) (zdd-node var-a
+ (zdd-intersection% hi-a hi-b)
+ (zdd-intersection% lo-a lo-b))))))
(defun zdd-intersection (&rest zdds)
"Return the intersection of ZDDs: {α | α ∈ Z₁ and α ∈ Z₂}."
@@ -139,28 +150,28 @@
(reduce #'zdd-intersection% zdds)
(sink nil)))
-(defun zdd-join% (a b)
- (ematch* (a b)
- (((sink nil) _) (sink nil))
- ((_ (sink nil)) (sink nil))
- (((sink t) b) b)
- ((a (sink t)) a)
+(defun-ematch* zdd-join% (a b)
+ (((sink nil) _) (sink nil))
+ ((_ (sink nil)) (sink nil))
+
+ (((sink t) b) b)
+ ((a (sink t)) a)
- (((node var-a hi-a lo-a)
- (node var-b hi-b lo-b))
- (cond
- ((< var-a var-b) (zdd-node var-a
- (zdd-join% hi-a b)
- (zdd-join% lo-a b)))
- ((> var-a var-b) (zdd-node var-b
- (zdd-join% hi-b a)
- (zdd-join% lo-b a)))
- ((= var-a var-b) (zdd-node var-a
- (zdd-union (zdd-join% hi-a lo-b)
- (zdd-join% lo-a hi-b)
- (zdd-join% hi-a hi-b))
- (zdd-join% lo-a lo-b)))))))
+ (((node var-a hi-a lo-a)
+ (node var-b hi-b lo-b))
+ (cond
+ ((< var-a var-b) (zdd-node var-a
+ (zdd-join% hi-a b)
+ (zdd-join% lo-a b)))
+ ((> var-a var-b) (zdd-node var-b
+ (zdd-join% hi-b a)
+ (zdd-join% lo-b a)))
+ ((= var-a var-b) (zdd-node var-a
+ (zdd-union (zdd-join% hi-a lo-b)
+ (zdd-join% lo-a hi-b)
+ (zdd-join% hi-a hi-b))
+ (zdd-join% lo-a lo-b))))))
(defun zdd-join (&rest zdds)
"Return the relational join of ZDDs: {α ∪ β | α ∈ Z₁ and β ∈ Z₂}."
@@ -168,26 +179,26 @@
(reduce #'zdd-join% zdds)
(sink nil)))
-(defun zdd-meet% (a b)
- (ematch* (a b)
- (((sink nil) _) (sink nil))
- ((_ (sink nil)) (sink nil))
- (((sink t) _) (sink t))
- ((_ (sink t)) (sink t))
+(defun-ematch* zdd-meet% (a b)
+ (((sink nil) _) (sink nil))
+ ((_ (sink nil)) (sink nil))
+
+ (((sink t) _) (sink t))
+ ((_ (sink t)) (sink t))
- (((node var-a hi-a lo-a)
- (node var-b hi-b lo-b))
- (cond
- ((< var-a var-b) (zdd-union (zdd-meet% hi-a b)
- (zdd-meet% lo-a b)))
- ((> var-a var-b) (zdd-union (zdd-meet% hi-b a)
- (zdd-meet% lo-b a)))
- ((= var-a var-b) (zdd-node var-a
- (zdd-meet% hi-a hi-b)
- (zdd-union (zdd-meet% hi-a lo-b)
- (zdd-meet% lo-a hi-b)
- (zdd-meet% lo-a lo-b))))))))
+ (((node var-a hi-a lo-a)
+ (node var-b hi-b lo-b))
+ (cond
+ ((< var-a var-b) (zdd-union (zdd-meet% hi-a b)
+ (zdd-meet% lo-a b)))
+ ((> var-a var-b) (zdd-union (zdd-meet% hi-b a)
+ (zdd-meet% lo-b a)))
+ ((= var-a var-b) (zdd-node var-a
+ (zdd-meet% hi-a hi-b)
+ (zdd-union (zdd-meet% hi-a lo-b)
+ (zdd-meet% lo-a hi-b)
+ (zdd-meet% lo-a lo-b)))))))
(defun zdd-meet (&rest zdds)
"Return the relational meet of ZDDs: {α ∩ β | α ∈ Z₁ and β ∈ Z₂}."
@@ -201,55 +212,52 @@
(reduce #'zdd-union (mapcar #'zdd-set sets)))
-(defun zdd-keep-supersets-of% (zdd set)
- (ematch* (zdd set)
- ((_ nil) zdd)
- (((sink) _) (sink nil))
- (((node var hi lo) (list* el remaining))
- (cond
- ((= var el) (zdd-node var
- (zdd-keep-supersets-of% hi remaining)
- (sink nil)))
- ((< var el) (zdd-node var
- (zdd-keep-supersets-of% hi set)
- (zdd-keep-supersets-of% lo set)))
- ((> var el) (sink nil))))))
+(defun-ematch* zdd-keep-supersets-of% (zdd set)
+ ((_ nil) zdd)
+ (((sink) _) (sink nil))
+ (((node var hi lo) (list* el remaining))
+ (cond
+ ((= var el) (zdd-node var
+ (zdd-keep-supersets-of% hi remaining)
+ (sink nil)))
+ ((< var el) (zdd-node var
+ (zdd-keep-supersets-of% hi set)
+ (zdd-keep-supersets-of% lo set)))
+ ((> var el) (sink nil)))))
(defun zdd-keep-supersets-of (zdd set)
"Return a ZDD of all supersets of `set` in `zdd`: {α | α ∈ Z and α ⊇ S}."
(zdd-keep-supersets-of% zdd (sort set #'<)))
-(defun zdd-remove-supersets-of% (zdd set)
- (ematch* (zdd set)
- ((_ nil) (sink nil))
- (((sink) _) zdd)
- (((node var hi lo) (list* el remaining))
- (cond
- ((= var el) (zdd-node var
- (zdd-remove-supersets-of% hi remaining)
- lo))
- ((< var el) (zdd-node var
- (zdd-remove-supersets-of% hi set)
- (zdd-remove-supersets-of% lo set)))
- ((> var el) zdd)))))
+(defun-ematch* zdd-remove-supersets-of% (zdd set)
+ ((_ nil) (sink nil))
+ (((sink) _) zdd)
+ (((node var hi lo) (list* el remaining))
+ (cond
+ ((= var el) (zdd-node var
+ (zdd-remove-supersets-of% hi remaining)
+ lo))
+ ((< var el) (zdd-node var
+ (zdd-remove-supersets-of% hi set)
+ (zdd-remove-supersets-of% lo set)))
+ ((> var el) zdd))))
(defun zdd-remove-supersets-of (zdd set)
"Return a ZDD of all non-supersets of `set` in `zdd`: {α | α ∈ Z and α ⊉ S}."
(zdd-remove-supersets-of% zdd (sort set #'<)))
-(defun zdd-keep-avoiders-of% (zdd set)
- (ematch* (zdd set)
- ((_ nil) zdd)
- (((sink) _) zdd)
- (((node var hi lo) (list* el remaining))
- (cond
- ((= var el) (zdd-keep-avoiders-of% lo remaining))
- ((< var el) (zdd-node var
- (zdd-keep-avoiders-of% hi set)
- (zdd-keep-avoiders-of% lo set)))
- ((> var el) (zdd-keep-avoiders-of% zdd remaining))))))
+(defun-ematch* zdd-keep-avoiders-of% (zdd set)
+ ((_ nil) zdd)
+ (((sink) _) zdd)
+ (((node var hi lo) (list* el remaining))
+ (cond
+ ((= var el) (zdd-keep-avoiders-of% lo remaining))
+ ((< var el) (zdd-node var
+ (zdd-keep-avoiders-of% hi set)
+ (zdd-keep-avoiders-of% lo set)))
+ ((> var el) (zdd-keep-avoiders-of% zdd remaining)))))
(defun zdd-keep-avoiders-of (zdd set)
"Return a ZDD of members of `zdd` avoiding `set`: {α | α ∈ Z and α ∩ S = ø}."
--- a/vendor/make-quickutils.lisp Wed Dec 07 17:52:35 2016 -0500
+++ b/vendor/make-quickutils.lisp Sun Dec 11 16:25:09 2016 -0500
@@ -12,6 +12,7 @@
:ensure-list
:extremum
:flatten-once
+ :hash-table-alist
:hash-table-keys
:hash-table-values
:map-product
--- a/vendor/quickutils.lisp Wed Dec 07 17:52:35 2016 -0500
+++ b/vendor/quickutils.lisp Sun Dec 11 16:25:09 2016 -0500
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :SUBDIVIDE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :SYMB :WITH-GENSYMS :WITH-OUTPUT-TO-FILE :WRITE-STRING-INTO-FILE :YES-NO) :ensure-package T :package "SCULLY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :SUBDIVIDE :SYMB :WITH-GENSYMS :WITH-OUTPUT-TO-FILE :WRITE-STRING-INTO-FILE :YES-NO) :ensure-package T :package "SCULLY.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SCULLY.QUICKUTILS")
@@ -14,13 +14,14 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :COMPOSE :COPY-HASH-TABLE :SUBDIVIDE
- :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH
+ :COMPOSE :COPY-HASH-TABLE :CURRY
+ :ENSURE-BOOLEAN :ENSURE-GETHASH
:ENSURE-LIST :EXTREMUM :FLATTEN-ONCE
- :MAPHASH-KEYS :HASH-TABLE-KEYS
- :MAPHASH-VALUES :HASH-TABLE-VALUES
- :MAPPEND :MAP-PRODUCT :MKSTR
- :ONCE-ONLY :RCURRY :SET-EQUAL :SYMB
+ :HASH-TABLE-ALIST :MAPHASH-KEYS
+ :HASH-TABLE-KEYS :MAPHASH-VALUES
+ :HASH-TABLE-VALUES :MAPPEND
+ :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY
+ :SET-EQUAL :SUBDIVIDE :SYMB
:STRING-DESIGNATOR :WITH-GENSYMS
:WITH-OPEN-FILE* :WITH-OUTPUT-TO-FILE
:WRITE-STRING-INTO-FILE :YES-NO))))
@@ -100,28 +101,6 @@
copy))
- (defun subdivide (sequence chunk-size)
- "Split `sequence` into subsequences of size `chunk-size`."
- (check-type sequence sequence)
- (check-type chunk-size (integer 1))
-
- (etypecase sequence
- ;; Since lists have O(N) access time, we iterate through manually,
- ;; collecting each chunk as we pass through it. Using SUBSEQ would
- ;; be O(N^2).
- (list (loop :while sequence
- :collect
- (loop :repeat chunk-size
- :while sequence
- :collect (pop sequence))))
-
- ;; For other sequences like strings or arrays, we can simply chunk
- ;; by repeated SUBSEQs.
- (sequence (loop :with len := (length sequence)
- :for i :below len :by chunk-size
- :collect (subseq sequence i (min len (+ chunk-size i)))))))
-
-
(defun curry (function &rest arguments)
"Returns a function that applies `arguments` and the arguments
it is called with to `function`."
@@ -217,6 +196,16 @@
:collect x))
+ (defun hash-table-alist (table)
+ "Returns an association list containing the keys and values of hash table
+`table`."
+ (let ((alist nil))
+ (maphash (lambda (k v)
+ (push (cons k v) alist))
+ table)
+ alist))
+
+
(declaim (inline maphash-keys))
(defun maphash-keys (function table)
"Like `maphash`, but calls `function` with each key in the hash table `table`."
@@ -351,6 +340,28 @@
(return nil))))))
+ (defun subdivide (sequence chunk-size)
+ "Split `sequence` into subsequences of size `chunk-size`."
+ (check-type sequence sequence)
+ (check-type chunk-size (integer 1))
+
+ (etypecase sequence
+ ;; Since lists have O(N) access time, we iterate through manually,
+ ;; collecting each chunk as we pass through it. Using SUBSEQ would
+ ;; be O(N^2).
+ (list (loop :while sequence
+ :collect
+ (loop :repeat chunk-size
+ :while sequence
+ :collect (pop sequence))))
+
+ ;; For other sequences like strings or arrays, we can simply chunk
+ ;; by repeated SUBSEQs.
+ (sequence (loop :with len := (length sequence)
+ :for i :below len :by chunk-size
+ :collect (subseq sequence i (min len (+ chunk-size i)))))))
+
+
(defun symb (&rest args)
"Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
@@ -462,10 +473,10 @@
nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compose copy-hash-table subdivide curry ensure-boolean
- ensure-gethash ensure-list extremum flatten-once hash-table-keys
- hash-table-values map-product mkstr once-only rcurry set-equal symb
- with-gensyms with-unique-names with-output-to-file
+ (export '(compose copy-hash-table curry ensure-boolean ensure-gethash
+ ensure-list extremum flatten-once hash-table-alist hash-table-keys
+ hash-table-values map-product mkstr once-only rcurry set-equal
+ subdivide symb with-gensyms with-unique-names with-output-to-file
write-string-into-file yes no)))
;;;; END OF quickutils.lisp ;;;;