# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1477852069 0
# Node ID 10be262d7ae3c520a1db0214f71ea25ec11b6698
# Parent  c4fb52c19da9c660c03af16f9fdffdbe55033486
Add ZDD meet operation

diff -r c4fb52c19da9 -r 10be262d7ae3 src/zdd.lisp
--- a/src/zdd.lisp	Sun Oct 30 17:52:26 2016 +0000
+++ b/src/zdd.lisp	Sun Oct 30 18:27:49 2016 +0000
@@ -144,6 +144,32 @@
     (reduce #'zdd-join% zdds)
     (leaf nil)))
 
+(defun zdd-meet% (a b)
+  (ematch* (a b)
+    (((leaf nil) _) (leaf nil))
+    ((_ (leaf nil)) (leaf nil))
+
+    (((leaf t) _) (leaf t))
+    ((_ (leaf t)) (leaf t))
+
+    (((node var-a hi-a lo-a)
+      (node var-b hi-b lo-b))
+     (cond
+       ((< var-a var-b) (zdd-union (zdd-meet% hi-a b)
+                                   (zdd-meet% lo-a b)))
+       ((> var-a var-b) (zdd-union (zdd-meet% hi-b a)
+                                   (zdd-meet% lo-b a)))
+       ((= var-a var-b) (zdd-node var-a
+                                  (zdd-meet% hi-a hi-b)
+                                  (zdd-union (zdd-meet% hi-a lo-b)
+                                             (zdd-meet% lo-a hi-b)
+                                             (zdd-meet% lo-a lo-b))))))))
+
+(defun zdd-meet (&rest zdds)
+  (if zdds
+    (reduce #'zdd-meet% zdds)
+    (leaf nil)))
+
 
 (defun zdd-family (&rest sets)
   (reduce #'zdd-union (mapcar #'zdd-set sets)))
@@ -166,5 +192,10 @@
   (enumerate
     (zdd-join (zdd-family '(1 2) '(7 8) '())
               (zdd-family '(1 5 9) nil)
-              (zdd-set '(1))
-              )))
+              (zdd-set '(1)))))
+
+(with-zdd
+  (enumerate
+    (zdd-meet (zdd-family '(1 2) '(1 6))
+              (zdd-family '(2)))))
+