# HG changeset patch # User Steve Losh # Date 1478780762 0 # Node ID a406e590934fa479788a5b73888f65c2876f788c # Parent c660eaed47fb80e18c8697d0a02bbc2500399e17 Get the layer partitioning working diff -r c660eaed47fb -r a406e590934f src/terms.lisp --- a/src/terms.lisp Sun Nov 06 16:15:09 2016 +0000 +++ b/src/terms.lisp Thu Nov 10 12:26:02 2016 +0000 @@ -2,7 +2,7 @@ (in-readtable :fare-quasiquote) -;;;; Overview +;;;; Overview ----------------------------------------------------------------- ;;; We start with a set of grounded rules like: ((next bar) x y (true foo)). ;;; ;;; We need to turn map each term to a unique integer, making sure that they end @@ -20,9 +20,11 @@ ;;; (sees ...) ;;; anything that depends on only these or lower ;;; +;;; Within each layer the ordering is arbitrary, EXCEPT that if a rule X that +;;; relies on the negation of a rule Y, then Y must come before X. -;;;; Ordering ----------------------------------------------------------------- +;;;; Utils -------------------------------------------------------------------- (defun-match bare-term (term) (`(not ,x) x) (x x)) @@ -32,50 +34,101 @@ (_ nil)) -(defun content< (c1 c2) - nil - ) +(defun-match normalize-term (term) + (`(not ,body) `(not ,(normalize-term body))) + (_ (ensure-list term))) + +(defun normalize-rule (rule) + (mapcar #'normalize-term (ensure-list rule))) + +(defun normalize-rules (rules) + (mapcar #'normalize-rule rules)) + -(defun-match* same-predicate-p (t1 t2) - ((`(,h1 ,@_) - `(,h2 ,@_)) - (equal h1 h2)) - ((_ _) nil)) +;;;; Dependency Graph --------------------------------------------------------- +(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-dependencies (head body) + (iterate (for b :in body) + (when (or (negationp b) + (not negations-only)) + (mark-dependency head b))))) + (iterate (for rule :in rules) + (for (head . body) = (ensure-list rule)) + (mark-dependencies head body))) + graph)) + + +;;;; Layer Partitioning ------------------------------------------------------- +(defun mark (layers layer term) + (setf (gethash term layers) layer) + (pushnew term (gethash layer layers) :test #'equal)) + + +(defun extract-simple (predicates layer layers terms) + (iterate (for term :in terms) + (if (member (car term) predicates) + (mark layers layer term) + (collect term)))) -(defun-ematch layer-id (l) - (:base 0) - (:does 1) - (:possible 2) - (:happens 3)) +(defun extract-base (layers terms) + (extract-simple '(true) :base layers terms)) -(defun-match layer (term) - (`(,head ,@_) (case head - (true :base) - (does :does) - ((legal goal) :possible) - ((next sees) :happening))) - ('terminal :possible) - (_ (error "Unknown layer for ~S" term))) - -(defun layer< (l1 l2) - (< (layer-id l1) - (layer-id l2))) - -(defun layer= (l1 l2) - (eql l1 l2)) +(defun extract-does (layers terms) + (extract-simple '(does) :does layers terms)) -(defun term< (t1 t2) - (let ((l1 (layer t1)) - (l2 (layer t2))) - (if (not (layer= l1 l2)) - (layer< l1 l2) +(defun extract-possible% (layers dependencies terms) + (labels ((find-dependencies (term) + (mapcar (rcurry #'gethash layers) + (digraph:successors dependencies term))) + (find-eligible (terms) + (iterate (for term :in terms) + (for deps = (find-dependencies term)) + (for unmet = (set-difference deps '(:base :possible))) + (when (null unmet) + (collect term))))) + (iterate + (with remaining = terms) + (for next = (find-eligible remaining)) + (while next) + (mapcar (curry #'mark layers :possible) next) + (zapf remaining (set-difference % next :test #'equal)) + (finally (return remaining))))) - ))) +(defun extract-possible (layers dependencies terms) + (-<> terms + (extract-simple '(legal goal terminal) :possible layers <>) + (extract-possible% layers dependencies <>))) +(defun extract-happens (layers terms) + (mapcar (curry #'mark layers :happens) terms) + nil) + +(defun partition-predicates (rules) + (let* ((rules (normalize-rules rules)) + (dependencies (build-dependency-graph rules)) + (terms (-<> rules + (mapcan #'identity <>) + (mapcar #'bare-term <>))) + (layers (make-hash-table :test #'equal))) + (-<> terms + (extract-base layers <>) + (extract-does layers <>) + (extract-possible layers dependencies <>) + (extract-happens layers <>)) + layers)) + + +;;;; Intra-Layer Ordering ----------------------------------------------------- (defun build-layer-graph (rules) (let ((graph (digraph:make-digraph :test #'equal :initial-vertices (mapcar #'first rules)))) @@ -88,23 +141,38 @@ (digraph:insert-edge graph head dependency)))))) graph)) + (defun order-rules (rules) - (-<> rules + (-> rules build-layer-graph - (digraph::map-topological #'identity <>))) - + digraph:topological-sort)) -(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))) - ))) +;;;; 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))))) +; (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 *)