# HG changeset patch # User Steve Losh # Date 1478784590 0 # Node ID b4a7a2c6e44905f65ce243dfb0d6adf8f3f25898 # Parent a406e590934fa479788a5b73888f65c2876f788c Implement the layer ordering diff -r a406e590934f -r b4a7a2c6e449 src/terms.lisp --- a/src/terms.lisp Thu Nov 10 12:26:02 2016 +0000 +++ b/src/terms.lisp Thu Nov 10 13:29:50 2016 +0000 @@ -36,7 +36,9 @@ (defun-match normalize-term (term) (`(not ,body) `(not ,(normalize-term body))) - (_ (ensure-list term))) + (`(,_) term) + (`(,head ,@body) (cons head (mapcar #'normalize-term body))) + (sym `(,sym))) (defun normalize-rule (rule) (mapcar #'normalize-term (ensure-list rule))) @@ -49,15 +51,15 @@ (defun build-dependency-graph (rules &key negations-only) (let ((graph (digraph:make-digraph :test #'equal))) (labels - ((mark-dependency (head-pred body-pred) - (digraph:insert-vertex graph head-pred) - (digraph:insert-vertex graph body-pred) - (digraph:insert-edge graph head-pred body-pred)) + ((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)) - (mark-dependency head b))))) + (mark-dependency head (bare-term b)))))) (iterate (for rule :in rules) (for (head . body) = (ensure-list rule)) (mark-dependencies head body))) @@ -113,11 +115,9 @@ nil) -(defun partition-predicates (rules) - (let* ((rules (normalize-rules rules)) - (dependencies (build-dependency-graph rules)) - (terms (-<> rules - (mapcan #'identity <>) +(defun partition-rules (dependencies rules) + (let* ((terms (-<> rules + flatten-once (mapcar #'bare-term <>))) (layers (make-hash-table :test #'equal))) (-<> terms @@ -129,50 +129,39 @@ ;;;; Intra-Layer Ordering ----------------------------------------------------- -(defun build-layer-graph (rules) - (let ((graph (digraph:make-digraph :test #'equal - :initial-vertices (mapcar #'first rules)))) - (iterate - (for (head . body) :in rules) - (iterate (for term :in body) - (when (negationp term) - (let ((dependency (bare-term term))) - (when (digraph:contains-vertex-p graph dependency) - (digraph:insert-edge graph head dependency)))))) - graph)) - +(defun sort-layer (negation-dependencies terms) + (let ((layer (digraph:make-digraph :test #'equal))) + (flet ((add-dependencies (term) + (iterate + (for dep :in (digraph:successors negation-dependencies term)) + (when (digraph:contains-vertex-p layer dep) + (digraph:insert-edge layer term dep))))) + (mapc (curry #'digraph:insert-vertex layer) terms) + (mapc #'add-dependencies terms)) + ;; todo: fix the roots/cycles issue in cl-digraph + (digraph:topological-sort layer))) (defun order-rules (rules) - (-> rules - build-layer-graph - digraph:topological-sort)) + (let* ((rules (normalize-rules rules)) + (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)))) ;;;; Scratch ------------------------------------------------------------------ -; (defparameter *g* -; (build-layer-graph (list -; '((t foo) a) -; '((t bar) a (not (t foo))) -; '((t baz) a (not (t bar))) -; '((t dogs) a x) -; '((t cats) a (not (t dogs))) -; ))) -; (order-rules (list -; '((t foo) a) -; '((t bar) a (not (t foo))) -; '((t baz) a (not (t bar))))) - -(-<> '( - ((foo x) (true 1)) - (cats (foo x)) - (dogs (not cats)) - ((bar x) (true 2) (does q)) - (mice (bar x)) - ((legal x) (true 3)) - ) - partition-predicates - ; print-hash-table - ) - -(print-hash-table *) +(order-rules '( + (foo (true something)) + (bar (true (something)) + (does x) + ) + )) diff -r a406e590934f -r b4a7a2c6e449 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Thu Nov 10 12:26:02 2016 +0000 +++ b/vendor/make-quickutils.lisp Thu Nov 10 13:29:50 2016 +0000 @@ -10,6 +10,7 @@ :ensure-boolean :ensure-gethash :ensure-list + :flatten-once :hash-table-keys :map-product :mkstr diff -r a406e590934f -r b4a7a2c6e449 vendor/quickutils.lisp --- a/vendor/quickutils.lisp Thu Nov 10 12:26:02 2016 +0000 +++ b/vendor/quickutils.lisp Thu Nov 10 13:29:50 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 :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 :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") @@ -16,9 +16,10 @@ (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION :COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH - :ENSURE-LIST :MAPHASH-KEYS - :HASH-TABLE-KEYS :MAPPEND :MAP-PRODUCT - :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL + :ENSURE-LIST :FLATTEN-ONCE + :MAPHASH-KEYS :HASH-TABLE-KEYS + :MAPPEND :MAP-PRODUCT :MKSTR + :ONCE-ONLY :RCURRY :SET-EQUAL :STRING-DESIGNATOR :WITH-GENSYMS :WITH-OPEN-FILE* :WITH-OUTPUT-TO-FILE)))) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -139,6 +140,15 @@ (list list))) + (defun flatten-once (list) + "Flatten `list` once." + (loop :for x :in list + :if (listp x) + :append x + :else + :collect x)) + + (declaim (inline maphash-keys)) (defun maphash-keys (function table) "Like `maphash`, but calls `function` with each key in the hash table `table`." @@ -336,7 +346,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (export '(compose copy-hash-table curry ensure-boolean ensure-gethash - ensure-list 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 map-product mkstr + once-only rcurry set-equal with-gensyms with-unique-names + with-output-to-file))) ;;;; END OF quickutils.lisp ;;;;