1 ;;;-*- Mode: Lisp; Package: metabang.graph -*-
5 $Id: graphviz-support.lisp,v 1.7 2005/06/21 20:51:51 moody Exp $
7 Copyright 1992 - 2005 Experimental Knowledge Systems Lab,
8 University of Massachusetts Amherst MA, 01003-4610
9 Professor Paul Cohen, Director
15 A color value can be a huesaturation-
16 brightness triple (three floating point numbers between 0 and 1, separated
17 by commas); one of the colors names listed in Appendix G (borrowed from
18 some version of the X window system); or a red-green-blue (RGB) triple4 (three
19 hexadecimal number between 00 and FF, preceded by the character Õ#Õ). Thus,
20 the values "orchid", "0.8396,0.4862,0.8549" and #DA70D6 are three
21 ways to specify the same color.
24 (in-package metabang.graph)
26 ;;; ---------------------------------------------------------------------------
28 ; This outputs the graph to string in accordance with the DOT file format.
29 ; For more information about DOT file format, search the web for "DOTTY" and
32 (defmethod graph->dot ((g basic-graph) (stream stream)
34 (graph-formatter 'graph->dot-properties)
35 (vertex-key 'vertex-id)
37 (vertex-formatter 'vertex->dot)
40 (edge-formatter 'edge->dot))
41 (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
43 (funcall graph-formatter g stream)
52 (let ((key (if vertex-key (funcall vertex-key v) v)))
56 (princ "label=\"" stream)
57 (funcall vertex-labeler v stream)
58 (princ "\", " stream))
59 (funcall vertex-formatter v stream)
62 (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
63 (directed-edge-tag (when (and (contains-undirected-edge-p g)
64 (contains-directed-edge-p g))
66 (flet ((format-edge (e connector from to directed?)
68 (princ (funcall vertex-key from) stream)
69 (princ connector stream)
70 (princ (funcall vertex-key to) stream)
72 (when (and directed? directed-edge-tag)
73 (princ directed-edge-tag stream))
75 (princ "label=\"" stream)
76 (funcall edge-labeler e stream)
78 (funcall edge-formatter e stream)
87 (when (directed-edge-p e)
88 (format-edge e directed-edge-connector
89 (source-vertex e) (target-vertex e) t))))))
92 (let ((edges (make-container 'simple-associative-container)))
99 (when (and (undirected-edge-p e)
100 (not (item-at-1 edges e)))
101 (setf (item-at-1 edges e) t)
102 (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
111 (let ((g (make-container 'graph-container :default-edge-type :undirected)))
112 (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
113 (add-edge-between-vertexes g a b))
133 (let ((g (make-container 'graph-container :default-edge-type :directed)))
134 (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
135 (add-edge-between-vertexes g a b))
155 (let ((g (make-container 'graph-container)))
156 (loop for (a b) in '((d e) (e f) (d f)) do
157 (add-edge-between-vertexes g a b :edge-type :directed))
158 (loop for (a b) in '((a b) (b c) (b d)) do
159 (add-edge-between-vertexes g a b :edge-type :undirected))
178 ;;; ---------------------------------------------------------------------------
180 (defmethod graph->dot ((g basic-graph) (stream (eql nil))
181 &rest args &key &allow-other-keys)
182 (declare (dynamic-extent args))
183 (let ((out (make-string-output-stream)))
184 (apply #'graph->dot g out args)
185 (get-output-stream-string out)))
187 ;;; ---------------------------------------------------------------------------
189 (defmethod graph->dot ((g basic-graph) (stream (eql t))
190 &rest args &key &allow-other-keys)
191 (declare (dynamic-extent args))
192 (apply #'graph->dot g *standard-output* args))
194 ;;; ---------------------------------------------------------------------------
196 (defmethod graph->dot ((g basic-graph) (stream string)
197 &rest args &key &allow-other-keys)
198 (declare (dynamic-extent args))
199 (with-open-file (out stream :direction :output :if-exists :supersede)
200 (apply #'graph->dot g out args)))
202 ;;; ---------------------------------------------------------------------------
204 (defmethod graph->dot ((g basic-graph) (stream pathname)
205 &rest args &key &allow-other-keys)
206 (declare (dynamic-extent args))
207 (apply #'graph->dot g (namestring stream) args))
209 ;;; ---------------------------------------------------------------------------
211 (defmethod graph->dot-properties ((g t) (stream t))
214 ;;; ---------------------------------------------------------------------------
216 (defmethod vertex->dot ((v basic-vertex) (stream stream))
219 ;;; ---------------------------------------------------------------------------
221 (defmethod edge->dot ((v basic-edge) (stream stream))
224 ;;; ---------------------------------------------------------------------------
226 ;;; ---------------------------------------------------------------------------
229 (defmethod dot->graph ((dot-stream stream)
233 ;;; ---------------------------------------------------------------------------
235 (defmethod dot->graph ((dot-stream string)
236 &rest args &key &allow-other-keys)
237 (declare (dynamic-extent args))
238 (with-open-file (out stream :direction :output :if-exists :supersede)
239 (apply #'dot->graph g out args)))
241 ;;; ---------------------------------------------------------------------------
243 (defmethod dot->graph ((dot-stream pathname)
244 &rest args &key &allow-other-keys)
245 (declare (dynamic-extent args))
246 (with-open-file (out stream :direction :output :if-exists :supersede)
247 (apply #'dot->graph g out args))
248 (apply #'dot->graph g (namestring stream) args))
252 (defparameter *dot-graph-attributes*
255 (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
260 (:rankdir ("LR" "RL" "BT"))
262 (:rank (:same :min :max))
271 (defparameter *dot-vertex-attributes*
274 (:fixed-size boolean)
276 (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
277 :diamond :trapezium :parallelogram :house :hexagon :octagon
283 (:style (:filled :solid :dashed :dotted :bold :invis))
286 (defparameter *dot-edge-attributes*
293 (:style (:solid :dashed :dotted :bold :invis))
295 (:dir (:forward :back :both :none))
298 (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee
299 :empty :invempty :open :halfopen :diamond :odiamond
301 (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee
302 :empty :invempty :open :halfopen :diamond :odiamond
306 (:labelfontsize integer)
307 (:labelfontname text)
308 (:labelfontcolor text)
309 (:labeldistance integer)
310 (:port-label-distance integer)
314 (:constraint boolean)
317 (defclass* dot-attributes-mixin ()
318 ((dot-attributes nil ia))
321 (defclass* dot-graph-mixin (dot-attributes-mixin) ()
323 (defclass* dot-vertex-mixin (dot-attributes-mixin) ()
325 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
328 (defclass* dot-graph (graph-container dot-graph-mixin)
331 :vertex-class 'dot-vertex
332 :directed-edge-class 'dot-directed-edge
333 :undirected-edge-class 'dot-edge)
336 (defclass* dot-vertex (graph-container-vertex dot-vertex-mixin) ()
338 (defclass* dot-edge (graph-container-edge dot-edge-mixin) ()
340 (defclass* dot-directed-edge (directed-edge-mixin dot-edge) ()
343 (defmethod graph->dot-properties ((graph dot-graph) (stream t))
344 (loop for (name value) on (dot-attributes graph) by #'cddr
346 (print-dot-key-value name value *dot-graph-attributes* stream)
347 (format stream " ;~%")))
349 (defmethod vertex->dot ((vertex dot-vertex) (stream t))
350 (format-dot-attributes vertex *dot-vertex-attributes* stream))
352 (defmethod edge->dot ((edge dot-edge) (stream t))
353 (format-dot-attributes edge *dot-edge-attributes* stream))
355 (defun format-dot-attributes (object dot-attributes stream)
356 (loop for (name value) on (dot-attributes object) by #'cddr
357 for prefix = "" then "," do
358 (write-string prefix stream)
359 (print-dot-key-value name value dot-attributes stream)))
361 (defun print-dot-key-value (key value dot-attributes stream)
362 (destructuring-bind (key value-type)
363 (or (assoc key dot-attributes)
364 (error "Invalid attribute ~S" key))
365 (format stream "~a=~a" (string-downcase key)
366 (etypecase value-type
368 (unless (typep value 'integer)
369 (error "Invalid value for ~S: ~S is not an integer"
379 (coerce value 'single-float))
381 (unless (member value value-type :test 'equal)
382 (error "Invalid value for ~S: ~S is not one of ~S"
383 key value value-type))
385 (string-downcase value)
388 (defun textify (object)
389 (let ((string (princ-to-string object)))
390 (with-output-to-string (stream)
391 (write-char #\" stream)
392 (loop for c across string do
393 ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
397 (write-char #\\ stream)
398 (write-char c stream))
400 (write-char #\\ stream)
401 (write-char #\n stream))
403 (write-char c stream))))
404 (write-char #\" stream))))
406 ;;; ---------------------------------------------------------------------------
408 ; Calls the dot executable to create external output for graphs
410 #+(or win32 mswindows)
411 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
413 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
415 (defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
416 "Generate an external represenation of a graph to a file, by running
417 the program in *dot-path*."
418 (let ((dot-string (graph->dot g nil))
419 (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
420 #+lispworks (with-open-stream
421 (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
423 (write-line dot-string s)
427 (sb-ext:run-program *dot-path*
428 (list dot-type "-o" file-name)
429 :input (make-string-input-stream dot-string)
430 :output *standard-output*)
431 #-(or sbcl lispworks)
432 (error "Don't know how to execute a program on this platform")))
434 ;;; ---------------------------------------------------------------------------
438 (defun test-dot-external ()
439 (let* ((g (make-graph 'dot-graph))
440 (v1 (add-vertex g 'a :dot-attributes '(:shape :box
442 (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
445 (add-edge-between-vertexes g v1 v2
446 :dot-attributes '(:arrowhead :open
449 (print (graph->dot g nil))
450 (graph->dot-external g "/tmp/test.gif" :type :gif)))