--- a/.hgignore Thu Aug 18 18:14:12 2016 +0000
+++ b/.hgignore Sat Aug 20 20:48:06 2016 +0000
@@ -1,1 +1,4 @@
+syntax: glob
scratch.lisp
+*.png
+*.dot
--- a/make-quickutils.lisp Thu Aug 18 18:14:12 2016 +0000
+++ b/make-quickutils.lisp Sat Aug 20 20:48:06 2016 +0000
@@ -11,6 +11,7 @@
:n-grams
:define-constant
:riffle
+ :tree-collect
; :switch
; :while
; :ensure-boolean
--- a/package.lisp Thu Aug 18 18:14:12 2016 +0000
+++ b/package.lisp Sat Aug 20 20:48:06 2016 +0000
@@ -90,3 +90,26 @@
#:dm-maximum-value
#:dm-map
#:dm-ref))
+
+(defpackage #:sand.graphviz
+ (:use
+ #:cl
+ #:cl-arrows
+ #:losh
+ #:iterate
+ #:sand.quickutils
+ #:sand.utils)
+ (:export
+ #:graphviz-digraph))
+
+(defpackage #:sand.binary-decision-diagrams
+ (:use
+ #:cl
+ #:cl-arrows
+ #:losh
+ #:iterate
+ #:sand.graphviz
+ #:sand.quickutils
+ #:sand.utils)
+ (:export
+ ))
--- a/quickutils.lisp Thu Aug 18 18:14:12 2016 +0000
+++ b/quickutils.lisp Sat Aug 20 20:48:06 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :N-GRAMS :DEFINE-CONSTANT :RIFFLE) :ensure-package T :package "SAND.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :N-GRAMS :DEFINE-CONSTANT :RIFFLE :TREE-COLLECT) :ensure-package T :package "SAND.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SAND.QUICKUTILS")
@@ -17,7 +17,7 @@
:MAKE-GENSYM-LIST :ONCE-ONLY
:ENSURE-FUNCTION :COMPOSE :CURRY
:RCURRY :TAKE :N-GRAMS
- :DEFINE-CONSTANT :RIFFLE))))
+ :DEFINE-CONSTANT :RIFFLE :TREE-COLLECT))))
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
@@ -249,8 +249,27 @@
:when xs
:collect obj))
+
+ (defun tree-collect (predicate tree)
+ "Returns a list of every node in the `tree` that satisfies the `predicate`. If there are any improper lists in the tree, the `predicate` is also applied to their dotted elements."
+ (let ((sentinel (gensym)))
+ (flet ((my-cdr (obj)
+ (cond ((consp obj)
+ (let ((result (cdr obj)))
+ (if (listp result)
+ result
+ (list result sentinel))))
+ (t
+ (list sentinel)))))
+ (loop :for (item . rest) :on tree :by #'my-cdr
+ :until (eq item sentinel)
+ :if (funcall predicate item) collect item
+ :else
+ :if (listp item)
+ :append (tree-collect predicate item)))))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(with-gensyms with-unique-names once-only compose curry rcurry
- n-grams define-constant riffle)))
+ n-grams define-constant riffle tree-collect)))
;;;; END OF quickutils.lisp ;;;;
--- a/sand.asd Thu Aug 18 18:14:12 2016 +0000
+++ b/sand.asd Sat Aug 20 20:48:06 2016 +0000
@@ -31,10 +31,12 @@
(:module "src"
:serial t
:components ((:file "utils")
+ (:file "graphviz")
(:file "random-numbers")
(:file "ascii")
(:file "markov")
(:file "dijkstra-maps")
+ (:file "binary-decision-diagrams")
(:module "terrain"
:serial t
:components ((:file "diamond-square")))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/binary-decision-diagrams.lisp Sat Aug 20 20:48:06 2016 +0000
@@ -0,0 +1,91 @@
+(in-package #:sand.binary-decision-diagrams)
+
+
+(defun required ()
+ (error "Argument required."))
+
+(defstruct (bdd-node (:constructor make-bdd-node (number low high)))
+ (number (required) :type fixnum)
+ (low (required) :type (or bit bdd-node))
+ (high (required) :type (or bit bdd-node)))
+
+(defun make-bdd (contents)
+ (etypecase contents
+ (bit contents)
+ (cons
+ (destructuring-bind (number low high) contents
+ (make-bdd-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)))
+ (etypecase bdd
+ (bit bdd)
+ (bdd-node
+ (if (> (bdd-node-number bdd) n)
+ (recur (1+ n)
+ bdd
+ argument
+ remaining)
+ (recur (1+ n)
+ (if (zerop argument)
+ (bdd-node-low bdd)
+ (bdd-node-high bdd))
+ (first remaining)
+ (rest remaining)))))))
+
+(defun bdd-map-nodes (function bdd)
+ (etypecase bdd
+ (bit (list (funcall function bdd)))
+ (bdd-node
+ (append (list (funcall function bdd))
+ (bdd-map-nodes function (bdd-node-low bdd))
+ (bdd-map-nodes function (bdd-node-high bdd))))))
+
+(defun bdd-map-edges (function bdd)
+ (etypecase bdd
+ (bit nil)
+ (bdd-node
+ (let ((low (bdd-node-low bdd))
+ (high (bdd-node-high bdd)))
+ (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)
+ (etypecase node
+ (bit (if (zerop node) 'false 'true))
+ (bdd-node (bdd-node-number node))))
+
+(defun node-shape (node)
+ (etypecase node
+ (bit :box)
+ (bdd-node :circle)))
+
+
+(defun draw-bdd (bdd &optional (path "bdd.dot"))
+ (let ((nodes (make-hash-table)))
+ (graphviz-digraph
+ (bdd-map-nodes (lambda (node)
+ (list (gethash-or-init 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)))
+
+
+(defparameter *maj*
+ (make-bdd '(1
+ (2 0 (3 0 1))
+ (2 (3 0 1) 1))))
+
+(draw-bdd *maj*)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/graphviz.lisp Sat Aug 20 20:48:06 2016 +0000
@@ -0,0 +1,43 @@
+(in-package #:sand.graphviz)
+
+(defun graphviz-node (id &key (label id) (shape :box))
+ (format t " ~A [shape=~(~A~),label=\"~A\"];~%"
+ id shape label))
+
+(defun graphviz-edge (from-id to-id &key (label "") (style :solid))
+ (format t " ~A -> ~A [style=~(~A~),label=\"~A\"];~%"
+ from-id to-id style label))
+
+(defun %graphviz-digraph (nodes edges)
+ (format t "digraph G {~%")
+ (mapc (curry #'apply #'graphviz-node) nodes)
+ (mapc (curry #'apply #'graphviz-edge) edges)
+ (format t "}~%"))
+
+(defun graphviz-digraph (nodes edges &key (path t))
+ "Output some Graphviz code to draw a digraph.
+
+ If `path` is `t`, output to a string. If `nil`, return a string. Otherwise
+ it should be a path designator, and the code will be spit to that file.
+
+ Each element in `nodes` will have `graphviz-node` applied to it, so they
+ should look like this:
+
+ (node-id)
+ (node-id :label \"foo\" :shape :circle)
+
+ Each element in `edges` will have `graphviz-edge` applied to it, so they
+ should look like this:
+
+ (from-node-id to-node-id)
+ (from-node-id to-node-id :style :dashed :label \"bar\")
+
+ "
+ (case path
+ ((t) (%graphviz-digraph nodes edges))
+ ((nil) (with-output-to-string (s)
+ (let ((*standard-output* s))
+ (%graphviz-digraph nodes edges))))
+ (t (with-open-file (s path :direction :output :if-exists :supersede)
+ (let ((*standard-output* s))
+ (%graphviz-digraph nodes edges))))))