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