# HG changeset patch # User Steve Losh # Date 1479488342 0 # Node ID fcc52d00b79fe5593dbd4847005078947e0116d0 # Parent 312aaa8e3bfe0772ddfdf2fd81cfcfb76a84ba2d Start the individual rule trees diff -r 312aaa8e3bfe -r fcc52d00b79f package.lisp --- a/package.lisp Tue Nov 15 17:20:50 2016 +0000 +++ b/package.lisp Fri Nov 18 16:59:02 2016 +0000 @@ -34,6 +34,17 @@ :scully.quickutils) (:export)) +(defpackage :scully.rule-trees + (:use + :cl + :losh + :iterate + :cl-arrows + :trivia + :named-readtables + :scully.quickutils) + (:export)) + (defpackage :scully.terms (:use :cl diff -r 312aaa8e3bfe -r fcc52d00b79f scully.asd --- a/scully.asd Tue Nov 15 17:20:50 2016 +0000 +++ b/scully.asd Fri Nov 18 16:59:02 2016 +0000 @@ -34,6 +34,7 @@ (:module "src" :serial t :components ((:file "gdl") (:file "terms") + (:file "rule-trees") (:file "zdd") (:module "reasoners" :serial t :components ((:file "prolog"))) diff -r 312aaa8e3bfe -r fcc52d00b79f src/rule-trees.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/rule-trees.lisp Fri Nov 18 16:59:02 2016 +0000 @@ -0,0 +1,117 @@ +(in-package :scully.rule-trees) +(in-readtable :fare-quasiquote) + +;;;; Rule Trees --------------------------------------------------------------- +(adt:defdata rule-tree + (node t rule-tree rule-tree) + (top t) + bottom) + + +(defun rule-head (rule) + (first rule)) + +(defun rule-body (rule) + (rest rule)) + +(defun-match bare-term (term) + (`(ggp-rules::not ,contents) contents) + (_ term)) + +(defun term< (a b) + (< (bare-term a) (bare-term b))) + + +(defun find-smallest-body-term (bodies) + (-<> bodies + (mapcar #'first <>) + (sort <> #'term<) + (first <>))) + +(defun partition (bodies) + (let ((element (bare-term (find-smallest-body-term bodies)))) + (labels + ((requires (body) + (equal (first body) element)) + (disallows (body) + (equal (first body) `(ggp-rules::not ,element))) + (ignores (body) + (not (or (requires body) + (disallows body))))) + (values element + (remove-if-not #'disallows bodies) + (remove-if-not #'requires bodies) + (remove-if-not #'ignores bodies))))) + + +(defun make-node (cache term hi lo) + (if (eql hi lo) + hi + (ensure-gethash (list term hi lo) cache + (node term hi lo)))) + +(defun make-rule-tree (rules) + (let* ((head (rule-head (first rules))) + (top (top head)) + (cache (make-hash-table :test #'equal))) + (recursively ((bodies (-<> rules + (mapcar #'rule-body <>) + (mapcar (rcurry #'sort #'term<) <>)))) + (cond + ((null bodies) bottom) + ((some #'null bodies) top) + (t (multiple-value-bind (term disallows requires ignores) + (partition bodies) + (make-node cache + term + (recur (append (mapcar #'rest requires) ignores)) + (recur (append (mapcar #'rest disallows) ignores))))))))) + + +;;;; GraphViz ----------------------------------------------------------------- +(setf cl-dot:*dot-path* "/usr/local/bin/dot") + +(defun attrs (object &rest attributes) + (make-instance 'cl-dot:attributed + :object object + :attributes attributes)) + + +(defmethod cl-dot:graph-object-node ((graph (eql 'rule-tree)) (object rule-tree)) + (make-instance 'cl-dot:node + :attributes (adt:match rule-tree object + ((node term _ _) `(:label ,(aesthetic-string term) + :shape :circle)) + + (bottom `(:label "⊥" + :shape :square)) + + ((top term) `(:label ,(aesthetic-string term) + :shape :rectangle))))) + +(defmethod cl-dot:graph-object-points-to ((graph (eql 'rule-tree)) + (object rule-tree)) + (adt:match rule-tree object + ((node _ hi lo) (list (attrs hi :style :solid) + (attrs lo :style :dashed))) + ((top _) nil) + (bottom nil))) + + +(defun draw (rule-tree &key (filename "rule-tree.png")) + (cl-dot:dot-graph + (cl-dot:generate-graph-from-roots 'rule-tree (list rule-tree)) + filename + :format :png) + rule-tree) + + +;;;; Scratch ------------------------------------------------------------------ +(defparameter *rule* '( + (1000 1 2 (ggp-rules::not 3)) + (1000 4 2 3 15) + (1000 (ggp-rules::not 19) 18) + (1000 19 17) + )) + +(-<> *rule* make-rule-tree draw) diff -r 312aaa8e3bfe -r fcc52d00b79f src/terms.lisp --- a/src/terms.lisp Tue Nov 15 17:20:50 2016 +0000 +++ b/src/terms.lisp Fri Nov 18 16:59:02 2016 +0000 @@ -222,7 +222,7 @@ ;;;; Scratch ------------------------------------------------------------------ -(-<> scully.zdd::*rules* +#+no (-<> scully.zdd::*rules* (integerize-rules <>) ; (never <>) ; (map nil #'print-hash-table <>) diff -r 312aaa8e3bfe -r fcc52d00b79f src/zdd.lisp --- a/src/zdd.lisp Tue Nov 15 17:20:50 2016 +0000 +++ b/src/zdd.lisp Fri Nov 18 16:59:02 2016 +0000 @@ -601,18 +601,19 @@ ;;;; Scratch ------------------------------------------------------------------ -(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 <>)))) -(start-profiling '(scully.zdd)) -(stop-profiling) +; (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 <>)))) + +; (start-profiling '(scully.zdd)) +; (stop-profiling)