--- a/scully.asd Thu Feb 23 22:05:09 2017 +0000
+++ b/scully.asd Fri Feb 24 15:48:20 2017 +0000
@@ -40,8 +40,7 @@
:components ((:file "prolog")
(:file "zdd")))
(:module "grounders" :serial t
- :components ((:file "prolog")
- (:file "fluxplayer")))
+ :components ((:file "fluxplayer")))
(:module "players" :serial t
:components ((:file "random")
(:file "random-ii")))))))
--- a/src/gdl.lisp Thu Feb 23 22:05:09 2017 +0000
+++ b/src/gdl.lisp Fri Feb 24 15:48:20 2017 +0000
@@ -79,9 +79,6 @@
(`(ggp-rules::not (,predicate ,@_)) predicate)
(`(,predicate ,@_) predicate))
-(defun term< (a b &optional (predicate #'<))
- (funcall predicate (bare-term a) (bare-term b)))
-
(defun-ematch rule-head (rule)
(`(,head ,@_) head))
--- a/src/grounders/prolog.lisp Thu Feb 23 22:05:09 2017 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,174 +0,0 @@
-(in-package :scully.grounders.prolog)
-
-
-;;;; Utils
-(defun gensyms (n prefix)
- (iterate (repeat n) (collect (gensym prefix))))
-
-
-;;;; Sanitization
-(defun clause-is-p (clause functor-name)
- (and (consp clause)
- (eql (first clause) functor-name)))
-
-(defun clause-is-not-p (clause)
- (clause-is-p clause 'ggp-rules::not))
-
-(defun clause-is-distinct-p (clause)
- (clause-is-p clause 'ggp-rules::distinct))
-
-(defun clause-is-and-p (clause)
- (clause-is-p clause 'ggp-rules::and))
-
-(defun clause-is-or-p (clause)
- (clause-is-p clause 'ggp-rules::or))
-
-
-(defun split-ors (rule)
- (labels ((split (body)
- ;; take the body of a clause and return a list of the bodies that
- ;; result after splitting up any `(or ...)`s inside it.
- (match body
- (nil (list nil))
-
- ((list* (list* 'ggp-rules::or args) remaining)
- (mapcan (lambda (arg)
- (mapcar (curry #'cons arg)
- (split remaining)))
- args))
-
- ((list* other remaining)
- (mapcar (curry #'cons other) (split remaining))))))
- (destructuring-bind (head . body) rule
- (mapcar (curry #'cons head) (split body)))))
-
-(defun strip-ands (rule)
- (labels ((flatten-ands (body)
- (match body
- (nil nil)
- ((list* first-clause remaining)
- (append (if (clause-is-and-p first-clause)
- (flatten-ands (rest first-clause))
- (list first-clause))
- (flatten-ands remaining))))))
- (destructuring-bind (head . body) rule
- (cons head (flatten-ands body)))))
-
-(defun strip-nots (rule)
- (destructuring-bind (head . body) rule
- (cons head (remove-if #'clause-is-not-p body))))
-
-(defun strip-distincts (rule)
- (destructuring-bind (head . body) rule
- (cons head (remove-if #'clause-is-distinct-p body))))
-
-
-(defun sanitize-rule (rule)
- (match rule
- ((list* 'ggp-rules::<= contents)
- (->> contents
- split-ors
- (mapcar #'strip-ands)
- (mapcar #'strip-nots)
- (mapcar #'strip-distincts)
- (mapcar (curry #'cons 'ggp-rules::<=))))
- (fact (list fact))))
-
-(defun sanitize-rules (rules)
- (mapcan #'sanitize-rule rules))
-
-
-;;;; Fluents
-(defun find-initial-state (database)
- (query-map database
- (lambda (result)
- `(ggp-rules::true ,(getf result '?what)))
- (ggp-rules::init ?what)))
-
-(defun find-trues (database)
- (query-map database
- (lambda (result)
- `(ggp-rules::true ,(getf result '?what)))
- (ggp-rules::next ?what)))
-
-(defun find-moves (database)
- (query-map database
- (lambda (result)
- `(ggp-rules::does
- ,(getf result '?role)
- ,(getf result '?move)))
- (ggp-rules::legal ?role ?move)))
-
-(defun push-fluents (database fluents)
- (push-logic-frame-with database
- (map nil (curry #'invoke-fact database) fluents)))
-
-(defun pop-fluents (database)
- (pop-logic-frame database))
-
-(defun find-more-fluents (database fluents)
- (push-fluents database fluents)
- (prog1
- (-> fluents
- (union (find-moves database) :test #'equal)
- (union (find-trues database) :test #'equal))
- (pop-fluents database)))
-
-(defun ground-fluents (rules)
- (let ((database (make-database)))
- (scully.gdl:load-rules database rules)
- (fixed-point (curry #'find-more-fluents database)
- (find-initial-state database)
- :test (rcurry #'set-equal :test #'equal))))
-
-
-;;;; Axioms
-(defun find-functor (rule)
- (ematch rule
- ((list* 'ggp-rules::<= (list* functor arguments) _)
- (cons functor (length arguments)))
-
- ((list* 'ggp-rules::<= bare-functor _)
- (cons bare-functor 0))
-
- ((list* functor arguments)
- (cons functor (length arguments)))))
-
-(defun find-axioms (rules)
- (-<> rules
- (mapcar #'find-functor <>)
- (remove-duplicates <> :test #'equal)))
-
-(defun ground-single-axiom (database functor arity)
- (let ((vars (gensyms arity "?")))
- (remove-duplicates
- (invoke-query-map database
- (lambda (result)
- (if (zerop arity)
- functor
- `(,functor ,@(mapcar (curry #'getf result) vars))))
- `(,functor ,@vars))
- :test #'equal)))
-
-(defun find-all-axioms (database functors)
- (iterate (for (functor . arity) :in functors)
- (unioning (ground-single-axiom database functor arity)
- :test #'equal)))
-
-(defun ground-axioms (rules grounded-fluents)
- (let ((database (make-database)))
- (scully.gdl:load-rules database rules)
- (push-fluents database grounded-fluents)
- (find-all-axioms database (find-axioms rules))))
-
-
-;;;; API
-(defun ground-rules (rules)
- (let* ((rules (sanitize-rules rules))
- (fluents (ground-fluents rules))
- (axioms (ground-axioms rules fluents)))
- fluents
- axioms))
-
-
-; (map nil #'print (ground-rules (scully.gdl:read-gdl "gdl/buttons.gdl")))
--- a/src/old-rule-trees.lisp Thu Feb 23 22:05:09 2017 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,149 +0,0 @@
-;;;; Rule Trees ---------------------------------------------------------------
-(defun rule-head (rule)
- (first rule))
-
-(defun rule-body (rule)
- (rest rule))
-
-(defun rule-first-body (rule)
- (first (rule-body rule)))
-
-(defun rule-empty-p (rule)
- (null (rule-body rule)))
-
-
-(defun negationp (term)
- (and (consp term) (eql 'ggp-rules::not (first term))))
-
-(defun bare-term (term)
- (if (negationp term)
- (second term)
- term))
-
-(defun term< (t1 t2)
- (< (bare-term t1) (bare-term t2)))
-
-
-(defun sort-body (rule)
- (destructuring-bind (head . body) rule
- (list* head (sort body #'term<))))
-
-(defun drop-first (rule)
- (destructuring-bind (head . body) rule
- (list* head (rest body))))
-
-(defun find-smallest-body-term (rules)
- (-<> rules
- (mapcar #'rule-first-body <>)
- (sort <> #'term<)
- (first <>)))
-
-(defun partition-rules (rules)
- (let ((element (bare-term (find-smallest-body-term rules))))
- (labels
- ((rule-requires (rule)
- (equal (rule-first-body rule) element))
- (rule-disallows (rule)
- (equal (rule-first-body rule) `(ggp-rules::not ,element)))
- (rule-ignores (rule)
- (not (or (rule-requires rule)
- (rule-disallows rule)))))
- (values element
- (remove-if-not #'rule-disallows rules)
- (remove-if-not #'rule-requires rules)
- (remove-if-not #'rule-ignores rules)))))
-
-
-(defmethod print-object ((set hash-set) stream)
- (print-unreadable-object (set stream :type t :identity nil)
- (prin1 (set->list set) stream)))
-
-(defun hash-set= (s1 s2)
- (zerop (set-size (set-symmetric-diff s1 s2))))
-
-(defun rule-head-in (set rule)
- (set-lookup set (rule-head rule)))
-
-(defun collapse-positive-heads (rules-and-heads)
- (destructuring-bind (rules heads) rules-and-heads
- (flet ((update-rule (rule)
- (cons (rule-head rule)
- (remove-if (curry #'set-lookup heads)
- (rule-body rule)))))
- (let* ((new-rules (set-map #'update-rule rules))
- (new-heads (-<> new-rules
- (set-filter #'rule-empty-p <>)
- (set-map #'rule-head <>))))
- (list (set-filter (complement (curry #'rule-head-in new-heads))
- new-rules)
- (set-union heads new-heads))))))
-
-(defun find-strictly-negative-rules (rules)
- (set-filter (lambda (rule)
- (every #'negationp (rule-body rule)))
- rules))
-
-(defun collapse-negative-heads (rules-and-heads)
- (destructuring-bind (rules heads) rules-and-heads
- (if (zerop (set-size rules))
- (list rules heads)
- (labels ((negation-satisfied-p (negation)
- (not (set-lookup heads (bare-term negation))))
- (rule-satisfied-p (rule)
- (every #'negation-satisfied-p (rule-body rule)))
- (smallest-head ()
- (-<> (set->list rules)
- (mapcar #'rule-head <>)
- (sort <> #'term<)
- (first <>)))
- (rules-with-head (head)
- (set-filter (lambda (rule) (eql head (rule-head rule)))
- rules)))
- (let* ((next (smallest-head))
- (candidates (rules-with-head next)))
- (list (set-diff rules candidates)
- (if (some #'rule-satisfied-p (set->list candidates))
- (set-insert heads next)
- heads)))))))
-
-
-(defun make-rule-tree (rules)
- "Create a rule tree ZDD from the given logical `rules`.
-
- `rules` should be a list of one layer-worth of rules, each of the form:
- `(head-term &rest body-terms)`
-
- Each head term should be a single variable.
- Each body term should be either a single variable or `(not variable)`.
-
- Rules and bodies do not need to be sorted beforehand.
-
- "
- (recursively ((rules (mapcar #'sort-body rules))
- (accumulated-heads nil))
- (let* ((heads (-<> rules
- (remove-if-not #'rule-empty-p <>)
- (mapcar #'rule-head <>)
- (remove-duplicates <> :test #'=)
- (union accumulated-heads <> :test #'=))) ; slow
- (next-rules (remove-if
- (lambda (rule)
- (member (rule-head rule) heads :test #'equal))
- rules)))
- (if (null next-rules)
- (zdd-set heads)
- (multiple-value-bind (term low high both)
- (partition-rules next-rules)
- ; (pr :rules rules)
- ; (pr :acch accumulated-heads)
- ; (pr :heads heads)
- ; (pr :next-rules next-rules)
- ; (pr :term term)
- ; (pr :low low)
- ; (pr :high high)
- ; (pr :both both)
- ; (break)
- (zdd-node term
- (recur (append (mapcar #'drop-first high) both) heads)
- (recur (append (mapcar #'drop-first low) both) heads)))))))
-
--- a/src/reasoners/zdd.lisp Thu Feb 23 22:05:09 2017 +0000
+++ b/src/reasoners/zdd.lisp Fri Feb 24 15:48:20 2017 +0000
@@ -92,6 +92,7 @@
terminal-zdd
next-zdd
percept-universes
+ does-universes
possible-forest
happens-forest))
@@ -172,6 +173,14 @@
(equal (take 2 term)
`(ggp-rules::sees ,role)))
term->number))))
+ :does-universes
+ (iterate
+ (for role :in roles)
+ (collect-hash (role (make-universe
+ (lambda (term)
+ (equal (take 2 term)
+ `(ggp-rules::does ,role)))
+ term->number))))
:term->number term->number
:number->term number->term)))))
@@ -286,6 +295,11 @@
(percepts (mapcar (curry #'term-to-number reasoner) percepts)))
(zdd-match iset percepts universe)))
+(defun filter-iset-for-move (reasoner iset role move)
+ (let ((universe (gethash role (zr-does-universes reasoner)))
+ (moves (list (term-to-number reasoner `(ggp-rules::does ,role ,move)))))
+ (zdd-match iset moves universe)))
+
;;;; Drawing ------------------------------------------------------------------
(defun label (reasoner n)
@@ -295,13 +309,15 @@
*reasoner*
reasoner)
<>)
- (structural-string <>))))
+ (format nil "~D ~S" n <>))))
(defun draw-zdd (reasoner zdd)
(scully.graphviz::draw-zdd zdd :label-fn (curry #'label reasoner)))
-(defun draw-rule-tree (reasoner rule-tree)
- (scully.graphviz::draw-rule-tree rule-tree :label-fn (curry #'label reasoner)))
+(defun draw-rule-tree (reasoner rule-tree &optional (filename "rule-tree.png"))
+ (scully.graphviz::draw-rule-tree rule-tree
+ :label-fn (curry #'label reasoner)
+ :filename filename))
;;;; Logic Application --------------------------------------------------------
@@ -528,24 +544,42 @@
(defparameter *r* (make-zdd-reasoner *rules*))
(defparameter *i* (initial-iset *r*))
-(defun test ()
- (with-zdd
- (-<>
- (initial-iset *r*)
- (apply-rule-forest *r* <> (zr-possible-forest *r*))
- (sprout *r* <>)
- (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))))
- ;; (pr <>)
- ;; (dump-iset *r* <>)
- ;; (dump-iset *r* <>)
- ;; (zdd-meet <> (zr-next-zdd *r*))
- ;; (dump-iset *r* <>)
- ;; (convert-next-to-true *r* <>)
- (dump-iset *r* <>)
- (no <>)
- ; (draw-zdd *r* <>)
- )))
+;; (defun test ()
+;; (with-zdd
+;; (-<>
+;; (initial-iset *r*)
+
+;; (apply-rule-forest *r* <> (zr-possible-forest *r*))
+;; (sprout *r* <>)
+;; (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))))
+;; (filter-iset-for-move
+;; *r* <>
+;; 'ggp-rules::alice
+;; 'ggp-rules::noop)
+;; (zdd-meet <> (zr-next-zdd *r*))
+;; (convert-next-to-true *r* <>)
+
+;; (apply-rule-forest *r* <> (zr-possible-forest *r*))
+;; (sprout *r* <>)
+;; (apply-rule-forest *r* <> (zr-happens-forest *r*))
+;; (filter-iset-for-move
+;; *r* <>
+;; 'ggp-rules::alice
+;; '(ggp-rules::play ggp-rules::tails))
+;; (filter-iset-for-percepts
+;; *r* <>
+;; 'ggp-rules::alice
+;; '((ggp-rules::sees ggp-rules::alice (ggp-rules::coins ggp-rules::heads))))
+;; (zdd-meet <> (zr-next-zdd *r*))
+;; (convert-next-to-true *r* <>)
+
+;; (apply-rule-forest *r* <> (zr-possible-forest *r*))
+
+;; (dump-iset *r* <>)
+;; (no <>)
+;; ; (draw-zdd *r* <>)
+;; )))
--- a/src/rule-trees.lisp Thu Feb 23 22:05:09 2017 +0000
+++ b/src/rule-trees.lisp Fri Feb 24 15:48:20 2017 +0000
@@ -64,7 +64,7 @@
(node term hi lo))))
(defun sort-body (body)
- (sort body #'term<))
+ (sort body #'abs<))
(defun make-rule-tree (rules)
"Make a rule tree for `rules`.