# HG changeset patch # User Steve Losh # Date 1502597396 14400 # Node ID 6494ca97e78bf96535f05ea08c5b129854910dce # Parent 0ac280dfa75f009df1384bffceb7d744ab3e79c2 BDDs/ZDDs -> Scully diff -r 0ac280dfa75f -r 6494ca97e78b package.lisp --- a/package.lisp Sun Aug 13 00:06:58 2017 -0400 +++ b/package.lisp Sun Aug 13 00:09:56 2017 -0400 @@ -119,29 +119,6 @@ (:export )) -(defpackage :sand.binary-decision-diagrams - (:use - :cl - :losh - :iterate - :sand.graphviz - :sand.quickutils - :sand.utils) - (:export - )) - -(defpackage :sand.zero-suppressed-decision-diagrams - (:use - :cl - :losh - :iterate - :sand.graphviz - :sand.quickutils - :sand.utils) - (:export - ) - (:nicknames :sand.zdd)) - (defpackage :sand.huffman-trees (:use :cl diff -r 0ac280dfa75f -r 6494ca97e78b sand.asd --- a/sand.asd Sun Aug 13 00:06:58 2017 -0400 +++ b/sand.asd Sun Aug 13 00:09:56 2017 -0400 @@ -61,8 +61,6 @@ (:file "dijkstra-maps") #+sbcl (:file "ffi") #+sbcl (:file "profiling") - (:file "binary-decision-diagrams") - (:file "zero-suppressed-decision-diagrams") (:file "huffman-trees") (:file "streams") (:file "color-difference") diff -r 0ac280dfa75f -r 6494ca97e78b src/binary-decision-diagrams.lisp --- a/src/binary-decision-diagrams.lisp Sun Aug 13 00:06:58 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -(in-package :sand.binary-decision-diagrams) - -(deftype non-negative-fixnum () - `(integer 0 ,most-positive-fixnum)) - - -;;;; Reference ---------------------------------------------------------------- -(adt:defdata bdd - (sink bit) - (node non-negative-fixnum bdd bdd)) - -(defun make-bdd (contents) - (etypecase contents - (bit (sink contents)) - (cons - (destructuring-bind (number low high) contents - (node number (make-bdd low) (make-bdd high)))))) - - -(defun evaluate-bdd (bdd &rest arguments) - (recursively ((n 1) - (bdd bdd) - (argument (first arguments)) - (remaining (rest arguments))) - (adt:match bdd bdd - ((sink bit) bit) - ((node number low high) - (if (> number n) - (recur (1+ n) - bdd - argument - remaining) - (recur (1+ n) - (if (zerop argument) - low - high) - (first remaining) - (rest remaining))))))) - - -(defun bdd-map-nodes (function bdd) - (adt:match bdd bdd - ((sink _) - (list (funcall function bdd))) - ((node _ low high) - (append (list (funcall function bdd)) - (bdd-map-nodes function low) - (bdd-map-nodes function high))))) - -(defun bdd-map-edges (function bdd) - (adt:match bdd bdd - ((sink _) nil) - ((node _ low high) - (list* (funcall function bdd low t) - (funcall function bdd high nil) - (append (bdd-map-edges function low) - (bdd-map-edges function high)))))) - - -(defun node-label (node) - (adt:match bdd node - ((sink bit) (if (zerop bit) 'false 'true)) - ((node number _ _) number))) - -(defun node-shape (node) - (adt:match bdd node - ((sink _) :box) - ((node _ _ _) :circle))) - - -(defun draw-bdd (bdd &optional (path "bdd.dot")) - (let ((nodes (make-hash-table))) - (graphviz-digraph - (bdd-map-nodes (lambda (node) - (list (ensure-gethash node nodes (gensym)) - :label (node-label node) - :shape (node-shape node))) - bdd) - (bdd-map-edges (lambda (a b lowp) - (list (gethash a nodes) - (gethash b nodes) - :style (if lowp :dashed :solid))) - bdd) - :path path))) - - -;;;; Scratch ------------------------------------------------------------------ -(defparameter *maj* - (make-bdd '(1 - (2 0 (3 0 1)) - (2 (3 0 1) 1)))) - - -; (evaluate-bdd *maj* 1 0 1) - -; (draw-bdd *maj* t) diff -r 0ac280dfa75f -r 6494ca97e78b src/zero-suppressed-decision-diagrams.lisp --- a/src/zero-suppressed-decision-diagrams.lisp Sun Aug 13 00:06:58 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -(in-package :sand.zero-suppressed-decision-diagrams) - -(adt:defdata zdd - empty - unit - (node t zdd zdd)) - - -(defun zdd-with (element) - (node element empty unit)) - -(defun patch-unit (z) - (adt:match zdd z - (empty unit) - (unit unit) - ((node element low high) - (node element (patch-unit low) high)))) - -(defun zdd-union (z1 z2 &key (test #'<)) - (recursively ((z1 z1) (z2 z2)) - (adt:match zdd z1 - (empty z2) - (unit (patch-unit z2)) - ((node e1 l1 h1) (adt:match zdd z2 - (empty z1) - (unit (patch-unit z1)) - ((node e2 l2 h2) - (cond - ((funcall test e1 e2) (node e1 (recur l1 z2) h1)) - ((funcall test e2 e1) (recur z2 z1)) - (t (node e1 (recur l1 l2) (recur h1 h2)))))))))) - -(defun zdd-adjoin (z element &key (test #'<)) - (recursively ((z z)) - (adt:match zdd z - (empty empty) - (unit (node element empty unit)) - ((node e low high) - (cond ((funcall test element e) - (node element empty z)) - ((funcall test e element) - (node e (recur low) (recur high))) - (t - (node element empty (zdd-union low high :test test)))))))) - -(defun zdd-disjoin (z element &key (test #'<)) - (recursively ((z z)) - (adt:match zdd z - (empty empty) - (unit unit) - ((node e low high) - (cond ((funcall test element e) - z) - ((funcall test e element) - (node e (recur low) (recur high))) - (t - (zdd-union low high :test test))))))) - - -(defun enumerate-zdd (zdd) - (adt:match zdd zdd - (empty nil) - (unit (list nil)) - ((node element low high) - (append (mapcar (lambda (s) (cons element s)) - (enumerate-zdd high)) - (enumerate-zdd low))))) - - -; (zdd-union (zdd-union (zdd-with 2) (zdd-with 1)) -; (zdd-adjoin -; (zdd-union (zdd-union (zdd-with 2) (zdd-with 3)) -; (zdd-union (zdd-with 1) (zdd-with 3))) -; 2)) - -; (zdd-adjoin -; (zdd-union (zdd-union (zdd-with 2) (zdd-with 3)) -; (zdd-union (zdd-with 1) (zdd-with 3))) -; 2) - -; (zdd-disjoin * 2) - - -; (enumerate-zdd *)