dev/graphviz-support.lisp

   1 ;;;-*- Mode: Lisp; Package: metabang.graph -*-
   2
   3 #| simple-header
   4
   5 $Id: graphviz-support.lisp,v 1.7 2005/06/21 20:51:51 moody Exp $
   6
   7 Copyright 1992 - 2005 Experimental Knowledge Systems Lab,
   8 University of Massachusetts Amherst MA, 01003-4610
   9 Professor Paul Cohen, Director
  10
  11 Author: Gary King
  12
  13 DISCUSSION
  14
  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.
  22
  23 |#
  24 (in-package metabang.graph)
  25
  26 ;;; ---------------------------------------------------------------------------
  27 ;
  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
  30 ; "GRAPHVIZ".
  31 ;
  32 (defmethod graph->dot ((g basic-graph) (stream stream)
  33                        &key
  34                        (graph-formatter 'graph->dot-properties)
  35                        (vertex-key 'vertex-id)
  36                        (vertex-labeler nil)
  37                        (vertex-formatter 'vertex->dot)
  38                        (edge-key nil)
  39                        (edge-labeler 'princ)
  40                        (edge-formatter 'edge->dot))
  41   (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
  42   (format stream "[")
  43   (funcall graph-formatter g stream)
  44   (format stream "];")
  45   (terpri stream)
  46
  47   ;; vertex formatting
  48   (iterate-vertexes
  49    g
  50    (lambda (v)
  51      (terpri stream)
  52      (let ((key (if vertex-key (funcall vertex-key v) v)))
  53        (princ key stream)
  54        (princ " [" stream)
  55        (when vertex-labeler
  56          (princ "label=\"" stream)
  57          (funcall vertex-labeler v stream)
  58          (princ "\", " stream))
  59        (funcall vertex-formatter v stream)
  60        (princ "]" stream))))
  61
  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))
  65                              "dir=forward, ")))
  66     (flet ((format-edge (e connector from to directed?)
  67              (terpri stream)
  68              (princ (funcall vertex-key from) stream)
  69              (princ connector stream)
  70              (princ (funcall vertex-key to) stream)
  71              (princ " [" stream)
  72              (when (and directed? directed-edge-tag)
  73                (princ directed-edge-tag stream))
  74              (when edge-key
  75                (princ "label=\"" stream)
  76                (funcall edge-labeler e stream)
  77                (princ "\"," stream))
  78              (funcall edge-formatter e stream)
  79              (princ "]" stream)))
  80       ;; directed edges
  81       (iterate-vertexes
  82        g
  83        (lambda (v)
  84          (iterate-target-edges
  85           v
  86           (lambda (e)
  87             (when (directed-edge-p e)
  88               (format-edge e directed-edge-connector
  89                            (source-vertex e) (target-vertex e) t))))))
  90
  91       ;; undirected edges
  92       (let ((edges (make-container 'simple-associative-container)))
  93         (iterate-vertexes
  94          g
  95          (lambda (v)
  96            (iterate-edges
  97             v
  98             (lambda (e)
  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)))))))))
 103
 104   (terpri stream)
 105   (princ "}" stream)
 106
 107   (values g))
 108
 109
 110 #+Test
 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))
 114   (graph->dot g nil))
 115
 116 #+Test
 117 "graph G {
 118 E []
 119 C []
 120 B []
 121 A []
 122 D []
 123 F []
 124 D--E []
 125 E--F []
 126 B--C []
 127 A--B []
 128 B--D []
 129 D--F []
 130 }"
 131
 132 #+Test
 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))
 136   (graph->dot g nil))
 137
 138 #+Test
 139 "digraph G {
 140 E []
 141 C []
 142 B []
 143 A []
 144 D []
 145 F []
 146 E->F []
 147 B->C []
 148 B->D []
 149 A->B []
 150 D->E []
 151 D->F []
 152 }"
 153
 154 #+Test
 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))
 160   (graph->dot g nil))
 161
 162 #+Test
 163 "graph G {
 164 E []
 165 C []
 166 B []
 167 A []
 168 D []
 169 F []
 170 E--F [dir=forward, ]
 171 D--E [dir=forward, ]
 172 D--F [dir=forward, ]
 173 B--C []
 174 A--B []
 175 B--D []
 176 }"
 177
 178 ;;; ---------------------------------------------------------------------------
 179
 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)))
 186
 187 ;;; ---------------------------------------------------------------------------
 188
 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))
 193
 194 ;;; ---------------------------------------------------------------------------
 195
 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)))
 201
 202 ;;; ---------------------------------------------------------------------------
 203
 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))
 208
 209 ;;; ---------------------------------------------------------------------------
 210
 211 (defmethod graph->dot-properties ((g t) (stream t))
 212   (values))
 213
 214 ;;; ---------------------------------------------------------------------------
 215
 216 (defmethod vertex->dot ((v basic-vertex) (stream stream))
 217   (values))
 218
 219 ;;; ---------------------------------------------------------------------------
 220
 221 (defmethod edge->dot ((v basic-edge) (stream stream))
 222   (values))
 223
 224 ;;; ---------------------------------------------------------------------------
 225 ;;; dot->graph
 226 ;;; ---------------------------------------------------------------------------
 227
 228 #|
 229 (defmethod dot->graph ((dot-stream stream)
 230                        &key)
 231   )
 232
 233 ;;; ---------------------------------------------------------------------------
 234
 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)))
 240
 241 ;;; ---------------------------------------------------------------------------
 242
 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))
 249
 250 |#
 251
 252 (defparameter *dot-graph-attributes*
 253   '((:size text)
 254     (:page text)
 255     (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
 256     (:margin float)
 257     (:nodesep float)
 258     (:ranksep float)
 259     (:ordering (:out))
 260     (:rankdir ("LR" "RL" "BT"))
 261     (:pagedir text)
 262     (:rank (:same :min :max))
 263     (:rotate integer)
 264     (:center integer)
 265     (:nslimit float)
 266     (:mclimit float)
 267     (:layers text)
 268     (:color text)
 269     (:bgcolor text)))
 270
 271 (defparameter *dot-vertex-attributes*
 272   '((:height integer)
 273     (:width integer)
 274     (:fixed-size boolean)
 275     (:label text)
 276     (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
 277              :diamond :trapezium :parallelogram :house :hexagon :octagon
 278              :doublecircle))
 279     (:fontsize integer)
 280     (:fontname text)
 281     (:color text)
 282     (:fillcolor text)
 283     (:style (:filled :solid :dashed :dotted :bold :invis))
 284     (:layer text)))
 285
 286 (defparameter *dot-edge-attributes*
 287   '((:minlen integer)
 288     (:weight integer)
 289     (:label text)
 290     (:fontsize integer)
 291     (:fontname text)
 292     (:fontcolor text)
 293     (:style (:solid :dashed :dotted :bold :invis))
 294     (:color text)
 295     (:dir (:forward :back :both :none))
 296     (:tailclip boolean)
 297     (:headclip boolean)
 298     (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee
 299                  :empty :invempty :open :halfopen :diamond :odiamond
 300                  :box :obox :crow))
 301     (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee
 302                  :empty :invempty :open :halfopen :diamond :odiamond
 303                  :box :obox :crow))
 304     (:headlabel text)
 305     (:taillabel text)
 306     (:labelfontsize integer)
 307     (:labelfontname text)
 308     (:labelfontcolor text)
 309     (:labeldistance integer)
 310     (:port-label-distance integer)
 311     (:decorate boolean)
 312     (:samehead boolean)
 313     (:sametail boolean)
 314     (:constraint boolean)
 315     (:layer text)))
 316
 317 (defclass* dot-attributes-mixin ()
 318   ((dot-attributes nil ia))
 319   (:export-p t))
 320
 321 (defclass* dot-graph-mixin (dot-attributes-mixin) ()
 322   (:export-p t))
 323 (defclass* dot-vertex-mixin (dot-attributes-mixin) ()
 324   (:export-p t))
 325 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
 326   (:export-p t))
 327
 328 (defclass* dot-graph (graph-container dot-graph-mixin)
 329   ()
 330   (:default-initargs
 331     :vertex-class 'dot-vertex
 332     :directed-edge-class 'dot-directed-edge
 333     :undirected-edge-class 'dot-edge)
 334   (:export-p t))
 335
 336 (defclass* dot-vertex (graph-container-vertex dot-vertex-mixin) ()
 337   (:export-p t))
 338 (defclass* dot-edge (graph-container-edge dot-edge-mixin) ()
 339   (:export-p t))
 340 (defclass* dot-directed-edge (directed-edge-mixin dot-edge) ()
 341   (:export-p t))
 342
 343 (defmethod graph->dot-properties ((graph dot-graph) (stream t))
 344   (loop for (name value) on (dot-attributes graph) by #'cddr
 345         do
 346         (print-dot-key-value name value *dot-graph-attributes* stream)
 347         (format stream "                 ;~%")))
 348
 349 (defmethod vertex->dot ((vertex dot-vertex) (stream t))
 350   (format-dot-attributes vertex *dot-vertex-attributes* stream))
 351
 352 (defmethod edge->dot ((edge dot-edge) (stream t))
 353   (format-dot-attributes edge *dot-edge-attributes* stream))
 354
 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)))
 360
 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
 367               ((member integer)
 368                (unless (typep value 'integer)
 369                  (error "Invalid value for ~S: ~S is not an integer"
 370                         key value))
 371                value)
 372               ((member boolean)
 373                (if value
 374                    "true"
 375                  "false"))
 376               ((member text)
 377                (textify value))
 378               ((member float)
 379                (coerce value 'single-float))
 380               (list
 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))
 384                (if (symbolp value)
 385                    (string-downcase value)
 386                  value))))))
 387
 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.
 394             ;; to work.
 395             (case c
 396               ((#\")
 397                (write-char #\\ stream)
 398                (write-char c stream))
 399               (#\Newline
 400                (write-char #\\ stream)
 401                (write-char #\n stream))
 402               (t
 403                (write-char c stream))))
 404       (write-char #\" stream))))
 405
 406 ;;; ---------------------------------------------------------------------------
 407 ;
 408 ; Calls the dot executable to create external output for graphs
 409 ;
 410 #+(or win32 mswindows)
 411 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
 412 #+(or linux unix)
 413 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
 414
 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)
 422                                       :direction :input))
 423                     (write-line dot-string s)
 424                     (force-output s)
 425                     (close s))
 426     #+sbcl
 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")))
 433
 434 ;;; ---------------------------------------------------------------------------
 435 ;
 436 ; Test dot external
 437 ;
 438 (defun test-dot-external ()
 439   (let* ((g (make-graph 'dot-graph))
 440          (v1 (add-vertex g 'a :dot-attributes '(:shape :box
 441                                                 :color :blue)))
 442          (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
 443                                                 :style :filled
 444                                                 :color :yellow))))
 445     (add-edge-between-vertexes g v1 v2
 446                                :dot-attributes '(:arrowhead :open
 447                                                  :arrowtail :normal
 448                                                  :style :dotted))
 449     (print (graph->dot g nil))
 450     (graph->dot-external g "/tmp/test.gif" :type :gif)))