1 ;;;-*- Mode: Lisp; Package: metabang.graph -*-
5 $Id: graphviz-support.lisp,v 1.7 2005/06/21 20:51:51 moody Exp $
7 Author: Gary King, Levente Mészáros, Attila Lendvai
11 This file contains the stuff that does not depend on cl-graphviz.
14 (in-package metabang.graph)
16 ;;; ---------------------------------------------------------------------------
18 ; This outputs the graph to string in accordance with the DOT file format.
19 ; For more information about DOT file format, search the web for "DOTTY" and
22 (defmethod graph->dot ((g basic-graph) (stream stream)
24 (graph-formatter 'graph->dot-properties)
25 (vertex-key 'vertex-id)
27 (vertex-formatter 'vertex->dot)
30 (edge-formatter 'edge->dot))
31 (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
33 (funcall graph-formatter g stream)
42 (let ((key (if vertex-key (funcall vertex-key v) v)))
46 (princ "label=\"" stream)
47 (funcall vertex-labeler v stream)
48 (princ "\", " stream))
49 (funcall vertex-formatter v stream)
50 (princ "];" stream))))
52 (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
53 (directed-edge-tag (when (and (contains-undirected-edge-p g)
54 (contains-directed-edge-p g))
56 (flet ((format-edge (e connector from to directed?)
58 (princ (funcall vertex-key from) stream)
59 (princ connector stream)
60 (princ (funcall vertex-key to) stream)
62 (when (and directed? directed-edge-tag)
63 (princ directed-edge-tag stream))
65 (princ "label=\"" stream)
66 (funcall edge-labeler e stream)
68 (funcall edge-formatter e stream)
77 (when (directed-edge-p e)
78 (format-edge e directed-edge-connector
79 (source-vertex e) (target-vertex e) t))))))
82 (let ((edges (make-container 'simple-associative-container)))
90 ;(spy e (undirected-edge-p e) (item-at-1 edges e))
91 (when (and (undirected-edge-p e)
92 (not (item-at-1 edges e)))
93 (setf (item-at-1 edges e) t)
94 (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
103 (let ((g (make-container 'graph-container :default-edge-type :undirected)))
104 (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
105 (add-edge-between-vertexes g a b))
125 (let ((g (make-container 'graph-container :default-edge-type :directed)))
126 (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
127 (add-edge-between-vertexes g a b))
147 (let ((g (make-container 'graph-container)))
148 (loop for (a b) in '((d e) (e f) (d f)) do
149 (add-edge-between-vertexes g a b :edge-type :directed))
150 (loop for (a b) in '((a b) (b c) (b d)) do
151 (add-edge-between-vertexes g a b :edge-type :undirected))
170 ;;; ---------------------------------------------------------------------------
172 (defmethod graph->dot ((g basic-graph) (stream (eql nil))
173 &rest args &key &allow-other-keys)
174 (declare (dynamic-extent args))
175 (with-output-to-string (out)
176 (apply #'graph->dot g out args)))
178 ;;; ---------------------------------------------------------------------------
180 (defmethod graph->dot ((g basic-graph) (stream (eql t))
181 &rest args &key &allow-other-keys)
182 (declare (dynamic-extent args))
183 (apply #'graph->dot g *standard-output* args))
185 ;;; ---------------------------------------------------------------------------
187 (defmethod graph->dot ((g basic-graph) (stream string)
188 &rest args &key &allow-other-keys)
189 (declare (dynamic-extent args))
190 (with-open-file (out stream :direction :output :if-exists :supersede)
191 (apply #'graph->dot g out args)))
193 ;;; ---------------------------------------------------------------------------
195 (defmethod graph->dot ((g basic-graph) (stream pathname)
196 &rest args &key &allow-other-keys)
197 (declare (dynamic-extent args))
198 (apply #'graph->dot g (namestring stream) args))
200 ;;; ---------------------------------------------------------------------------
202 (defmethod graph->dot-properties ((g t) (stream t))
205 ;;; ---------------------------------------------------------------------------
207 (defmethod vertex->dot ((v basic-vertex) (stream stream))
210 ;;; ---------------------------------------------------------------------------
212 (defmethod edge->dot ((v basic-edge) (stream stream))
215 ;;; ---------------------------------------------------------------------------
217 ;;; ---------------------------------------------------------------------------
220 (defmethod dot->graph ((dot-stream stream)
224 ;;; ---------------------------------------------------------------------------
226 (defmethod dot->graph ((dot-stream string)
227 &rest args &key &allow-other-keys)
228 (declare (dynamic-extent args))
229 (with-open-file (out stream :direction :output :if-exists :supersede)
230 (apply #'dot->graph g out args)))
232 ;;; ---------------------------------------------------------------------------
234 (defmethod dot->graph ((dot-stream pathname)
235 &rest args &key &allow-other-keys)
236 (declare (dynamic-extent args))
237 (with-open-file (out stream :direction :output :if-exists :supersede)
238 (apply #'dot->graph g out args))
239 (apply #'dot->graph g (namestring stream) args))
243 (defparameter *dot-graph-attributes*
247 (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
252 (:rankdir ("LR" "RL" "BT"))
254 (:rank (:same :min :max))
263 (defparameter *dot-vertex-attributes*
267 (:fixed-size boolean)
269 (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
270 :diamond :trapezium :parallelogram :house :hexagon :octagon
277 (:style (:filled :solid :dashed :dotted :bold :invis))
281 (defparameter *dot-edge-attributes*
289 (:style (:solid :dashed :dotted :bold :invis))
291 (:dir (:forward :back :both :none))
294 (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee
295 :empty :invempty :open :halfopen :diamond :odiamond
297 (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee
298 :empty :invempty :open :halfopen :diamond :odiamond
302 (:labelfontsize integer)
303 (:labelfontname text)
304 (:labelfontcolor text)
305 (:labeldistance integer)
306 (:port-label-distance integer)
310 (:constraint boolean)
313 (defclass* dot-attributes-mixin ()
314 ((dot-attributes nil ia))
317 (defclass* dot-graph-mixin (dot-attributes-mixin) ()
320 :vertex-class 'dot-vertex
321 :directed-edge-class 'dot-directed-edge
322 :undirected-edge-class 'dot-edge))
323 (defclass* dot-vertex-mixin (dot-attributes-mixin) ()
325 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
328 (defclass* dot-graph (dot-graph-mixin graph-container)
332 (defclass* dot-vertex (dot-vertex-mixin graph-container-vertex) ()
334 (defclass* dot-edge (dot-edge-mixin graph-container-edge) ()
336 (defclass* dot-directed-edge (dot-edge directed-edge-mixin) ()
340 (defmethod (setf dot-attribute-value) :before (value (attr symbol) (thing dot-attributes-mixin))
341 (declare (ignore value))
342 (ensure-valid-dot-attribute attr thing))
344 (defmethod (setf dot-attribute-value) (value (attr symbol) (thing dot-attributes-mixin))
345 (setf (getf (dot-attributes thing) attr) value))
347 (defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
348 (getf (dot-attributes thing) attr))
350 (defmethod graph->dot-properties ((graph dot-graph-mixin) (stream t))
351 (loop for (name value) on (dot-attributes graph) by #'cddr
353 (print-dot-key-value name value *dot-graph-attributes* stream)))
355 (defmethod vertex->dot ((vertex dot-vertex-mixin) (stream t))
356 (format-dot-attributes vertex *dot-vertex-attributes* stream))
358 (defmethod edge->dot ((edge dot-edge-mixin) (stream t))
359 (format-dot-attributes edge *dot-edge-attributes* stream))
361 (defun format-dot-attributes (object dot-attributes stream)
362 (loop for (name value) on (dot-attributes object) by #'cddr
363 for prefix = "" then ", " do
364 (write-string prefix stream)
365 (print-dot-key-value name value dot-attributes stream)))
367 (defmethod ensure-valid-dot-attribute (key (object dot-graph-mixin))
368 (or (assoc key *dot-graph-attributes*)
369 (error "Invalid dot graph attribute ~S" key)))
371 (defmethod ensure-valid-dot-attribute (key (object dot-vertex-mixin))
372 (or (assoc key *dot-vertex-attributes*)
373 (error "Invalid dot vertex attribute ~S" key)))
375 (defmethod ensure-valid-dot-attribute (key (object dot-edge-mixin))
376 (or (assoc key *dot-edge-attributes*)
377 (error "Invalid dot edge attribute ~S" key)))
379 (defun print-dot-key-value (key value dot-attributes stream)
380 (destructuring-bind (key value-type)
381 (or (assoc key dot-attributes)
382 (error "Invalid attribute ~S" key))
383 (write-name-for-dot key stream)
385 (etypecase value-type
387 (with-output-to-string (str)
397 (with-output-to-string (str)
403 (princ (first el) str)
405 (princ (second el) str)
408 ((member bounding-box)
409 (with-output-to-string (str)
415 (princ (first el) str)
417 (princ (second el) str)
421 (unless (typep value 'integer)
422 (error "Invalid value for ~S: ~S is not an integer"
432 (coerce value 'single-float))
434 (unless (member value value-type :test 'equal)
435 (error "Invalid value for ~S: ~S is not one of ~S"
436 key value value-type))
438 (string-downcase value)
441 (defmethod write-name-for-dot (attribute stream)
442 (format stream "~(~A~)" attribute))
444 (defmethod write-name-for-dot ((attribute (eql :url)) stream)
445 (format stream "URL"))
447 (defun textify (object)
448 (let ((string (princ-to-string object)))
449 (with-output-to-string (stream)
450 (write-char #\" stream)
451 (loop for c across string do
452 ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
456 (write-char #\\ stream)
457 (write-char c stream))
459 (write-char #\\ stream)
460 (write-char #\n stream))
462 (write-char c stream))))
463 (write-char #\" stream))))
465 ;;; ---------------------------------------------------------------------------
467 ; Calls the dot executable to create external output for graphs
469 #+(or win32 mswindows)
470 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
472 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
474 (defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
475 "Generate an external represenation of a graph to a file, by running
476 the program in *dot-path*."
477 (let ((dot-string (graph->dot g nil))
478 (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
479 #+lispworks (with-open-stream
480 (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
482 (write-line dot-string s)
486 (sb-ext:run-program *dot-path*
487 (list dot-type "-o" file-name)
488 :input (make-string-input-stream dot-string)
489 :output *standard-output*)
490 #-(or sbcl lispworks)
491 (error "Don't know how to execute a program on this platform")))
493 ;;; ---------------------------------------------------------------------------
497 (defun test-dot-external ()
498 (let* ((g (make-graph 'dot-graph))
499 (v1 (add-vertex g 'a :dot-attributes '(:shape :box
501 (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
504 (add-edge-between-vertexes g v1 v2
505 :dot-attributes '(:arrowhead :open
508 (print (graph->dot g nil))
509 (graph->dot-external g "/tmp/test.gif" :type :gif)))