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
11 Author: Gary King, Levente Mészáros, Attila Lendvai
15 This file contains the stuff that does not depend on cl-graphviz.
18 (in-package metabang.graph)
20 ;;; ---------------------------------------------------------------------------
22 ; This outputs the graph to string in accordance with the DOT file format.
23 ; For more information about DOT file format, search the web for "DOTTY" and
26 (defmethod graph->dot ((g basic-graph) (stream stream)
28 (graph-formatter 'graph->dot-properties)
29 (vertex-key 'vertex-id)
31 (vertex-formatter 'vertex->dot)
34 (edge-formatter 'edge->dot))
35 (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
37 (funcall graph-formatter g stream)
46 (let ((key (if vertex-key (funcall vertex-key v) v)))
50 (princ "label=\"" stream)
51 (funcall vertex-labeler v stream)
52 (princ "\", " stream))
53 (funcall vertex-formatter v stream)
54 (princ "];" stream))))
56 (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
57 (directed-edge-tag (when (and (contains-undirected-edge-p g)
58 (contains-directed-edge-p g))
60 (flet ((format-edge (e connector from to directed?)
62 (princ (funcall vertex-key from) stream)
63 (princ connector stream)
64 (princ (funcall vertex-key to) stream)
66 (when (and directed? directed-edge-tag)
67 (princ directed-edge-tag stream))
69 (princ "label=\"" stream)
70 (funcall edge-labeler e stream)
72 (funcall edge-formatter e stream)
81 (when (directed-edge-p e)
82 (format-edge e directed-edge-connector
83 (source-vertex e) (target-vertex e) t))))))
86 (let ((edges (make-container 'simple-associative-container)))
93 (when (and (undirected-edge-p e)
94 (not (item-at-1 edges e)))
95 (setf (item-at-1 edges e) t)
96 (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
105 (let ((g (make-container 'graph-container :default-edge-type :undirected)))
106 (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
107 (add-edge-between-vertexes g a b))
127 (let ((g (make-container 'graph-container :default-edge-type :directed)))
128 (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
129 (add-edge-between-vertexes g a b))
149 (let ((g (make-container 'graph-container)))
150 (loop for (a b) in '((d e) (e f) (d f)) do
151 (add-edge-between-vertexes g a b :edge-type :directed))
152 (loop for (a b) in '((a b) (b c) (b d)) do
153 (add-edge-between-vertexes g a b :edge-type :undirected))
172 ;;; ---------------------------------------------------------------------------
174 (defmethod graph->dot ((g basic-graph) (stream (eql nil))
175 &rest args &key &allow-other-keys)
176 (declare (dynamic-extent args))
177 (with-output-to-string (out)
178 (apply #'graph->dot g out args)))
180 ;;; ---------------------------------------------------------------------------
182 (defmethod graph->dot ((g basic-graph) (stream (eql t))
183 &rest args &key &allow-other-keys)
184 (declare (dynamic-extent args))
185 (apply #'graph->dot g *standard-output* args))
187 ;;; ---------------------------------------------------------------------------
189 (defmethod graph->dot ((g basic-graph) (stream string)
190 &rest args &key &allow-other-keys)
191 (declare (dynamic-extent args))
192 (with-open-file (out stream :direction :output :if-exists :supersede)
193 (apply #'graph->dot g out args)))
195 ;;; ---------------------------------------------------------------------------
197 (defmethod graph->dot ((g basic-graph) (stream pathname)
198 &rest args &key &allow-other-keys)
199 (declare (dynamic-extent args))
200 (apply #'graph->dot g (namestring stream) args))
202 ;;; ---------------------------------------------------------------------------
204 (defmethod graph->dot-properties ((g t) (stream t))
207 ;;; ---------------------------------------------------------------------------
209 (defmethod vertex->dot ((v basic-vertex) (stream stream))
212 ;;; ---------------------------------------------------------------------------
214 (defmethod edge->dot ((v basic-edge) (stream stream))
217 ;;; ---------------------------------------------------------------------------
219 ;;; ---------------------------------------------------------------------------
222 (defmethod dot->graph ((dot-stream stream)
226 ;;; ---------------------------------------------------------------------------
228 (defmethod dot->graph ((dot-stream string)
229 &rest args &key &allow-other-keys)
230 (declare (dynamic-extent args))
231 (with-open-file (out stream :direction :output :if-exists :supersede)
232 (apply #'dot->graph g out args)))
234 ;;; ---------------------------------------------------------------------------
236 (defmethod dot->graph ((dot-stream pathname)
237 &rest args &key &allow-other-keys)
238 (declare (dynamic-extent args))
239 (with-open-file (out stream :direction :output :if-exists :supersede)
240 (apply #'dot->graph g out args))
241 (apply #'dot->graph g (namestring stream) args))
245 (defparameter *dot-graph-attributes*
249 (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
254 (:rankdir ("LR" "RL" "BT"))
256 (:rank (:same :min :max))
265 (defparameter *dot-vertex-attributes*
269 (:fixed-size boolean)
271 (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
272 :diamond :trapezium :parallelogram :house :hexagon :octagon
278 (: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) ()
319 (defclass* dot-vertex-mixin (dot-attributes-mixin) ()
321 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
324 (defclass* dot-graph (graph-container dot-graph-mixin)
327 :vertex-class 'dot-vertex
328 :directed-edge-class 'dot-directed-edge
329 :undirected-edge-class 'dot-edge)
332 (defclass* dot-vertex (graph-container-vertex dot-vertex-mixin) ()
334 (defclass* dot-edge (graph-container-edge dot-edge-mixin) ()
336 (defclass* dot-directed-edge (directed-edge-mixin dot-edge) ()
340 (defmethod (setf dot-attribute) :before (value (attr symbol) (thing dot-attributes-mixin))
341 (ensure-valid-dot-attribute attr thing))
343 (defmethod (setf dot-attribute) (value (attr symbol) (thing dot-attributes-mixin))
344 (setf (getf (dot-attributes thing) attr) value))
346 (defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
347 (getf (dot-attributes thing) attr))
349 (defmethod graph->dot-properties ((graph dot-graph-mixin) (stream t))
350 (loop for (name value) on (dot-attributes graph) by #'cddr
352 (print-dot-key-value name value *dot-graph-attributes* stream)
353 (format 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 (format stream "~a=~a" (string-downcase key)
384 (etypecase value-type
386 (with-output-to-string (str)
395 ((member spline bounding-box)
396 (with-output-to-string (str)
402 (princ (first el) str)
404 (princ (second el) str)
408 (unless (typep value 'integer)
409 (error "Invalid value for ~S: ~S is not an integer"
419 (coerce value 'single-float))
421 (unless (member value value-type :test 'equal)
422 (error "Invalid value for ~S: ~S is not one of ~S"
423 key value value-type))
425 (string-downcase value)
428 (defun textify (object)
429 (let ((string (princ-to-string object)))
430 (with-output-to-string (stream)
431 (write-char #\" stream)
432 (loop for c across string do
433 ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
437 (write-char #\\ stream)
438 (write-char c stream))
440 (write-char #\\ stream)
441 (write-char #\n stream))
443 (write-char c stream))))
444 (write-char #\" stream))))
446 ;;; ---------------------------------------------------------------------------
448 ; Calls the dot executable to create external output for graphs
450 #+(or win32 mswindows)
451 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
453 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
455 (defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
456 "Generate an external represenation of a graph to a file, by running
457 the program in *dot-path*."
458 (let ((dot-string (graph->dot g nil))
459 (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
460 #+lispworks (with-open-stream
461 (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
463 (write-line dot-string s)
467 (sb-ext:run-program *dot-path*
468 (list dot-type "-o" file-name)
469 :input (make-string-input-stream dot-string)
470 :output *standard-output*)
471 #-(or sbcl lispworks)
472 (error "Don't know how to execute a program on this platform")))
474 ;;; ---------------------------------------------------------------------------
478 (defun test-dot-external ()
479 (let* ((g (make-graph 'dot-graph))
480 (v1 (add-vertex g 'a :dot-attributes '(:shape :box
482 (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
485 (add-edge-between-vertexes g v1 v2
486 :dot-attributes '(:arrowhead :open
489 (print (graph->dot g nil))
490 (graph->dot-external g "/tmp/test.gif" :type :gif)))