# HG changeset patch # User Steve Losh # Date 1471726086 0 # Node ID 9823fe1aea308b043cb01e70dd1b91b931a7a737 # Parent 49f0ca1bece8dae60d064c16bdbd55363662940a Add graphviz, basic BDDs diff -r 49f0ca1bece8 -r 9823fe1aea30 .hgignore --- 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 diff -r 49f0ca1bece8 -r 9823fe1aea30 make-quickutils.lisp --- 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 diff -r 49f0ca1bece8 -r 9823fe1aea30 package.lisp --- 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 + )) diff -r 49f0ca1bece8 -r 9823fe1aea30 quickutils.lisp --- 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 ;;;; diff -r 49f0ca1bece8 -r 9823fe1aea30 sand.asd --- 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"))) diff -r 49f0ca1bece8 -r 9823fe1aea30 src/binary-decision-diagrams.lisp --- /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*) diff -r 49f0ca1bece8 -r 9823fe1aea30 src/graphviz.lisp --- /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))))))