--- 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 <>)
+ )
--- 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)