# HG changeset patch # User Steve Losh # Date 1481491978 18000 # Node ID 51bc78b22d98541ca2b196d13506c3bc357cca46 # Parent 6ff8b64f604165ad9f5651a747d0fae498e9824b Rename the logic manager to just be the reasoner diff -r 6ff8b64f6041 -r 51bc78b22d98 package.lisp --- a/package.lisp Sun Dec 11 16:25:09 2016 -0500 +++ b/package.lisp Sun Dec 11 16:32:58 2016 -0500 @@ -74,15 +74,6 @@ :integerize-rules :stratify-layer)) -(defpackage :scully.logic - (:use - :cl - :losh - :iterate - :trivia - :cl-arrows - :scully.quickutils)) - (defpackage :scully.reasoners.prolog (:use @@ -104,6 +95,16 @@ :roles )) +(defpackage :scully.reasoners.zdd + (:use + :cl + :losh + :iterate + :trivia + :cl-arrows + :scully.quickutils)) + + (defpackage :scully.grounders.prolog (:use :cl @@ -128,6 +129,7 @@ :ground-gdl-file :ground-gdl-string)) + (defpackage :scully.players.random (:use :cl diff -r 6ff8b64f6041 -r 51bc78b22d98 scully.asd --- a/scully.asd Sun Dec 11 16:25:09 2016 -0500 +++ b/scully.asd Sun Dec 11 16:32:58 2016 -0500 @@ -37,9 +37,9 @@ (:file "rule-trees") (:file "zdd") (:file "graphviz") - (:file "logic") (:module "reasoners" :serial t - :components ((:file "prolog"))) + :components ((:file "prolog") + (:file "zdd"))) (:module "grounders" :serial t :components ((:file "prolog") (:file "fluxplayer"))) diff -r 6ff8b64f6041 -r 51bc78b22d98 src/logic.lisp --- a/src/logic.lisp Sun Dec 11 16:25:09 2016 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,192 +0,0 @@ -(in-package :scully.logic) - -(defparameter *rules* - (scully.gdl::read-gdl "gdl/tictactoe-grounded.gdl") - ; (scully.gdl::read-gdl "gdl/hanoi-grounded.gdl") - ; (scully.gdl::read-gdl "gdl/8puzzle-grounded.gdl") - ; (scully.gdl::read-gdl "gdl/roshambo2-grounded.gdl") - ) - - -(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-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: - - POSSIBLE: (STRATUM-1 STRATUM-2 ...) - HAPPENS: (STRATUM-1 STRATUM-2 ...) - || || - || \/ - || (rule-tree-1 rule-tree-2 ...) - \/ - (rule-tree-1 rule-tree-2 ...) - - " - (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)))))) - - -(defun initial-iset (logic-manager) - "Return the initial information set of the game." - (lm-initial-zdd logic-manager)) - -(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))) - -(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) -; "Apply the logical rules in `rule-tree` to the sets in `zdd`. - -; `zdd` is assumed to contain sets of logical axioms. This function will update -; each of these sets to add any rule heads derivable from the axioms in the set. - -; " -; (recursively ((zdd zdd) -; (rule-tree rule-tree)) -; (ematch* (zdd rule-tree) -; ;; If Z = ∅ there are no sets to cons heads onto, bail. -; (((sink nil) _) zdd) - -; ;; If R = ∅ or {∅} we've bottomed out of the rule tree and there are no -; ;; heads to cons, we're done. -; ((_ (sink)) zdd) - -; ;; If we've passed the head boundary on the rule tree side then we're done -; ;; filtering and just need to cons in all the heads. -; ((_ (guard (node var _ _) -; (>= var head-bound))) -; (zdd-join zdd rule-tree)) - -; ;; If Z = {∅} we might have some heads we need to cons later in the rule -; ;; tree, so recur down the lo side of it. -; (((sink t) (node _ _ lo)) -; (recur zdd lo)) - -; ;; Otherwise we need to filter. -; (((node var-z hi-z lo-z) (node var-r hi-r lo-r)) -; (cond -; ((= var-z var-r) (zdd-node var-z -; (recur hi-z hi-r) -; (recur lo-z lo-r))) -; ((< var-z var-r) (zdd-node var-z -; (recur hi-z rule-tree) -; (recur lo-z rule-tree))) -; ((> var-z var-r) (recur zdd lo-r))))))) - - - - -;;;; PLAN -;;; -;;; 1. Receive GDL from server -;;; 2. Ground it -;;; 3. Integerize the ground GDL -;;; 4. Find initial state -;;; 5. Build rule trees for integerized rules -;;; 6. ... diff -r 6ff8b64f6041 -r 51bc78b22d98 src/reasoners/zdd.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/reasoners/zdd.lisp Sun Dec 11 16:32:58 2016 -0500 @@ -0,0 +1,191 @@ +(in-package :scully.reasoners.zdd) + +(defparameter *rules* + (scully.gdl::read-gdl "gdl/tictactoe-grounded.gdl") + ; (scully.gdl::read-gdl "gdl/hanoi-grounded.gdl") + ; (scully.gdl::read-gdl "gdl/8puzzle-grounded.gdl") + ; (scully.gdl::read-gdl "gdl/roshambo2-grounded.gdl") + ) + + +(defmacro defclass* (name-and-options direct-superclasses slots &rest options) + (flet ((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)))))) + (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* (zdd-reasoner :conc-name zr-) () + (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-zdd-reasoner (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: + + POSSIBLE: (STRATUM-1 STRATUM-2 ...) + HAPPENS: (STRATUM-1 STRATUM-2 ...) + || || + || \/ + || (rule-tree-1 rule-tree-2 ...) + \/ + (rule-tree-1 rule-tree-2 ...) + + " + (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 'zdd-reasoner + :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)))))) + + +(defun initial-iset (reasoner) + "Return the initial information set of the game." + (zr-initial-zdd reasoner)) + +(defun number-to-term (reasoner number) + (gethash number (zr-number->term reasoner))) + +(defun term-to-number (reasoner term) + (gethash term (zr-term->number reasoner))) + +(defun rand-state (reasoner iset) + "Select a random member of the given information set." + (mapcar (curry #'number-to-term reasoner) + (scully.zdd::zdd-random-member iset))) + +(defun terminalp (reasoner iset) + "Return whether the given information set is a terminal state." + (-<> iset + (scully.zdd::zdd-meet <> (zr-terminal-zdd reasoner)) + scully.zdd::zdd-unit-p + not)) + +(defun draw-zdd (reasoner zdd) + (flet ((label (n) + (let ((*package* (find-package :ggp-rules))) + (-<> n + (number-to-term reasoner <>) + (structural-string <>))))) + (scully.graphviz::draw-zdd zdd :label-fn #'label))) + + +(defparameter *l* (make-zdd-reasoner *rules*)) + + +; (defun apply-rule-tree (zdd rule-tree head-bound) +; "Apply the logical rules in `rule-tree` to the sets in `zdd`. + +; `zdd` is assumed to contain sets of logical axioms. This function will update +; each of these sets to add any rule heads derivable from the axioms in the set. + +; " +; (recursively ((zdd zdd) +; (rule-tree rule-tree)) +; (ematch* (zdd rule-tree) +; ;; If Z = ∅ there are no sets to cons heads onto, bail. +; (((sink nil) _) zdd) + +; ;; If R = ∅ or {∅} we've bottomed out of the rule tree and there are no +; ;; heads to cons, we're done. +; ((_ (sink)) zdd) + +; ;; If we've passed the head boundary on the rule tree side then we're done +; ;; filtering and just need to cons in all the heads. +; ((_ (guard (node var _ _) +; (>= var head-bound))) +; (zdd-join zdd rule-tree)) + +; ;; If Z = {∅} we might have some heads we need to cons later in the rule +; ;; tree, so recur down the lo side of it. +; (((sink t) (node _ _ lo)) +; (recur zdd lo)) + +; ;; Otherwise we need to filter. +; (((node var-z hi-z lo-z) (node var-r hi-r lo-r)) +; (cond +; ((= var-z var-r) (zdd-node var-z +; (recur hi-z hi-r) +; (recur lo-z lo-r))) +; ((< var-z var-r) (zdd-node var-z +; (recur hi-z rule-tree) +; (recur lo-z rule-tree))) +; ((> var-z var-r) (recur zdd lo-r))))))) + + + + +;;;; PLAN +;;; +;;; 1. Receive GDL from server +;;; 2. Ground it +;;; 3. Integerize the ground GDL +;;; 4. Find initial state +;;; 5. Build rule trees for integerized rules +;;; 6. ...