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-labeler 'princ)
  29                        (edge-formatter 'edge->dot)
  30                        &allow-other-keys)
  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     (:dpi float)
 248     (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
 249     (:margin float)
 250     (:nodesep float)
 251     (:ranksep float)
 252     (:ordering (:out))
 253     (:overlap text)
 254     (:rankdir ("LR" "RL" "BT"))
 255     (:pagedir text)
 256     (:rank (:same :min :max))
 257     (:rotate integer)
 258     (:center integer)
 259     (:nslimit float)
 260     (:mclimit float)
 261     (:layers text)
 262     (:color text)
 263     (:bgcolor text)
 264     (:fontname text)))
 265
 266 (defparameter *dot-vertex-attributes*
 267   '((:pos coordinate)
 268     (:height float)
 269     (:width float)
 270     (:margin float)
 271     (:fixed-size boolean)
 272     (:label text)
 273     (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
 274              :diamond :trapezium :parallelogram :house :hexagon :octagon
 275              :doublecircle))
 276     (:fontsize integer)
 277     (:fontname text)
 278     (:fontcolor text)
 279     (:color text)
 280     (:fillcolor text)
 281     (:style (:filled :solid :dashed :dotted :bold :invis))
 282     (:layer text)
 283     (:url text)
 284     (:peripheries integer)))
 285
 286 (defparameter *dot-edge-attributes*
 287   '((:pos spline)
 288     (:minlen integer)
 289     (:weight integer)
 290     (:label text)
 291     (:fontsize integer)
 292     (:fontname text)
 293     (:fontcolor text)
 294     (:style (:solid :dashed :dotted :bold :invis))
 295     (:color text)
 296     (:dir (:forward :back :both :none))
 297     (:tailclip boolean)
 298     (:headclip boolean)
 299     (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee
 300                  :empty :invempty :open :halfopen :diamond :odiamond
 301                  :box :obox :crow))
 302     (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee
 303                  :empty :invempty :open :halfopen :diamond :odiamond
 304                  :box :obox :crow))
 305     (:headlabel text)
 306     (:taillabel text)
 307     (:labelfontsize integer)
 308     (:labelfontname text)
 309     (:labelfontcolor text)
 310     (:labeldistance integer)
 311     (:port-label-distance integer)
 312     (:decorate boolean)
 313     (:samehead boolean)
 314     (:sametail boolean)
 315     (:constraint boolean)
 316     (:layer text)))
 317
 318 (defclass* dot-attributes-mixin ()
 319   ((dot-attributes nil ia))
 320   (:export-p t))
 321
 322 (defclass* dot-graph-mixin (dot-attributes-mixin) ()
 323   (:export-p t)
 324   (:default-initargs
 325     :vertex-class 'dot-vertex
 326     :directed-edge-class 'dot-directed-edge
 327     :undirected-edge-class 'dot-edge))
 328 (defclass* dot-vertex-mixin (dot-attributes-mixin) ()
 329   (:export-p t))
 330 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
 331   (:export-p t))
 332
 333 (defclass* dot-graph (dot-graph-mixin graph-container)
 334   ()
 335   (:export-p t))
 336
 337 (defclass* dot-vertex (dot-vertex-mixin graph-container-vertex) ()
 338   (:export-p t))
 339 (defclass* dot-edge (dot-edge-mixin graph-container-edge) ()
 340   (:export-p t))
 341 (defclass* dot-directed-edge (dot-edge directed-edge-mixin) ()
 342   (:export-p t))
 343
 344
 345 (defmethod (setf dot-attribute-value) :before (value (attr symbol) (thing dot-attributes-mixin))
 346   (declare (ignore value))
 347   (ensure-valid-dot-attribute attr thing))
 348
 349 (defmethod (setf dot-attribute-value) (value (attr symbol) (thing dot-attributes-mixin))
 350   (setf (getf (dot-attributes thing) attr) value))
 351
 352 (defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
 353   (getf (dot-attributes thing) attr))
 354
 355 (defmacro defpixel-inch-accessors (name attr type)
 356   (bind ((actual-name (form-symbol name "-IN-PIXELS")))
 357     `(progn
 358       (export ',actual-name)
 359       (defmethod ,actual-name ((thing ,type))
 360         "Return the attribute in pixels assuming 72 dpi"
 361         (awhen (dot-attribute-value ,attr thing)
 362           (* 72 it)))
 363       (defmethod (setf ,actual-name) (value (thing ,type))
 364         "Set the attribute in pixels assuming 72 dpi"
 365         (setf (dot-attribute-value ,attr thing) (coerce (/ value 72) 'double-float))))))
 366
 367 (defpixel-inch-accessors width :width dot-vertex-mixin)
 368 (defpixel-inch-accessors height :height dot-vertex-mixin)
 369
 370
 371 (defmethod graph->dot-properties ((graph dot-graph-mixin) (stream t))
 372   (loop for (name value) on (dot-attributes graph) by #'cddr
 373         do
 374         (print-dot-key-value name value *dot-graph-attributes* stream)))
 375
 376 (defmethod vertex->dot ((vertex dot-vertex-mixin) (stream t))
 377   (format-dot-attributes vertex *dot-vertex-attributes* stream))
 378
 379 (defmethod edge->dot ((edge dot-edge-mixin) (stream t))
 380   (format-dot-attributes edge *dot-edge-attributes* stream))
 381
 382 (defun format-dot-attributes (object dot-attributes stream)
 383   (loop for (name value) on (dot-attributes object) by #'cddr
 384         for prefix = "" then ", " do
 385         (write-string prefix stream)
 386         (print-dot-key-value name value dot-attributes stream)))
 387
 388 (defmethod ensure-valid-dot-attribute (key (object dot-graph-mixin))
 389   (or (assoc key *dot-graph-attributes*)
 390       (error "Invalid dot graph attribute ~S" key)))
 391
 392 (defmethod ensure-valid-dot-attribute (key (object dot-vertex-mixin))
 393   (or (assoc key *dot-vertex-attributes*)
 394       (error "Invalid dot vertex attribute ~S" key)))
 395
 396 (defmethod ensure-valid-dot-attribute (key (object dot-edge-mixin))
 397   (or (assoc key *dot-edge-attributes*)
 398       (error "Invalid dot edge attribute ~S" key)))
 399
 400 (defun print-dot-key-value (key value dot-attributes stream)
 401   (destructuring-bind (key value-type)
 402       (or (assoc key dot-attributes)
 403           (error "Invalid attribute ~S" key))
 404     (write-name-for-dot key stream)
 405     (format stream "=~a"
 406             (etypecase value-type
 407               ((member coordinate)
 408                (with-output-to-string (str)
 409                  (princ "\"" str)
 410                  (let ((first t))
 411                    (dolist (el value)
 412                      (unless first
 413                        (princ "," str))
 414                      (princ el str)
 415                      (setf first nil)))
 416                  (princ "\"" str)))
 417               ((member spline)
 418                (with-output-to-string (str)
 419                  (princ "\"" str)
 420                  (let ((first t))
 421                    (dolist (el value)
 422                      (unless first
 423                        (princ " " str))
 424                      (princ (first el) str)
 425                      (princ "," str)
 426                      (princ (second el) str)
 427                      (setf first nil)))
 428                  (princ "\"" str)))
 429               ((member bounding-box)
 430                (with-output-to-string (str)
 431                  (princ "\"" str)
 432                  (let ((first t))
 433                    (dolist (el value)
 434                      (unless first
 435                        (princ ", " str))
 436                      (princ (first el) str)
 437                      (princ "," str)
 438                      (princ (second el) str)
 439                      (setf first nil)))
 440                  (princ "\"" str)))
 441               ((member integer)
 442                (unless (typep value 'integer)
 443                  (error "Invalid value for ~S: ~S is not an integer"
 444                         key value))
 445                value)
 446               ((member boolean)
 447                (if value
 448                    "true"
 449                    "false"))
 450               ((member text)
 451                (textify value))
 452               ((member float)
 453                ;; graphviz does not support the 1.2e-3 format
 454                (with-output-to-string (str)
 455                  (format str "~,f" (coerce value 'single-float))))
 456               (list
 457                (unless (member value value-type :test 'equal)
 458                  (error "Invalid value for ~S: ~S is not one of ~S"
 459                         key value value-type))
 460                (if (symbolp value)
 461                    (string-downcase value)
 462                    value))))))
 463
 464 (defmethod write-name-for-dot (attribute stream)
 465   (format stream "~(~A~)" attribute))
 466
 467 (defmethod write-name-for-dot ((attribute (eql :url)) stream)
 468   (format stream "URL"))
 469
 470 (defun textify (object)
 471   (let ((string (princ-to-string object)))
 472     (with-output-to-string (stream)
 473       (write-char #\" stream)
 474       (loop for c across string do
 475             ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
 476             ;; to work.
 477             (case c
 478               ((#\")
 479                (write-char #\\ stream)
 480                (write-char c stream))
 481               (#\Newline
 482                (write-char #\\ stream)
 483                (write-char #\n stream))
 484               (t
 485                (write-char c stream))))
 486       (write-char #\" stream))))
 487
 488 ;;; ---------------------------------------------------------------------------
 489 ;
 490 ; Calls the dot executable to create external output for graphs
 491 ;
 492 #+(or win32 mswindows)
 493 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
 494 #+(or linux unix)
 495 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
 496
 497 (defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
 498   "Generate an external represenation of a graph to a file, by running
 499 the program in *dot-path*."
 500   (let ((dot-string (graph->dot g nil))
 501         (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
 502     #+lispworks (with-open-stream
 503                     (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
 504                                       :direction :input))
 505                     (write-line dot-string s)
 506                     (force-output s)
 507                     (close s))
 508     #+sbcl
 509     (sb-ext:run-program *dot-path*
 510                         (list dot-type "-o" file-name)
 511                         :input (make-string-input-stream dot-string)
 512                         :output *standard-output*)
 513     #-(or sbcl lispworks)
 514     (error "Don't know how to execute a program on this platform")))
 515
 516 ;;; ---------------------------------------------------------------------------
 517 ;
 518 ; Test dot external
 519 ;
 520 (defun test-dot-external ()
 521   (let* ((g (make-graph 'dot-graph))
 522          (v1 (add-vertex g 'a :dot-attributes '(:shape :box
 523                                                 :color :blue)))
 524          (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
 525                                                 :style :filled
 526                                                 :color :yellow))))
 527     (add-edge-between-vertexes g v1 v2
 528                                :dot-attributes '(:arrowhead :open
 529                                                  :arrowtail :normal
 530                                                  :style :dotted))
 531     (print (graph->dot g nil))
 532     (graph->dot-external g "/tmp/test.gif" :type :gif)))