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