# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1477760522 0
# Node ID ecd4aaf2cc105be1506ec14a3ee4c1a22d69f8b1
# Parent  8eace5aaf113b25072ea0fc1a69039cb6936d45e
ZDD intersection

diff -r 8eace5aaf113 -r ecd4aaf2cc10 src/zdd.lisp
--- a/src/zdd.lisp	Sat Oct 29 16:34:06 2016 +0000
+++ b/src/zdd.lisp	Sat Oct 29 17:02:02 2016 +0000
@@ -1,8 +1,5 @@
 (in-package :scully.zdd)
 
-(defpattern leaf (&optional content)
-  `(structure leaf :content ,content))
-
 
 ;;;; Utils --------------------------------------------------------------------
 (defun gcprint (thing &rest args)
@@ -12,6 +9,9 @@
                   (tg:gc :full t :verbose t))
            args)))
 
+(defpattern leaf (&optional content)
+  `(structure leaf :content ,content))
+
 
 ;;;; GraphViz -----------------------------------------------------------------
 (setf cl-dot:*dot-path* "/usr/local/bin/dot")
@@ -74,38 +74,49 @@
 
 (defun zdd-union (a b)
   (ematch* (a b)
-    (((node) (leaf))
-     (zdd-union b a))
+    (((node) (leaf)) (zdd-union b a))
 
-    (((leaf nil) b)
-     b)
-
-    (((leaf t) b)
-     (unit-patch b))
+    (((leaf nil) b) b)
+    (((leaf t) b) (unit-patch b))
 
     (((node var-a hi-a lo-a)
       (node var-b hi-b lo-b))
      (cond
-       ((< var-a var-b)
-        (zdd-node var-a
-                  hi-a
-                  (zdd-union lo-a b)))
-       ((> var-a var-b)
-        (zdd-node var-b
-                  hi-b
-                  (zdd-union lo-b a)))
-       ((= var-a var-b)
-        (zdd-node var-a
-                  (zdd-union hi-a hi-b)
-                  (zdd-union lo-a lo-b)))))))
+       ((< var-a var-b) (zdd-node var-a hi-a (zdd-union lo-a b)))
+       ((> var-a var-b) (zdd-node var-b hi-b (zdd-union lo-b a)))
+       ((= var-a var-b) (zdd-node var-a
+                                  (zdd-union hi-a hi-b)
+                                  (zdd-union lo-a lo-b)))))))
+
+(defun zdd-intersection (a b)
+  (ematch* (a b)
+    (((node) (leaf)) (zdd-intersection b a))
+
+    (((leaf nil) _) (leaf nil))
+    ((_ (leaf nil)) (leaf nil))
+
+    (((leaf t) (leaf _)) b)
+    (((leaf t) (node _ _ lo)) (zdd-intersection a lo))
+
+    (((node var-a hi-a lo-a)
+      (node var-b hi-b lo-b))
+     (cond
+       ((< var-a var-b) (zdd-intersection lo-a b))
+       ((> var-a var-b) (zdd-intersection lo-b a))
+       ((= var-a var-b) (zdd-node var-a
+                                  (zdd-intersection hi-a hi-b)
+                                  (zdd-intersection lo-a lo-b)))))))
 
 
 (defun zdd-family (&rest sets)
   (reduce #'zdd-union (mapcar #'zdd-set sets)))
 
 
-
 ;;;; Scratch ------------------------------------------------------------------
 (with-zdd
   (enumerate (gcprint (draw (zdd-union (zdd-family '(1 2 4) '(3 4))
                                        (zdd-set '(1 2)))))))
+
+(with-zdd
+  (enumerate (zdd-intersection (zdd-family '(1) '(1 2) '(3) )
+                               (zdd-family '(2 3 4) '(1 4) nil '(1 2)))))