1 ;;;-*- Mode: Lisp; Package: metabang.graph -*-
5 Author: Gary King, Levente Mészáros, Attila Lendvai
9 This file contains the stuff that does not depend on cl-graphviz.
12 (in-package #:metabang.graph)
14 ;;; ---------------------------------------------------------------------------
16 ; This outputs the graph to string in accordance with the DOT file format.
17 ; For more information about DOT file format, search the web for "DOTTY" and
20 (defmethod graph->dot ((g basic-graph) (stream stream)
22 (graph-formatter 'graph->dot-properties)
23 (vertex-key 'vertex-id)
25 (vertex-formatter 'vertex->dot)
27 (edge-formatter 'edge->dot)
29 (format stream "~A G {~%graph "
30 (if (contains-undirected-edge-p g) "graph" "digraph"))
32 (funcall graph-formatter g stream)
41 (let ((key (if vertex-key (funcall vertex-key v) v)))
45 (princ "label=\"" stream)
46 (funcall vertex-labeler v stream)
47 (princ "\", " stream))
48 (funcall vertex-formatter v stream)
49 (princ "];" stream))))
51 (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
52 (directed-edge-tag (when (and (contains-undirected-edge-p g)
53 (contains-directed-edge-p g))
55 (flet ((format-edge (e connector from to directed?)
57 (princ (funcall vertex-key from) stream)
58 (princ connector stream)
59 (princ (funcall vertex-key to) stream)
61 (when (and directed? directed-edge-tag)
62 (princ directed-edge-tag stream))
64 (princ "label=\"" stream)
65 (funcall edge-labeler e stream)
67 (funcall edge-formatter e stream)
76 (when (directed-edge-p e)
77 (format-edge e directed-edge-connector
78 (source-vertex e) (target-vertex e) t))))))
81 (let ((edges (make-container 'simple-associative-container)))
89 ;(spy e (undirected-edge-p e) (item-at-1 edges e))
90 (when (and (undirected-edge-p e)
91 (not (item-at-1 edges e)))
92 (setf (item-at-1 edges e) t)
93 (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
102 (let ((g (make-container 'graph-container :default-edge-type :undirected)))
103 (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
104 (add-edge-between-vertexes g a b))
124 (let ((g (make-container 'graph-container :default-edge-type :directed)))
125 (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
126 (add-edge-between-vertexes g a b))
146 (let ((g (make-container 'graph-container)))
147 (loop for (a b) in '((d e) (e f) (d f)) do
148 (add-edge-between-vertexes g a b :edge-type :directed))
149 (loop for (a b) in '((a b) (b c) (b d)) do
150 (add-edge-between-vertexes g a b :edge-type :undirected))
169 ;;; ---------------------------------------------------------------------------
171 (defmethod graph->dot ((g basic-graph) (stream (eql nil))
172 &rest args &key &allow-other-keys)
173 (declare (dynamic-extent args))
174 (with-output-to-string (out)
175 (apply #'graph->dot g out args)))
177 ;;; ---------------------------------------------------------------------------
179 (defmethod graph->dot ((g basic-graph) (stream (eql t))
180 &rest args &key &allow-other-keys)
181 (declare (dynamic-extent args))
182 (apply #'graph->dot g *standard-output* args))
184 ;;; ---------------------------------------------------------------------------
186 (defmethod graph->dot ((g basic-graph) (stream string)
187 &rest args &key &allow-other-keys)
188 (declare (dynamic-extent args))
189 (with-open-file (out stream :direction :output :if-exists :supersede)
190 (apply #'graph->dot g out args)))
192 ;;; ---------------------------------------------------------------------------
194 (defmethod graph->dot ((g basic-graph) (stream pathname)
195 &rest args &key &allow-other-keys)
196 (declare (dynamic-extent args))
197 (apply #'graph->dot g (namestring stream) args))
199 ;;; ---------------------------------------------------------------------------
201 (defmethod graph->dot-properties ((g t) (stream t))
204 ;;; ---------------------------------------------------------------------------
206 (defmethod vertex->dot ((v basic-vertex) (stream stream))
209 ;;; ---------------------------------------------------------------------------
211 (defmethod edge->dot ((v basic-edge) (stream stream))
214 ;;; ---------------------------------------------------------------------------
216 ;;; ---------------------------------------------------------------------------
219 (defmethod dot->graph ((dot-stream stream)
223 ;;; ---------------------------------------------------------------------------
225 (defmethod dot->graph ((dot-stream string)
226 &rest args &key &allow-other-keys)
227 (declare (dynamic-extent args))
228 (with-open-file (out stream :direction :output :if-exists :supersede)
229 (apply #'dot->graph g out args)))
231 ;;; ---------------------------------------------------------------------------
233 (defmethod dot->graph ((dot-stream pathname)
234 &rest args &key &allow-other-keys)
235 (declare (dynamic-extent args))
236 (with-open-file (out stream :direction :output :if-exists :supersede)
237 (apply #'dot->graph g out args))
238 (apply #'dot->graph g (namestring stream) args))
242 (defparameter *dot-graph-attributes*
247 (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
253 (:rankdir ("LR" "RL" "BT"))
255 (:rank (:same :min :max))
265 (defparameter *dot-vertex-attributes*
270 (:fixed-size boolean)
272 (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
273 :diamond :trapezium :parallelogram :house :hexagon :octagon
280 (:style (:filled :solid :dashed :dotted :bold :invis))
283 (:peripheries integer)))
285 (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) ()
324 :vertex-class 'dot-vertex
325 :directed-edge-class 'dot-directed-edge
326 :undirected-edge-class 'dot-edge))
327 (defclass* dot-vertex-mixin (dot-attributes-mixin) ()
329 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
332 (defclass* dot-graph (dot-graph-mixin graph-container)
336 (defclass* dot-vertex (dot-vertex-mixin graph-container-vertex) ()
338 (defclass* dot-edge (dot-edge-mixin graph-container-edge) ()
340 (defclass* dot-directed-edge (dot-edge directed-edge-mixin) ()
344 (defmethod (setf dot-attribute-value)
345 :before (value (attr symbol) (thing dot-attributes-mixin))
346 (declare (ignore value))
347 (ensure-valid-dot-attribute attr thing))
349 (defmethod (setf dot-attribute-value)
350 (value (attr symbol) (thing dot-attributes-mixin))
351 (setf (getf (dot-attributes thing) attr) value))
353 (defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
354 (getf (dot-attributes thing) attr))
356 (defmacro defpixel-inch-accessors (name attr type)
357 (let ((actual-name (form-symbol name (symbol-name '-in-pixels))))
359 (eval-always (export ',actual-name))
360 (defmethod ,actual-name ((thing ,type))
361 "Return the attribute in pixels assuming 72 dpi"
362 (when (dot-attribute-value ,attr thing)
363 (* 72 (dot-attribute-value ,attr thing))))
364 (defmethod (setf ,actual-name) (value (thing ,type))
365 "Set the attribute in pixels assuming 72 dpi"
366 (setf (dot-attribute-value ,attr thing)
367 (coerce (/ value 72) 'double-float))))))
369 (defpixel-inch-accessors width :width dot-vertex-mixin)
370 (defpixel-inch-accessors height :height dot-vertex-mixin)
373 (defmethod graph->dot-properties ((graph dot-graph-mixin) (stream t))
374 (loop for (name value) on (dot-attributes graph) by #'cddr
376 (print-dot-key-value name value *dot-graph-attributes* stream)))
378 (defmethod vertex->dot ((vertex dot-vertex-mixin) (stream t))
379 (format-dot-attributes vertex *dot-vertex-attributes* stream))
381 (defmethod edge->dot ((edge dot-edge-mixin) (stream t))
382 (format-dot-attributes edge *dot-edge-attributes* stream))
384 (defun format-dot-attributes (object dot-attributes stream)
385 (loop for (name value) on (dot-attributes object) by #'cddr
386 for prefix = "" then ", " do
387 (write-string prefix stream)
388 (print-dot-key-value name value dot-attributes stream)))
390 (defmethod ensure-valid-dot-attribute (key (object dot-graph-mixin))
391 (or (assoc key *dot-graph-attributes*)
392 (error "Invalid dot graph attribute ~S" key)))
394 (defmethod ensure-valid-dot-attribute (key (object dot-vertex-mixin))
395 (or (assoc key *dot-vertex-attributes*)
396 (error "Invalid dot vertex attribute ~S" key)))
398 (defmethod ensure-valid-dot-attribute (key (object dot-edge-mixin))
399 (or (assoc key *dot-edge-attributes*)
400 (error "Invalid dot edge attribute ~S" key)))
402 (defun print-dot-key-value (key value dot-attributes stream)
403 (destructuring-bind (key value-type)
404 (or (assoc key dot-attributes)
405 (error "Invalid attribute ~S" key))
406 (write-name-for-dot key stream)
408 (etypecase value-type
410 (with-output-to-string (str)
420 (with-output-to-string (str)
426 (princ (first el) str)
428 (princ (second el) str)
431 ((member bounding-box)
432 (with-output-to-string (str)
438 (princ (first el) str)
440 (princ (second el) str)
444 (unless (typep value 'integer)
445 (error "Invalid value for ~S: ~S is not an integer"
455 ;; graphviz does not support the 1.2e-3 format
456 (with-output-to-string (str)
457 (format str "~,f" (coerce value 'single-float))))
459 (unless (member value value-type :test 'equal)
460 (error "Invalid value for ~S: ~S is not one of ~S"
461 key value value-type))
463 (string-downcase value)
466 (defmethod write-name-for-dot (attribute stream)
467 (format stream "~(~A~)" attribute))
469 (defmethod write-name-for-dot ((attribute (eql :url)) stream)
470 (format stream "URL"))
472 (defun textify (object)
473 (let ((string (princ-to-string object)))
474 (with-output-to-string (stream)
475 (write-char #\" stream)
476 (loop for c across string do
477 ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
481 (write-char #\\ stream)
482 (write-char c stream))
484 (write-char #\\ stream)
485 (write-char #\n stream))
487 (write-char c stream))))
488 (write-char #\" stream))))
490 ;;; ---------------------------------------------------------------------------
492 ; Calls the dot executable to create external output for graphs
494 #+(or win32 mswindows)
495 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
497 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
499 (defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
500 "Generate an external represenation of a graph to a file, by running
501 the program in *dot-path*."
502 (declare (ignorable file-name))
503 (let ((dot-string (graph->dot g nil))
504 (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
505 (declare (ignorable dot-string dot-type))
506 #+lispworks (with-open-stream
507 (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
509 (write-line dot-string s)
513 (sb-ext:run-program *dot-path*
514 (list dot-type "-o" file-name)
515 :input (make-string-input-stream dot-string)
516 :output *standard-output*)
517 #-(or sbcl lispworks)
518 (error "Don't know how to execute a program on this platform")))
524 (defun test-dot-external ()
525 (let* ((g (make-graph 'dot-graph))
526 (v1 (add-vertex g 'a :dot-attributes '(:shape :box
528 (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
531 (add-edge-between-vertexes g v1 v2
532 :dot-attributes '(:arrowhead :open
535 (print (graph->dot g nil))
536 (graph->dot-external g "/tmp/test.gif" :type :gif)))