dev/graphviz/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 Author: Gary King, Levente Mészáros, Attila Lendvai
   8
   9 DISCUSSION
  10
  11 This file contains the stuff that does not depend on cl-graphviz.
  12
  13 |#
  14 (in-package #:metabang.graph)
  15
  16 ;;; ---------------------------------------------------------------------------
  17 ;
  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
  20 ; "GRAPHVIZ".
  21 ;
  22 (defmethod graph->dot ((g basic-graph) (stream stream)
  23                        &key
  24                        (graph-formatter 'graph->dot-properties)
  25                        (vertex-key 'vertex-id)
  26                        (vertex-labeler nil)
  27                        (vertex-formatter 'vertex->dot)
  28                        (edge-key nil)
  29                        (edge-labeler 'princ)
  30                        (edge-formatter 'edge->dot))
  31   (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
  32   (format stream "[")
  33   (funcall graph-formatter g stream)
  34   (format stream "];")
  35   (terpri stream)
  36
  37   ;; vertex formatting
  38   (iterate-vertexes
  39    g
  40    (lambda (v)
  41      (terpri stream)
  42      (let ((key (if vertex-key (funcall vertex-key v) v)))
  43        (princ key stream)
  44        (princ " [" stream)
  45        (when vertex-labeler
  46          (princ "label=\"" stream)
  47          (funcall vertex-labeler v stream)
  48          (princ "\", " stream))
  49        (funcall vertex-formatter v stream)
  50        (princ "];" stream))))
  51
  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))
  55                              "dir=forward, ")))
  56     (flet ((format-edge (e connector from to directed?)
  57              (terpri stream)
  58              (princ (funcall vertex-key from) stream)
  59              (princ connector stream)
  60              (princ (funcall vertex-key to) stream)
  61              (princ " [" stream)
  62              (when (and directed? directed-edge-tag)
  63                (princ directed-edge-tag stream))
  64              (when edge-labeler
  65                (princ "label=\"" stream)
  66                (funcall edge-labeler e stream)
  67                (princ "\"," stream))
  68              (funcall edge-formatter e stream)
  69              (princ "];" stream)))
  70       ;; directed edges
  71       (iterate-vertexes
  72        g
  73        (lambda (v)
  74          (iterate-target-edges
  75           v
  76           (lambda (e)
  77             (when (directed-edge-p e)
  78               (format-edge e directed-edge-connector
  79                            (source-vertex e) (target-vertex e) t))))))
  80
  81       ;; undirected edges
  82       (let ((edges (make-container 'simple-associative-container)))
  83         (iterate-vertexes
  84          g
  85          (lambda (v)
  86            ;(spy v)
  87            (iterate-edges
  88             v
  89             (lambda (e)
  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)))))))))
  95
  96   (terpri stream)
  97   (princ "}" stream)
  98
  99   (values g))
 100
 101
 102 #+Test
 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))
 106   (graph->dot g nil))
 107
 108 #+Test
 109 "graph G {
 110 E []
 111 C []
 112 B []
 113 A []
 114 D []
 115 F []
 116 D--E []
 117 E--F []
 118 B--C []
 119 A--B []
 120 B--D []
 121 D--F []
 122 }"
 123
 124 #+Test
 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))
 128   (graph->dot g nil))
 129
 130 #+Test
 131 "digraph G {
 132 E []
 133 C []
 134 B []
 135 A []
 136 D []
 137 F []
 138 E->F []
 139 B->C []
 140 B->D []
 141 A->B []
 142 D->E []
 143 D->F []
 144 }"
 145
 146 #+Test
 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))
 152   (graph->dot g nil))
 153
 154 #+Test
 155 "graph G {
 156 E []
 157 C []
 158 B []
 159 A []
 160 D []
 161 F []
 162 E--F [dir=forward, ]
 163 D--E [dir=forward, ]
 164 D--F [dir=forward, ]
 165 B--C []
 166 A--B []
 167 B--D []
 168 }"
 169
 170 ;;; ---------------------------------------------------------------------------
 171
 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)))
 177
 178 ;;; ---------------------------------------------------------------------------
 179
 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))
 184
 185 ;;; ---------------------------------------------------------------------------
 186
 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)))
 192
 193 ;;; ---------------------------------------------------------------------------
 194
 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))
 199
 200 ;;; ---------------------------------------------------------------------------
 201
 202 (defmethod graph->dot-properties ((g t) (stream t))
 203   (values))
 204
 205 ;;; ---------------------------------------------------------------------------
 206
 207 (defmethod vertex->dot ((v basic-vertex) (stream stream))
 208   (values))
 209
 210 ;;; ---------------------------------------------------------------------------
 211
 212 (defmethod edge->dot ((v basic-edge) (stream stream))
 213   (values))
 214
 215 ;;; ---------------------------------------------------------------------------
 216 ;;; dot->graph
 217 ;;; ---------------------------------------------------------------------------
 218
 219 #|
 220 (defmethod dot->graph ((dot-stream stream)
 221                        &key)
 222   )
 223
 224 ;;; ---------------------------------------------------------------------------
 225
 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)))
 231
 232 ;;; ---------------------------------------------------------------------------
 233
 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))
 240
 241 |#
 242
 243 (defparameter *dot-graph-attributes*
 244   '((:size coordinate)
 245     (:bb bounding-box)
 246     (:page text)
 247     (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
 248     (:margin float)
 249     (:nodesep float)
 250     (:ranksep float)
 251     (:ordering (:out))
 252     (:rankdir ("LR" "RL" "BT"))
 253     (:pagedir text)
 254     (:rank (:same :min :max))
 255     (:rotate integer)
 256     (:center integer)
 257     (:nslimit float)
 258     (:mclimit float)
 259     (:layers text)
 260     (:color text)
 261     (:bgcolor text)))
 262
 263 (defparameter *dot-vertex-attributes*
 264   '((:pos coordinate)
 265     (:height float)
 266     (:width float)
 267     (:fixed-size boolean)
 268     (:label text)
 269     (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
 270              :diamond :trapezium :parallelogram :house :hexagon :octagon
 271              :doublecircle))
 272     (:fontsize integer)
 273     (:fontname text)
 274     (:fontcolor text)
 275     (:color text)
 276     (:fillcolor text)
 277     (:style (:filled :solid :dashed :dotted :bold :invis))
 278     (:layer text)
 279     (:url text)))
 280
 281 (defparameter *dot-edge-attributes*
 282   '((:pos spline)
 283     (:minlen integer)
 284     (:weight integer)
 285     (:label text)
 286     (:fontsize integer)
 287     (:fontname text)
 288     (:fontcolor text)
 289     (:style (:solid :dashed :dotted :bold :invis))
 290     (:color text)
 291     (:dir (:forward :back :both :none))
 292     (:tailclip boolean)
 293     (:headclip boolean)
 294     (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee
 295                  :empty :invempty :open :halfopen :diamond :odiamond
 296                  :box :obox :crow))
 297     (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee
 298                  :empty :invempty :open :halfopen :diamond :odiamond
 299                  :box :obox :crow))
 300     (:headlabel text)
 301     (:taillabel text)
 302     (:labelfontsize integer)
 303     (:labelfontname text)
 304     (:labelfontcolor text)
 305     (:labeldistance integer)
 306     (:port-label-distance integer)
 307     (:decorate boolean)
 308     (:samehead boolean)
 309     (:sametail boolean)
 310     (:constraint boolean)
 311     (:layer text)))
 312
 313 (defclass* dot-attributes-mixin ()
 314   ((dot-attributes nil ia))
 315   (:export-p t))
 316
 317 (defclass* dot-graph-mixin (dot-attributes-mixin) ()
 318   (:export-p t)
 319   (:default-initargs
 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) ()
 324   (:export-p t))
 325 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
 326   (:export-p t))
 327
 328 (defclass* dot-graph (dot-graph-mixin graph-container)
 329   ()
 330   (:export-p t))
 331
 332 (defclass* dot-vertex (dot-vertex-mixin graph-container-vertex) ()
 333   (:export-p t))
 334 (defclass* dot-edge (dot-edge-mixin graph-container-edge) ()
 335   (:export-p t))
 336 (defclass* dot-directed-edge (dot-edge directed-edge-mixin) ()
 337   (:export-p t))
 338
 339
 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))
 343
 344 (defmethod (setf dot-attribute-value) (value (attr symbol) (thing dot-attributes-mixin))
 345   (setf (getf (dot-attributes thing) attr) value))
 346
 347 (defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
 348   (getf (dot-attributes thing) attr))
 349
 350 (defmethod graph->dot-properties ((graph dot-graph-mixin) (stream t))
 351   (loop for (name value) on (dot-attributes graph) by #'cddr
 352         do
 353         (print-dot-key-value name value *dot-graph-attributes* stream)))
 354
 355 (defmethod vertex->dot ((vertex dot-vertex-mixin) (stream t))
 356   (format-dot-attributes vertex *dot-vertex-attributes* stream))
 357
 358 (defmethod edge->dot ((edge dot-edge-mixin) (stream t))
 359   (format-dot-attributes edge *dot-edge-attributes* stream))
 360
 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)))
 366
 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)))
 370
 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)))
 374
 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)))
 378
 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)
 384     (format stream "=~a"
 385             (etypecase value-type
 386               ((member coordinate)
 387                (with-output-to-string (str)
 388                  (princ "\"" str)
 389                  (let ((first t))
 390                    (dolist (el value)
 391                      (unless first
 392                        (princ "," str))
 393                      (princ el str)
 394                      (setf first nil)))
 395                  (princ "\"" str)))
 396               ((member spline)
 397                (with-output-to-string (str)
 398                  (princ "\"" str)
 399                  (let ((first t))
 400                    (dolist (el value)
 401                      (unless first
 402                        (princ " " str))
 403                      (princ (first el) str)
 404                      (princ "," str)
 405                      (princ (second el) str)
 406                      (setf first nil)))
 407                  (princ "\"" str)))
 408               ((member bounding-box)
 409                (with-output-to-string (str)
 410                  (princ "\"" str)
 411                  (let ((first t))
 412                    (dolist (el value)
 413                      (unless first
 414                        (princ ", " str))
 415                      (princ (first el) str)
 416                      (princ "," str)
 417                      (princ (second el) str)
 418                      (setf first nil)))
 419                  (princ "\"" str)))
 420               ((member integer)
 421                (unless (typep value 'integer)
 422                  (error "Invalid value for ~S: ~S is not an integer"
 423                         key value))
 424                value)
 425               ((member boolean)
 426                (if value
 427                    "true"
 428                    "false"))
 429               ((member text)
 430                (textify value))
 431               ((member float)
 432                (coerce value 'single-float))
 433               (list
 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))
 437                (if (symbolp value)
 438                    (string-downcase value)
 439                    value))))))
 440
 441 (defmethod write-name-for-dot (attribute stream)
 442   (format stream "~(~A~)" attribute))
 443
 444 (defmethod write-name-for-dot ((attribute (eql :url)) stream)
 445   (format stream "URL"))
 446
 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.
 453             ;; to work.
 454             (case c
 455               ((#\")
 456                (write-char #\\ stream)
 457                (write-char c stream))
 458               (#\Newline
 459                (write-char #\\ stream)
 460                (write-char #\n stream))
 461               (t
 462                (write-char c stream))))
 463       (write-char #\" stream))))
 464
 465 ;;; ---------------------------------------------------------------------------
 466 ;
 467 ; Calls the dot executable to create external output for graphs
 468 ;
 469 #+(or win32 mswindows)
 470 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
 471 #+(or linux unix)
 472 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
 473
 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)
 481                                       :direction :input))
 482                     (write-line dot-string s)
 483                     (force-output s)
 484                     (close s))
 485     #+sbcl
 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")))
 492
 493 ;;; ---------------------------------------------------------------------------
 494 ;
 495 ; Test dot external
 496 ;
 497 (defun test-dot-external ()
 498   (let* ((g (make-graph 'dot-graph))
 499          (v1 (add-vertex g 'a :dot-attributes '(:shape :box
 500                                                 :color :blue)))
 501          (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
 502                                                 :style :filled
 503                                                 :color :yellow))))
 504     (add-edge-between-vertexes g v1 v2
 505                                :dot-attributes '(:arrowhead :open
 506                                                  :arrowtail :normal
 507                                                  :style :dotted))
 508     (print (graph->dot g nil))
 509     (graph->dot-external g "/tmp/test.gif" :type :gif)))