b4a7a2c6e449

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

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

--- 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 ;;;;