# HG changeset patch # User Steve Losh # Date 1481491509 18000 # Node ID 6ff8b64f604165ad9f5651a747d0fae498e9824b # Parent 8a22df7c2b9dce3db98bffee17259e100cb4a043 Start sketching out the actual reasoning logic diff -r 8a22df7c2b9d -r 6ff8b64f6041 package.lisp --- 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)) diff -r 8a22df7c2b9d -r 6ff8b64f6041 src/logic.lisp --- 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) diff -r 8a22df7c2b9d -r 6ff8b64f6041 src/zdd.lisp --- 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 = ø}." diff -r 8a22df7c2b9d -r 6ff8b64f6041 vendor/make-quickutils.lisp --- 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 diff -r 8a22df7c2b9d -r 6ff8b64f6041 vendor/quickutils.lisp --- 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 ;;;;