# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1479655986 0
# Node ID 37e64253cccf8a27eeda880489d5356946c3a153
# Parent  fcc52d00b79fe5593dbd4847005078947e0116d0
Stratify rules according to negations

diff -r fcc52d00b79f -r 37e64253cccf src/terms.lisp
--- a/src/terms.lisp	Fri Nov 18 16:59:02 2016 +0000
+++ b/src/terms.lisp	Sun Nov 20 15:33:06 2016 +0000
@@ -70,6 +70,7 @@
                       (mark-dependency head (bare-term b))))))
       (iterate (for rule :in rules)
                (for (head . body) = (ensure-list rule))
+               (digraph:insert-vertex graph head)
                (mark-dependencies head body)))
     graph))
 
@@ -191,6 +192,28 @@
               layers))))
 
 
+;;;; Stratification -----------------------------------------------------------
+(defun stratify-layer (rules)
+  (iterate
+    (with dependencies = (build-dependency-graph rules :negations-only t))
+    (with remaining = rules)
+    (until (null remaining))
+
+    (for next-heads = (digraph:leafs dependencies))
+    (when (null next-heads)
+      (error "Cycle in negations detected!"))
+
+    (for stratum = (remove-if-not (lambda (rule)
+                                    (member (first rule) next-heads))
+                                  remaining))
+    (collect stratum)
+    ;; TODO: do we want the full rules or just the heads here?
+    ; (collect next-heads)
+
+    (setf remaining (set-difference remaining stratum))
+    (mapc (curry #'digraph:remove-vertex dependencies) next-heads)))
+
+
 ;;;; API ----------------------------------------------------------------------
 (defun integerize-term (term->number term)
   (match term
@@ -222,8 +245,19 @@
 
 ;;;; Scratch ------------------------------------------------------------------
 
-#+no (-<> scully.zdd::*rules*
+(-<> '(
+       (ggp-rules::<= a (ggp-rules::true foo))
+       (ggp-rules::<= b (ggp-rules::true foo) (ggp-rules::true baz))
+       (ggp-rules::<= c (ggp-rules::true dogs) (ggp-rules::not a))
+       (ggp-rules::<= x (ggp-rules::not a) b)
+       (ggp-rules::<= y (ggp-rules::not a) (ggp-rules::not x))
+       (ggp-rules::<= y (ggp-rules::not c))
+       )
   (integerize-rules <>)
-  ; (never <>)
+  (nth 2 <>)
+  (gethash :possible <>)
+  (stratify-layer <>)
+  (mapc (lambda (s) (format t "Stratum:~%~{    ~S~%~}" s)) <>)
+  (never <>)
   ; (map nil #'print-hash-table <>)
   )