dev/graphviz/graphviz-support.lisp

   1 ;;;-*- Mode: Lisp; Package: metabang.graph -*-
   2
   3 #| simple-header
   4
   5 Author: Gary King, Levente Mészáros, Attila Lendvai
   6
   7 DISCUSSION
   8
   9 This file contains the stuff that does not depend on cl-graphviz.
  10
  11 |#
  12 (in-package #:metabang.graph)
  13
  14 ;;; ---------------------------------------------------------------------------
  15 ;
  16 ; This outputs the graph to string in accordance with the DOT file format.
  17 ; For more information about DOT file format, search the web for "DOTTY" and
  18 ; "GRAPHVIZ".
  19 ;
  20 (defmethod graph->dot ((g basic-graph) (stream stream)
  21                        &key
  22                        (graph-formatter 'graph->dot-properties)
  23                        (vertex-key 'vertex-id)
  24                        (vertex-labeler nil)
  25                        (vertex-formatter 'vertex->dot)
  26                        (edge-labeler 'princ)
  27                        (edge-formatter 'edge->dot)
  28                        &allow-other-keys)
  29   (format stream "~A G {~%graph "
  30           (if (contains-undirected-edge-p g) "graph" "digraph"))
  31   (format stream "[")
  32   (funcall graph-formatter g stream)
  33   (format stream "];")
  34   (terpri stream)
  35
  36   ;; vertex formatting
  37   (iterate-vertexes
  38    g
  39    (lambda (v)
  40      (terpri stream)
  41      (let ((key (if vertex-key (funcall vertex-key v) v)))
  42        (princ key stream)
  43        (princ " [" stream)
  44        (when vertex-labeler
  45          (princ "label=\"" stream)
  46          (funcall vertex-labeler v stream)
  47          (princ "\", " stream))
  48        (funcall vertex-formatter v stream)
  49        (princ "];" stream))))
  50
  51   (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
  52         (directed-edge-tag (when (and (contains-undirected-edge-p g)
  53                                       (contains-directed-edge-p g))
  54                              "dir=forward, ")))
  55     (flet ((format-edge (e connector from to directed?)
  56              (terpri stream)
  57              (princ (funcall vertex-key from) stream)
  58              (princ connector stream)
  59              (princ (funcall vertex-key to) stream)
  60              (princ " [" stream)
  61              (when (and directed? directed-edge-tag)
  62                (princ directed-edge-tag stream))
  63              (when edge-labeler
  64                (princ "label=\"" stream)
  65                (funcall edge-labeler e stream)
  66                (princ "\"," stream))
  67              (funcall edge-formatter e stream)
  68              (princ "];" stream)))
  69       ;; directed edges
  70       (iterate-vertexes
  71        g
  72        (lambda (v)
  73          (iterate-target-edges
  74           v
  75           (lambda (e)
  76             (when (directed-edge-p e)
  77               (format-edge e directed-edge-connector
  78                            (source-vertex e) (target-vertex e) t))))))
  79
  80       ;; undirected edges
  81       (let ((edges (make-container 'simple-associative-container)))
  82         (iterate-vertexes
  83          g
  84          (lambda (v)
  85            ;(spy v)
  86            (iterate-edges
  87             v
  88             (lambda (e)
  89               ;(spy e (undirected-edge-p e) (item-at-1 edges e))
  90               (when (and (undirected-edge-p e)
  91                          (not (item-at-1 edges e)))
  92                 (setf (item-at-1 edges e) t)
  93                 (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
  94
  95   (terpri stream)
  96   (princ "}" stream)
  97
  98   (values g))
  99
 100
 101 #+Test
 102 (let ((g (make-container 'graph-container :default-edge-type :undirected)))
 103   (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
 104         (add-edge-between-vertexes g a b))
 105   (graph->dot g nil))
 106
 107 #+Test
 108 "graph G {
 109 E []
 110 C []
 111 B []
 112 A []
 113 D []
 114 F []
 115 D--E []
 116 E--F []
 117 B--C []
 118 A--B []
 119 B--D []
 120 D--F []
 121 }"
 122
 123 #+Test
 124 (let ((g (make-container 'graph-container :default-edge-type :directed)))
 125   (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
 126         (add-edge-between-vertexes g a b))
 127   (graph->dot g nil))
 128
 129 #+Test
 130 "digraph G {
 131 E []
 132 C []
 133 B []
 134 A []
 135 D []
 136 F []
 137 E->F []
 138 B->C []
 139 B->D []
 140 A->B []
 141 D->E []
 142 D->F []
 143 }"
 144
 145 #+Test
 146 (let ((g (make-container 'graph-container)))
 147   (loop for (a b) in '((d e) (e f) (d f)) do
 148         (add-edge-between-vertexes g a b :edge-type :directed))
 149   (loop for (a b) in '((a b) (b c) (b d)) do
 150         (add-edge-between-vertexes g a b :edge-type :undirected))
 151   (graph->dot g nil))
 152
 153 #+Test
 154 "graph G {
 155 E []
 156 C []
 157 B []
 158 A []
 159 D []
 160 F []
 161 E--F [dir=forward, ]
 162 D--E [dir=forward, ]
 163 D--F [dir=forward, ]
 164 B--C []
 165 A--B []
 166 B--D []
 167 }"
 168
 169 ;;; ---------------------------------------------------------------------------
 170
 171 (defmethod graph->dot ((g basic-graph) (stream (eql nil))
 172                        &rest args &key &allow-other-keys)
 173   (declare (dynamic-extent args))
 174   (with-output-to-string (out)
 175     (apply #'graph->dot g out args)))
 176
 177 ;;; ---------------------------------------------------------------------------
 178
 179 (defmethod graph->dot ((g basic-graph) (stream (eql t))
 180                        &rest args &key &allow-other-keys)
 181   (declare (dynamic-extent args))
 182   (apply #'graph->dot g *standard-output* args))
 183
 184 ;;; ---------------------------------------------------------------------------
 185
 186 (defmethod graph->dot ((g basic-graph) (stream string)
 187                        &rest args &key &allow-other-keys)
 188   (declare (dynamic-extent args))
 189   (with-open-file (out stream :direction :output :if-exists :supersede)
 190     (apply #'graph->dot g out args)))
 191
 192 ;;; ---------------------------------------------------------------------------
 193
 194 (defmethod graph->dot ((g basic-graph) (stream pathname)
 195                        &rest args &key &allow-other-keys)
 196   (declare (dynamic-extent args))
 197   (apply #'graph->dot g (namestring stream) args))
 198
 199 ;;; ---------------------------------------------------------------------------
 200
 201 (defmethod graph->dot-properties ((g t) (stream t))
 202   (values))
 203
 204 ;;; ---------------------------------------------------------------------------
 205
 206 (defmethod vertex->dot ((v basic-vertex) (stream stream))
 207   (values))
 208
 209 ;;; ---------------------------------------------------------------------------
 210
 211 (defmethod edge->dot ((v basic-edge) (stream stream))
 212   (values))
 213
 214 ;;; ---------------------------------------------------------------------------
 215 ;;; dot->graph
 216 ;;; ---------------------------------------------------------------------------
 217
 218 #|
 219 (defmethod dot->graph ((dot-stream stream)
 220                        &key)
 221   )
 222
 223 ;;; ---------------------------------------------------------------------------
 224
 225 (defmethod dot->graph ((dot-stream string)
 226                        &rest args &key &allow-other-keys)
 227   (declare (dynamic-extent args))
 228   (with-open-file (out stream :direction :output :if-exists :supersede)
 229     (apply #'dot->graph g out args)))
 230
 231 ;;; ---------------------------------------------------------------------------
 232
 233 (defmethod dot->graph ((dot-stream pathname)
 234                        &rest args &key &allow-other-keys)
 235   (declare (dynamic-extent args))
 236   (with-open-file (out stream :direction :output :if-exists :supersede)
 237     (apply #'dot->graph g out args))
 238   (apply #'dot->graph g (namestring stream) args))
 239
 240 |#
 241
 242 (defparameter *dot-graph-attributes*
 243   '((:size coordinate)
 244     (:bb bounding-box)
 245     (:page text)
 246     (:dpi float)
 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     (:overlap text)
 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     (:fontname text)))
 264
 265 (defparameter *dot-vertex-attributes*
 266   '((:pos coordinate)
 267     (:height float)
 268     (:width float)
 269     (:margin float)
 270     (:fixed-size boolean)
 271     (:label text)
 272     (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
 273              :diamond :trapezium :parallelogram :house :hexagon :octagon
 274              :doublecircle))
 275     (:fontsize integer)
 276     (:fontname text)
 277     (:fontcolor text)
 278     (:color text)
 279     (:fillcolor text)
 280     (:style (:filled :solid :dashed :dotted :bold :invis))
 281     (:layer text)
 282     (:url text)
 283     (:peripheries integer)))
 284
 285 (defparameter *dot-edge-attributes*
 286   '((:pos spline)
 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   (:default-initargs
 324     :vertex-class 'dot-vertex
 325     :directed-edge-class 'dot-directed-edge
 326     :undirected-edge-class 'dot-edge))
 327 (defclass* dot-vertex-mixin (dot-attributes-mixin) ()
 328   (:export-p t))
 329 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
 330   (:export-p t))
 331
 332 (defclass* dot-graph (dot-graph-mixin graph-container)
 333   ()
 334   (:export-p t))
 335
 336 (defclass* dot-vertex (dot-vertex-mixin graph-container-vertex) ()
 337   (:export-p t))
 338 (defclass* dot-edge (dot-edge-mixin graph-container-edge) ()
 339   (:export-p t))
 340 (defclass* dot-directed-edge (dot-edge directed-edge-mixin) ()
 341   (:export-p t))
 342
 343
 344 (defmethod (setf dot-attribute-value) :before (value (attr symbol) (thing dot-attributes-mixin))
 345   (declare (ignore value))
 346   (ensure-valid-dot-attribute attr thing))
 347
 348 (defmethod (setf dot-attribute-value) (value (attr symbol) (thing dot-attributes-mixin))
 349   (setf (getf (dot-attributes thing) attr) value))
 350
 351 (defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
 352   (getf (dot-attributes thing) attr))
 353
 354 (defmacro defpixel-inch-accessors (name attr type)
 355   (bind ((actual-name (form-symbol name "-IN-PIXELS")))
 356     `(progn
 357        (eval-always (export ',actual-name))
 358       (defmethod ,actual-name ((thing ,type))
 359         "Return the attribute in pixels assuming 72 dpi"
 360         (when (dot-attribute-value ,attr thing)
 361           (* 72 (dot-attribute-value ,attr thing))))
 362       (defmethod (setf ,actual-name) (value (thing ,type))
 363         "Set the attribute in pixels assuming 72 dpi"
 364         (setf (dot-attribute-value ,attr thing)
 365               (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   (declare (ignorable file-name))
 501   (let ((dot-string (graph->dot g nil))
 502         (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
 503     (declare (ignorable dot-string dot-type))
 504     #+lispworks (with-open-stream
 505                     (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
 506                                       :direction :input))
 507                     (write-line dot-string s)
 508                     (force-output s)
 509                     (close s))
 510     #+sbcl
 511     (sb-ext:run-program *dot-path*
 512                         (list dot-type "-o" file-name)
 513                         :input (make-string-input-stream dot-string)
 514                         :output *standard-output*)
 515     #-(or sbcl lispworks)
 516     (error "Don't know how to execute a program on this platform")))
 517
 518 ;;; ---------------------------------------------------------------------------
 519 ;
 520 ; Test dot external
 521 ;
 522 (defun test-dot-external ()
 523   (let* ((g (make-graph 'dot-graph))
 524          (v1 (add-vertex g 'a :dot-attributes '(:shape :box
 525                                                 :color :blue)))
 526          (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
 527                                                 :style :filled
 528                                                 :color :yellow))))
 529     (add-edge-between-vertexes g v1 v2
 530                                :dot-attributes '(:arrowhead :open
 531                                                  :arrowtail :normal
 532                                                  :style :dotted))
 533     (print (graph->dot g nil))
 534     (graph->dot-external g "/tmp/test.gif" :type :gif)))