# HG changeset patch # User Steve Losh # Date 1479230450 0 # Node ID 312aaa8e3bfe0772ddfdf2fd81cfcfb76a84ba2d # Parent 533ee45e04e0d211770609ef172a55df09f7e677 Wire things up together. diff -r 533ee45e04e0 -r 312aaa8e3bfe src/terms.lisp --- a/src/terms.lisp Tue Nov 15 17:20:45 2016 +0000 +++ b/src/terms.lisp Tue Nov 15 17:20:50 2016 +0000 @@ -26,22 +26,30 @@ ;;;; Utils -------------------------------------------------------------------- (defun-match bare-term (term) - (`(not ,x) x) + (`(ggp-rules::not ,x) x) (x x)) (defun-match negationp (term) - (`(not ,_) t) + (`(ggp-rules::not ,_) t) (_ nil)) (defun-match normalize-term (term) - (`(not ,body) `(not ,(normalize-term body))) + (`(ggp-rules::not ,body) `(ggp-rules::not ,(normalize-term body))) (`(,_) term) (`(,head ,@body) (cons head (mapcar #'normalize-term body))) (sym `(,sym))) -(defun normalize-rule (rule) - (mapcar #'normalize-term (ensure-list rule))) +(defun-match normalize-term (term) + (`(ggp-rules::not ,body) `(ggp-rules::not ,(normalize-term body))) + (`(,constant) constant) + (`(,head ,@body) (cons head (mapcar #'normalize-term body))) + (`,constant constant)) + +(defun-match normalize-rule (rule) + (`(ggp-rules::<= ,head ,@body) `(,(normalize-term head) + ,@(mapcar #'normalize-term body))) + (fact `(,(normalize-term fact)))) (defun normalize-rules (rules) (mapcar #'normalize-rule rules)) @@ -74,16 +82,24 @@ (defun extract-simple (predicates layer layers terms) (iterate (for term :in terms) - (if (member (car term) predicates) + (if (member (car (ensure-list term)) predicates) (mark layers layer term) (collect term)))) (defun extract-base (layers terms) - (extract-simple '(true) :base layers terms)) + (let ((terms (extract-simple '(ggp-rules::true + ggp-rules::role) + :base layers terms))) + (iterate (for term :in terms) + (match term + (`(ggp-rules::init ,contents) + (mark layers :base `(ggp-rules::true ,contents)) + (mark layers :base term)) + (_ (collect term)))))) (defun extract-does (layers terms) - (extract-simple '(does) :does layers terms)) + (extract-simple '(ggp-rules::does) :does layers terms)) (defun extract-possible% (layers dependencies terms) @@ -106,11 +122,19 @@ (defun extract-possible (layers dependencies terms) (-<> terms - (extract-simple '(legal goal terminal) :possible layers <>) + (extract-simple '(ggp-rules::legal + ggp-rules::goal + ggp-rules::terminal) + :possible layers <>) (extract-possible% layers dependencies <>))) -(defun extract-happens (layers terms) +(defun extract-early-happens (layers terms) + (extract-simple '(ggp-rules::sees + ggp-rules::next) + :happens layers terms)) + +(defun extract-final-happens (layers terms) (mapcar (curry #'mark layers :happens) terms) nil) @@ -118,13 +142,15 @@ (defun partition-rules (dependencies rules) (let* ((terms (-<> rules flatten-once - (mapcar #'bare-term <>))) + (mapcar #'bare-term <>) + (remove-duplicates <> :test #'equal))) (layers (make-hash-table :test #'equal))) (-<> terms (extract-base layers <>) (extract-does layers <>) + (extract-early-happens layers <>) ; ugh (extract-possible layers dependencies <>) - (extract-happens layers <>)) + (extract-final-happens layers <>)) layers)) @@ -141,27 +167,63 @@ ;; todo: fix the roots/cycles issue in cl-digraph (digraph:topological-sort layer))) -(defun order-rules (rules) - (let* ((rules (normalize-rules rules)) - (dependencies (build-dependency-graph rules)) +(defun order-predicates (rules) + (let* ((dependencies (build-dependency-graph rules)) (negation-dependencies (build-dependency-graph rules :negations-only t)) (layers (partition-rules dependencies rules))) (let ((base (gethash :base layers)) (does (gethash :does layers)) (possible (sort-layer negation-dependencies (gethash :possible layers))) (happens (sort-layer negation-dependencies (gethash :happens layers)))) - (pr :base base) - (pr :does does) - (pr :possible possible) - (pr :happens happens) - (append base possible does happens)))) + ; (pr :base) + ; (pr base) + ; (terpri) + ; (pr :does) + ; (pr does) + ; (terpri) + ; (pr :possible) + ; (pr possible) + ; (terpri) + ; (pr :happens) + ; (pr happens) + ; (terpri) + (values (append base possible does happens) + layers)))) + + +;;;; API ---------------------------------------------------------------------- +(defun integerize-term (term->number term) + (match term + (`(ggp-rules::not ,body) + `(ggp-rules::not ,(gethash body term->number))) + (_ (gethash term term->number)))) + +(defun integerize-rule (term->number rule) + (mapcar (curry #'integerize-term term->number) rule)) + +(defun integerize-rules (rules) + (let ((rules (normalize-rules rules)) + (term->number (make-hash-table :test #'equal)) + (number->term (make-hash-table)) + (rule-layers (make-hash-table))) + (multiple-value-bind (terms layers) + (order-predicates rules) + (iterate (for i :from 0) + (for term :in terms) + (setf (gethash i number->term) term + (gethash term term->number) i)) + (iterate (for rule :in rules) + (for head = (first rule)) + (for layer = (gethash head layers)) + (push (integerize-rule term->number rule) + (gethash layer rule-layers)))) + (list term->number number->term rule-layers))) ;;;; Scratch ------------------------------------------------------------------ -(order-rules '( - (foo (true something)) - (bar (true (something)) - (does x) - ) - )) +(-<> scully.zdd::*rules* + (integerize-rules <>) + ; (never <>) + ; (map nil #'print-hash-table <>) + ) diff -r 533ee45e04e0 -r 312aaa8e3bfe src/zdd.lisp --- a/src/zdd.lisp Tue Nov 15 17:20:45 2016 +0000 +++ b/src/zdd.lisp Tue Nov 15 17:20:50 2016 +0000 @@ -45,6 +45,7 @@ (defparameter *draw-unique-sinks* nil) (defparameter *draw-unique-nodes* nil) (defparameter *draw-hex-p* #'never) +(defparameter *draw-label-fn* #'identity) (defun attrs (object &rest attributes) (make-instance 'cl-dot:attributed @@ -64,10 +65,10 @@ (defmethod cl-dot:graph-object-node ((graph (eql 'zdd)) (object node)) (make-instance 'cl-dot:node :attributes (ematch object - ((node v) `(:label ,v + ((node v) `(:label ,(funcall *draw-label-fn* v) :shape ,(if (funcall *draw-hex-p* v) :hexagon - :circle)))))) + :rectangle)))))) (defmethod cl-dot:graph-object-node ((graph (eql 'zdd)) (object cons)) (cl-dot:graph-object-node graph (car object))) @@ -98,10 +99,12 @@ (filename "zdd.png") (unique-sinks nil) (unique-nodes t) - (hexp #'never)) + (hexp #'never) + (label-fn #'identity)) (let ((*draw-unique-sinks* unique-sinks) (*draw-unique-nodes* unique-nodes) - (*draw-hex-p* hexp)) + (*draw-hex-p* hexp) + (*draw-label-fn* label-fn)) (cl-dot:dot-graph (cl-dot:generate-graph-from-roots 'zdd (list (wrap-node zdd))) filename @@ -422,7 +425,7 @@ (defun negationp (term) - (and (consp term) (eql 'not (first term)))) + (and (consp term) (eql 'ggp-rules::not (first term)))) (defun bare-term (term) (if (negationp term) @@ -453,7 +456,7 @@ ((rule-requires (rule) (equal (rule-first-body rule) element)) (rule-disallows (rule) - (equal (rule-first-body rule) `(not ,element))) + (equal (rule-first-body rule) `(ggp-rules::not ,element))) (rule-ignores (rule) (not (or (rule-requires rule) (rule-disallows rule))))) @@ -519,7 +522,7 @@ (defun make-rule-tree (rules) "Create a rule tree ZDD from the given logical `rules`. - `rules` should be a list of rules, each of the form: + `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. @@ -533,8 +536,8 @@ (let* ((heads (-<> rules (remove-if-not #'rule-empty-p <>) (mapcar #'rule-head <>) - (remove-duplicates <> :test #'equal) - (union accumulated-heads <> :test #'equal))) ; slow + (remove-duplicates <> :test #'=) + (union accumulated-heads <> :test #'=))) ; slow (next-rules (remove-if (lambda (rule) (member (rule-head rule) heads :test #'equal)) @@ -543,9 +546,18 @@ (zdd-set heads) (multiple-value-bind (term low high both) (partition-rules next-rules) - (zdd-node term - (recur (append (mapcar #'drop-first high) both) heads) - (recur (append (mapcar #'drop-first low) both) heads))))))) + ; (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))))))) (defun apply-rule-tree (zdd rule-tree head-bound) @@ -589,38 +601,18 @@ ;;;; Scratch ------------------------------------------------------------------ -(defun test (l) - (fixed-point #'collapse-positive-heads - (list (set-insert (empty-set) - '(100 1 2) - '(1001 100 200) - '(2000 1 (not 1001)) - '(3000 1 (not 100)) - '(1 10) - '(2 30 1)) - (set-insert (empty-set :test #'eql) - '10 '20 '30)) - :limit l - :test (lambda (old new) - (and (hash-set= (first old) - (first new)) - (hash-set= (second old) - (second new)))))) +(destructuring-bind (term->number number->term layers) + (scully.terms::integerize-rules *rules*) + ; (print-hash-table layers) + (with-zdd + (-<> (gethash :happens layers) + ; (mapprint-through #'pr <>) + (make-rule-tree <>) + ; (draw <> :unique-sinks nil :unique-nodes t + ; :label-fn (lambda (n) + ; (aesthetic-string (gethash n number->term)))) + ; (print-through #'zdd-size <>) + (never <>)))) - -;;;; TODO -;; -;; * Implement head fixed-point thing for rule trees -;; * Positive head fixed-pointing -;; * Negative head fixed-pointing -;; * Fact edge case addition -;; * all (next ...) and (init ...) should have (true ...) equivalents -;; * all (legal ...) should have (does ...) equivalents -;; * Ordering for facts -;; * Base < Does < Possible < Happens -;; true does legal/term/goal sees/next -;; * Poster -;; * Monty Hall -;; * Pictures -;; * Fact sets -;; * ZDDs +(start-profiling '(scully.zdd)) +(stop-profiling)