# HG changeset patch # User Steve Losh # Date 1479747133 0 # Node ID fe02d26f331f4b12297584da9e977b1cd1fa8d78 # Parent addb56e3eb9d74e65a3975bc48934ec232dc8e13 Plumb together all the rule tree/stratification stuff diff -r addb56e3eb9d -r fe02d26f331f package.lisp --- a/package.lisp Mon Nov 21 15:33:17 2016 +0000 +++ b/package.lisp Mon Nov 21 16:52:13 2016 +0000 @@ -66,6 +66,14 @@ :scully.quickutils) (:export)) +(defpackage :scully.logic + (:use + :cl + :losh + :iterate + :cl-arrows + :scully.quickutils)) + (defpackage :scully.reasoners.prolog (:use :cl diff -r addb56e3eb9d -r fe02d26f331f scully.asd --- a/scully.asd Mon Nov 21 15:33:17 2016 +0000 +++ b/scully.asd Mon Nov 21 16:52:13 2016 +0000 @@ -37,6 +37,7 @@ (:file "rule-trees") (:file "zdd") (:file "graphviz") + (:file "logic") (:module "reasoners" :serial t :components ((:file "prolog"))) (:module "grounders" :serial t diff -r addb56e3eb9d -r fe02d26f331f src/graphviz.lisp --- a/src/graphviz.lisp Mon Nov 21 15:33:17 2016 +0000 +++ b/src/graphviz.lisp Mon Nov 21 16:52:13 2016 +0000 @@ -10,20 +10,22 @@ ;;;; Rule Trees --------------------------------------------------------------- +(defparameter *rt-label-fn* #'identity) + (defmethod cl-dot:graph-object-node ((graph (eql 'rule-tree)) (object scully.rule-trees::rule-tree)) (make-instance 'cl-dot:node :attributes (adt:match scully.rule-trees::rule-tree object ((scully.rule-trees::node term _ _) - `(:label ,(aesthetic-string term) - :shape :circle)) + `(:label ,(aesthetic-string (funcall *rt-label-fn* term)) + :shape :ellipse)) (scully.rule-trees::bottom `(:label "⊥" :shape :square)) ((scully.rule-trees::top term) - `(:label ,(aesthetic-string term) + `(:label ,(aesthetic-string (funcall *rt-label-fn* term)) :shape :rectangle))))) (defmethod cl-dot:graph-object-points-to ((graph (eql 'rule-tree)) @@ -35,11 +37,14 @@ (scully.rule-trees::bottom nil))) -(defun draw-rule-tree (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) +(defun draw-rule-tree (rule-tree &key + (filename "rule-tree.png") + (label-fn #'identity)) + (let ((*rt-label-fn* label-fn)) + (cl-dot:dot-graph + (cl-dot:generate-graph-from-roots 'rule-tree (list rule-tree)) + filename + :format :png)) rule-tree) diff -r addb56e3eb9d -r fe02d26f331f src/logic.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/logic.lisp Mon Nov 21 16:52:13 2016 +0000 @@ -0,0 +1,42 @@ +(in-package :scully.logic) + + +(defparameter *rules* + (scully.gdl::read-gdl "gdl/tictactoe-grounded.gdl")) + + +(defun make-stratum-rule-trees (stratum) + (-<> stratum + (group-by #'car <>) + hash-table-values + (mapcar #'scully.rule-trees::make-rule-tree <>))) + + +; (setf *print-length* 10000) +(destructuring-bind (term->number number->term rule-layers) + (scully.terms::integerize-rules *rules*) + ; (let ((*print-length* 1000)) + ; (print-hash-table number->term)) + ; (print-hash-table rule-layers) + (flet ((draw (rt) + (scully.graphviz::draw-rule-tree + rt :label-fn (lambda (n) + (gethash n number->term))) + (break))) + (-<> rule-layers + (gethash :possible <>) + scully.terms::stratify-layer + (nth 0 <>) + (make-stratum-rule-trees <>) + (map nil #'draw <>) + ; (map nil #'pr <>) + ; (mapcar (curry #'group-by #'car) <>) + ; (map nil #'print-hash-table <>) + ; (hash-table-values <>) + ; (map nil (lambda (rule) + ; (-<> rule + ; (scully.rule-trees::make-rule-tree <>) + ; ) + ; (break)) + ; <>) + ))) diff -r addb56e3eb9d -r fe02d26f331f src/rule-trees.lisp --- a/src/rule-trees.lisp Mon Nov 21 15:33:17 2016 +0000 +++ b/src/rule-trees.lisp Mon Nov 21 16:52:13 2016 +0000 @@ -76,4 +76,4 @@ (500 19 17) )) -(-<> *rule* make-rule-tree scully.graphviz::draw-rule-tree) +; (-<> *rule* make-rule-tree scully.graphviz::draw-rule-tree) diff -r addb56e3eb9d -r fe02d26f331f src/terms.lisp --- a/src/terms.lisp Mon Nov 21 15:33:17 2016 +0000 +++ b/src/terms.lisp Mon Nov 21 16:52:13 2016 +0000 @@ -56,17 +56,16 @@ ;;;; Dependency Graph --------------------------------------------------------- -(defun build-dependency-graph (rules &key negations-only) +(defun build-dependency-graph (rules &key includep) (let ((graph (digraph:make-digraph :test #'equal))) (labels ((mark-dependency (head dep) - (digraph:insert-vertex graph head) (digraph:insert-vertex graph dep) (digraph:insert-edge graph head dep)) (mark-dependencies (head body) (iterate (for b :in body) - (when (or (negationp b) - (not negations-only)) + (when (or (null includep) + (funcall includep b)) (mark-dependency head (bare-term b)))))) (iterate (for rule :in rules) (for (head . body) = (ensure-list rule)) @@ -170,7 +169,8 @@ (defun order-predicates (rules) (let* ((dependencies (build-dependency-graph rules)) - (negation-dependencies (build-dependency-graph rules :negations-only t)) + (negation-dependencies (build-dependency-graph rules + :includep #'negationp)) (layers (partition-rules dependencies rules))) (let ((base (gethash :base layers)) (does (gethash :does layers)) @@ -193,9 +193,18 @@ ;;;; Stratification ----------------------------------------------------------- +(defun build-single-layer-dependency-graph (rules) + (let* ((layer-heads (remove-duplicates (mapcar #'first rules)))) + (build-dependency-graph + rules + :includep (lambda (b) + (and (negationp b) + (member (bare-term b) layer-heads)))))) + (defun stratify-layer (rules) (iterate - (with dependencies = (build-dependency-graph rules :negations-only t)) + (with dependencies = (build-single-layer-dependency-graph rules)) + ; (initially (digraph.dot:draw dependencies)) (with remaining = rules) (until (null remaining)) diff -r addb56e3eb9d -r fe02d26f331f src/zdd.lisp --- a/src/zdd.lisp Mon Nov 21 15:33:17 2016 +0000 +++ b/src/zdd.lisp Mon Nov 21 16:52:13 2016 +0000 @@ -392,6 +392,3 @@ ; ; (aesthetic-string (gethash n number->term)))) ; ; (print-through #'zdd-size <>) ; (never <>)))) - -; (start-profiling '(scully.zdd)) -; (stop-profiling) diff -r addb56e3eb9d -r fe02d26f331f vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Mon Nov 21 15:33:17 2016 +0000 +++ b/vendor/make-quickutils.lisp Mon Nov 21 16:52:13 2016 +0000 @@ -12,6 +12,7 @@ :ensure-list :flatten-once :hash-table-keys + :hash-table-values :map-product :mkstr :once-only diff -r addb56e3eb9d -r fe02d26f331f vendor/quickutils.lisp --- a/vendor/quickutils.lisp Mon Nov 21 15:33:17 2016 +0000 +++ b/vendor/quickutils.lisp Mon Nov 21 16:52:13 2016 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :FLATTEN-ONCE :HASH-TABLE-KEYS :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :WITH-GENSYMS :WITH-OUTPUT-TO-FILE) :ensure-package T :package "SCULLY.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :FLATTEN-ONCE :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :WITH-GENSYMS :WITH-OUTPUT-TO-FILE) :ensure-package T :package "SCULLY.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "SCULLY.QUICKUTILS") @@ -18,6 +18,7 @@ :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :FLATTEN-ONCE :MAPHASH-KEYS :HASH-TABLE-KEYS + :MAPHASH-VALUES :HASH-TABLE-VALUES :MAPPEND :MAP-PRODUCT :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :STRING-DESIGNATOR :WITH-GENSYMS @@ -167,6 +168,24 @@ keys)) + (declaim (inline maphash-values)) + (defun maphash-values (function table) + "Like `maphash`, but calls `function` with each value in the hash table `table`." + (maphash (lambda (k v) + (declare (ignore k)) + (funcall function v)) + table)) + + + (defun hash-table-values (table) + "Returns a list containing the values of hash table `table`." + (let ((values nil)) + (maphash-values (lambda (v) + (push v values)) + table) + values)) + + (defun mappend (function &rest lists) "Applies `function` to respective element(s) of each `list`, appending all the all the result list to a single list. `function` must return a list." @@ -346,8 +365,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (export '(compose copy-hash-table curry ensure-boolean ensure-gethash - ensure-list flatten-once hash-table-keys map-product mkstr - once-only rcurry set-equal with-gensyms with-unique-names - with-output-to-file))) + ensure-list flatten-once hash-table-keys hash-table-values + map-product mkstr once-only rcurry set-equal with-gensyms + with-unique-names with-output-to-file))) ;;;; END OF quickutils.lisp ;;;;