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
 320 (defclass* dot-graph-mixin (dot-attributes-mixin) ())
 321 (defclass* dot-vertex-mixin (dot-attributes-mixin) ())
 322 (defclass* dot-edge-mixin (dot-attributes-mixin) ())
 323
 324 (defclass* dot-graph (graph-container dot-graph-mixin)
 325   ()
 326   (:default-initargs
 327     :vertex-class 'dot-vertex
 328     :directed-edge-class 'dot-edge
 329     :undirected-edge-class 'dot-edge))
 330
 331 (defclass* dot-vertex (graph-container-vertex dot-vertex-mixin) ())
 332 (defclass* dot-edge (graph-container-edge dot-edge-mixin) ())
 333 (defclass* dot-directed-edge (directed-edge-mixin dot-edge) ())
 334
 335 (defmethod graph->dot-properties ((graph dot-graph) (stream t))
 336   (loop for (name value) on (dot-attributes graph) by #'cddr
 337         do
 338         (print-dot-key-value name value *dot-graph-attributes* stream)
 339         (format stream "                 ;~%")))
 340
 341 (defmethod vertex->dot ((vertex dot-vertex) (stream t))
 342   (format-dot-attributes vertex *dot-vertex-attributes* stream))
 343
 344 (defmethod edge->dot ((edge dot-edge) (stream t))
 345   (format-dot-attributes edge *dot-edge-attributes* stream))
 346
 347 (defun format-dot-attributes (object dot-attributes stream)
 348   (loop for (name value) on (dot-attributes object) by #'cddr
 349         for prefix = "" then "," do
 350         (write-string prefix stream)
 351         (print-dot-key-value name value dot-attributes stream)))
 352
 353 (defun print-dot-key-value (key value dot-attributes stream)
 354   (destructuring-bind (key value-type)
 355       (or (assoc key dot-attributes)
 356           (error "Invalid attribute ~S" key))
 357     (format stream "~a=~a" (string-downcase key)
 358             (etypecase value-type
 359               ((member integer)
 360                (unless (typep value 'integer)
 361                  (error "Invalid value for ~S: ~S is not an integer"
 362                         key value))
 363                value)
 364               ((member boolean)
 365                (if value
 366                    "true"
 367                  "false"))
 368               ((member text)
 369                (textify value))
 370               ((member float)
 371                (coerce value 'single-float))
 372               (list
 373                (unless (member value value-type :test 'equal)
 374                  (error "Invalid value for ~S: ~S is not one of ~S"
 375                         key value value-type))
 376                (if (symbolp value)
 377                    (string-downcase value)
 378                  value))))))
 379
 380 (defun textify (object)
 381   (let ((string (princ-to-string object)))
 382     (with-output-to-string (stream)
 383       (write-char #\" stream)
 384       (loop for c across string do
 385             ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
 386             ;; to work.
 387             (case c
 388               ((#\")
 389                (write-char #\\ stream)
 390                (write-char c stream))
 391               (#\Newline
 392                (write-char #\\ stream)
 393                (write-char #\n stream))
 394               (t
 395                (write-char c stream))))
 396       (write-char #\" stream))))
 397
 398 ;;; ---------------------------------------------------------------------------
 399 ;
 400 ; Calls the dot executable to create external output for graphs
 401 ;
 402 #+(or win32 mswindows)
 403 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
 404 #+(or linux unix)
 405 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
 406
 407 (defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
 408   "Generate an external represenation of a graph to a file, by running
 409 the program in *dot-path*."
 410   (let ((dot-string (graph->dot g nil))
 411         (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
 412     #+lispworks (with-open-stream
 413                     (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
 414                                       :direction :input))
 415                     (write-line dot-string s)
 416                     (force-output s)
 417                     (close s))
 418     #+sbcl
 419     (sb-ext:run-program *dot-path*
 420                         (list dot-type "-o" file-name)
 421                         :input (make-string-input-stream dot-string)
 422                         :output *standard-output*)
 423     #-(or sbcl lispworks)
 424     (error "Don't know how to execute a program on this platform")))
 425
 426 ;;; ---------------------------------------------------------------------------
 427 ;
 428 ; Test dot external
 429 ;
 430 (defun test-dot-external ()
 431   (let* ((g (make-graph 'dot-graph))
 432          (v1 (add-vertex g 'a :dot-attributes '(:shape :box
 433                                                 :color :blue)))
 434          (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
 435                                                 :style :filled
 436                                                 :color :yellow))))
 437     (add-edge-between-vertexes g v1 v2
 438                                :dot-attributes '(:arrowhead :open
 439                                                  :arrowtail :normal
 440                                                  :style :dotted))
 441     (print (graph->dot g nil))
 442     (graph->dot-external g "/tmp/test.gif" :type :gif)))