# HG changeset patch # User Steve Losh # Date 1487951300 0 # Node ID a11739a2b4ef2b6bd890fc0a5f249e42a0243365 # Parent 5c19b4bd320088dfaaf36039600898d02c3eecac Fix abs bug diff -r 5c19b4bd3200 -r a11739a2b4ef scully.asd --- 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"))))))) diff -r 5c19b4bd3200 -r a11739a2b4ef src/gdl.lisp --- 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)) diff -r 5c19b4bd3200 -r a11739a2b4ef src/grounders/prolog.lisp --- 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"))) diff -r 5c19b4bd3200 -r a11739a2b4ef src/old-rule-trees.lisp --- 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))))))) - diff -r 5c19b4bd3200 -r a11739a2b4ef src/reasoners/zdd.lisp --- 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* <>) +;; ))) diff -r 5c19b4bd3200 -r a11739a2b4ef src/rule-trees.lisp --- 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`.