From: melevy Date: Wed, 8 Feb 2006 21:26:29 +0000 (-0500) Subject: Added support for calling the dot executable, plus a bunch of dot attributes. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e73837a566b7681c1ed2c5f6f1468e430e30e037;p=cl-graph.git Added support for calling the dot executable, plus a bunch of dot attributes. darcs-hash:20060208212629-d0603-4994de100350fc1fc64f7308c2873c020063d069.gz --- diff --git a/dev/graphviz-support.lisp b/dev/graphviz-support.lisp index 8eed617..65a4f57 100644 --- a/dev/graphviz-support.lisp +++ b/dev/graphviz-support.lisp @@ -247,4 +247,196 @@ B--D [] (apply #'dot->graph g out args)) (apply #'dot->graph g (namestring stream) args)) -|# \ No newline at end of file +|# + +(defparameter *dot-graph-attributes* + '((:size text) + (:page text) + (:ratio (:fill :compress :auto)) ;; Could actually be a float number too + (:margin float) + (:nodesep float) + (:ranksep float) + (:ordering (:out)) + (:rankdir ("LR" "RL" "BT")) + (:pagedir text) + (:rank (:same :min :max)) + (:rotate integer) + (:center integer) + (:nslimit float) + (:mclimit float) + (:layers text) + (:color text) + (:bgcolor text))) + +(defparameter *dot-vertex-attributes* + '((:height integer) + (:width integer) + (:fixed-size boolean) + (:label text) + (:shape (:record :plaintext :ellipse :circle :egg :triangle :box + :diamond :trapezium :parallelogram :house :hexagon :octagon + :doublecircle)) + (:fontsize integer) + (:fontname text) + (:color text) + (:fillcolor text) + (:style (:filled :solid :dashed :dotted :bold :invis)) + (:layer text))) + +(defparameter *dot-edge-attributes* + '((:minlen integer) + (:weight integer) + (:label text) + (:fontsize integer) + (:fontname text) + (:fontcolor text) + (:style (:solid :dashed :dotted :bold :invis)) + (:color text) + (:dir (:forward :back :both :none)) + (:tailclip boolean) + (:headclip boolean) + (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee + :empty :invempty :open :halfopen :diamond :odiamond + :box :obox :crow)) + (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee + :empty :invempty :open :halfopen :diamond :odiamond + :box :obox :crow)) + (:headlabel text) + (:taillabel text) + (:labelfontsize integer) + (:labelfontname text) + (:labelfontcolor text) + (:labeldistance integer) + (:port-label-distance integer) + (:decorate boolean) + (:samehead boolean) + (:sametail boolean) + (:constraint boolean) + (:layer text))) + +(defclass* dot-attributes-mixin () + ((dot-attributes nil ia))) + +(defclass* dot-graph-mixin (dot-attributes-mixin) ()) +(defclass* dot-vertex-mixin (dot-attributes-mixin) ()) +(defclass* dot-edge-mixin (dot-attributes-mixin) ()) + +(defclass* dot-graph (graph-container dot-graph-mixin) + () + (:default-initargs + :vertex-class 'dot-vertex + :directed-edge-class 'dot-edge + :undirected-edge-class 'dot-edge)) + +(defclass* dot-vertex (graph-container-vertex dot-vertex-mixin) ()) +(defclass* dot-edge (graph-container-edge dot-edge-mixin) ()) +(defclass* dot-directed-edge (directed-edge-mixin dot-edge) ()) + +(defmethod graph->dot-properties ((graph dot-graph) (stream t)) + (loop for (name value) on (dot-attributes graph) by #'cddr + do + (print-dot-key-value name value *dot-graph-attributes* stream) + (format stream " ;~%"))) + +(defmethod vertex->dot ((vertex dot-vertex) (stream t)) + (format-dot-attributes vertex *dot-vertex-attributes* stream)) + +(defmethod edge->dot ((edge dot-edge) (stream t)) + (format-dot-attributes edge *dot-edge-attributes* stream)) + +(defun format-dot-attributes (object dot-attributes stream) + (loop for (name value) on (dot-attributes object) by #'cddr + for prefix = "" then "," do + (write-string prefix stream) + (print-dot-key-value name value dot-attributes stream))) + +(defun print-dot-key-value (key value dot-attributes stream) + (destructuring-bind (key value-type) + (or (assoc key dot-attributes) + (error "Invalid attribute ~S" key)) + (format stream "~a=~a" (string-downcase key) + (etypecase value-type + ((member integer) + (unless (typep value 'integer) + (error "Invalid value for ~S: ~S is not an integer" + key value)) + value) + ((member boolean) + (if value + "true" + "false")) + ((member text) + (textify value)) + ((member float) + (coerce value 'single-float)) + (list + (unless (member value value-type :test 'equal) + (error "Invalid value for ~S: ~S is not one of ~S" + key value value-type)) + (if (symbolp value) + (string-downcase value) + value)))))) + +(defun textify (object) + (let ((string (princ-to-string object))) + (with-output-to-string (stream) + (write-char #\" stream) + (loop for c across string do + ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc. + ;; to work. + (case c + ((#\") + (write-char #\\ stream) + (write-char c stream)) + (#\Newline + (write-char #\\ stream) + (write-char #\n stream)) + (t + (write-char c stream)))) + (write-char #\" stream)))) + +;;; --------------------------------------------------------------------------- +; +; Calls the dot executable to create external output for graphs +; +#+(or win32 mswindows) +(defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"") +#+(or linux unix) +(defvar *dot-path* "/usr/bin/dot" "Path to `dot`") + +(defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps)) + "Generate an external represenation of a graph to a file, by running +the program in *dot-path*." + (let ((dot-string (graph->dot g nil)) + (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type))))) + #+lispworks (with-open-stream + (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name) + :direction :input)) + (write-line dot-string s) + (force-output s) + (close s)) + #+sbcl + (sb-ext:run-program *dot-path* + (list dot-type "-o" file-name) + :input (make-string-input-stream dot-string) + :output *standard-output*) + #-(or sbcl lispworks) + (error "Don't know how to execute a program on this platform"))) + +;;; --------------------------------------------------------------------------- +; +; Test dot external +; +(defun test-dot-external () + (let* ((g (make-graph 'dot-graph)) + (v1 (add-vertex g 'a :dot-attributes '(:shape :box + :color :blue))) + (v2 (add-vertex g 'b :dot-attributes '(:shape :circle + :style :filled + :color :yellow)))) + (add-edge-between-vertexes g v1 v2 + :dot-attributes '(:arrowhead :open + :arrowtail :normal + :style :dotted)) + (print (graph->dot g nil)) + (graph->dot-external g "/tmp/test.gif" :type :gif)))