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)
 345     :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)
 350     (value (attr symbol) (thing dot-attributes-mixin))
 351   (setf (getf (dot-attributes thing) attr) value))
 352
 353 (defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
 354   (getf (dot-attributes thing) attr))
 355
 356 (defmacro defpixel-inch-accessors (name attr type)
 357   (let ((actual-name (form-symbol name "-IN-PIXELS")))
 358     `(progn
 359        (eval-always (export ',actual-name))
 360       (defmethod ,actual-name ((thing ,type))
 361         "Return the attribute in pixels assuming 72 dpi"
 362         (when (dot-attribute-value ,attr thing)
 363           (* 72 (dot-attribute-value ,attr thing))))
 364       (defmethod (setf ,actual-name) (value (thing ,type))
 365         "Set the attribute in pixels assuming 72 dpi"
 366         (setf (dot-attribute-value ,attr thing)
 367               (coerce (/ value 72) 'double-float))))))
 368
 369 (defpixel-inch-accessors width :width dot-vertex-mixin)
 370 (defpixel-inch-accessors height :height dot-vertex-mixin)
 371
 372
 373 (defmethod graph->dot-properties ((graph dot-graph-mixin) (stream t))
 374   (loop for (name value) on (dot-attributes graph) by #'cddr
 375         do
 376         (print-dot-key-value name value *dot-graph-attributes* stream)))
 377
 378 (defmethod vertex->dot ((vertex dot-vertex-mixin) (stream t))
 379   (format-dot-attributes vertex *dot-vertex-attributes* stream))
 380
 381 (defmethod edge->dot ((edge dot-edge-mixin) (stream t))
 382   (format-dot-attributes edge *dot-edge-attributes* stream))
 383
 384 (defun format-dot-attributes (object dot-attributes stream)
 385   (loop for (name value) on (dot-attributes object) by #'cddr
 386         for prefix = "" then ", " do
 387         (write-string prefix stream)
 388         (print-dot-key-value name value dot-attributes stream)))
 389
 390 (defmethod ensure-valid-dot-attribute (key (object dot-graph-mixin))
 391   (or (assoc key *dot-graph-attributes*)
 392       (error "Invalid dot graph attribute ~S" key)))
 393
 394 (defmethod ensure-valid-dot-attribute (key (object dot-vertex-mixin))
 395   (or (assoc key *dot-vertex-attributes*)
 396       (error "Invalid dot vertex attribute ~S" key)))
 397
 398 (defmethod ensure-valid-dot-attribute (key (object dot-edge-mixin))
 399   (or (assoc key *dot-edge-attributes*)
 400       (error "Invalid dot edge attribute ~S" key)))
 401
 402 (defun print-dot-key-value (key value dot-attributes stream)
 403   (destructuring-bind (key value-type)
 404       (or (assoc key dot-attributes)
 405           (error "Invalid attribute ~S" key))
 406     (write-name-for-dot key stream)
 407     (format stream "=~a"
 408             (etypecase value-type
 409               ((member coordinate)
 410                (with-output-to-string (str)
 411                  (princ "\"" str)
 412                  (let ((first t))
 413                    (dolist (el value)
 414                      (unless first
 415                        (princ "," str))
 416                      (princ el str)
 417                      (setf first nil)))
 418                  (princ "\"" str)))
 419               ((member spline)
 420                (with-output-to-string (str)
 421                  (princ "\"" str)
 422                  (let ((first t))
 423                    (dolist (el value)
 424                      (unless first
 425                        (princ " " str))
 426                      (princ (first el) str)
 427                      (princ "," str)
 428                      (princ (second el) str)
 429                      (setf first nil)))
 430                  (princ "\"" str)))
 431               ((member bounding-box)
 432                (with-output-to-string (str)
 433                  (princ "\"" str)
 434                  (let ((first t))
 435                    (dolist (el value)
 436                      (unless first
 437                        (princ ", " str))
 438                      (princ (first el) str)
 439                      (princ "," str)
 440                      (princ (second el) str)
 441                      (setf first nil)))
 442                  (princ "\"" str)))
 443               ((member integer)
 444                (unless (typep value 'integer)
 445                  (error "Invalid value for ~S: ~S is not an integer"
 446                         key value))
 447                value)
 448               ((member boolean)
 449                (if value
 450                    "true"
 451                    "false"))
 452               ((member text)
 453                (textify value))
 454               ((member float)
 455                ;; graphviz does not support the 1.2e-3 format
 456                (with-output-to-string (str)
 457                  (format str "~,f" (coerce value 'single-float))))
 458               (list
 459                (unless (member value value-type :test 'equal)
 460                  (error "Invalid value for ~S: ~S is not one of ~S"
 461                         key value value-type))
 462                (if (symbolp value)
 463                    (string-downcase value)
 464                    value))))))
 465
 466 (defmethod write-name-for-dot (attribute stream)
 467   (format stream "~(~A~)" attribute))
 468
 469 (defmethod write-name-for-dot ((attribute (eql :url)) stream)
 470   (format stream "URL"))
 471
 472 (defun textify (object)
 473   (let ((string (princ-to-string object)))
 474     (with-output-to-string (stream)
 475       (write-char #\" stream)
 476       (loop for c across string do
 477             ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
 478             ;; to work.
 479             (case c
 480               ((#\")
 481                (write-char #\\ stream)
 482                (write-char c stream))
 483               (#\Newline
 484                (write-char #\\ stream)
 485                (write-char #\n stream))
 486               (t
 487                (write-char c stream))))
 488       (write-char #\" stream))))
 489
 490 ;;; ---------------------------------------------------------------------------
 491 ;
 492 ; Calls the dot executable to create external output for graphs
 493 ;
 494 #+(or win32 mswindows)
 495 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
 496 #+(or linux unix)
 497 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
 498
 499 (defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
 500   "Generate an external represenation of a graph to a file, by running
 501 the program in *dot-path*."
 502   (declare (ignorable file-name))
 503   (let ((dot-string (graph->dot g nil))
 504         (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
 505     (declare (ignorable dot-string dot-type))
 506     #+lispworks (with-open-stream
 507                     (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
 508                                       :direction :input))
 509                     (write-line dot-string s)
 510                     (force-output s)
 511                     (close s))
 512     #+sbcl
 513     (sb-ext:run-program *dot-path*
 514                         (list dot-type "-o" file-name)
 515                         :input (make-string-input-stream dot-string)
 516                         :output *standard-output*)
 517     #-(or sbcl lispworks)
 518     (error "Don't know how to execute a program on this platform")))
 519
 520 ;;;
 521 ; Test dot external
 522
 523 #+test
 524 (defun test-dot-external ()
 525   (let* ((g (make-graph 'dot-graph))
 526          (v1 (add-vertex g 'a :dot-attributes '(:shape :box
 527                                                 :color :blue)))
 528          (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
 529                                                 :style :filled
 530                                                 :color :yellow))))
 531     (add-edge-between-vertexes g v1 v2
 532                                :dot-attributes '(:arrowhead :open
 533                                                  :arrowtail :normal
 534                                                  :style :dotted))
 535     (print (graph->dot g nil))
 536     (graph->dot-external g "/tmp/test.gif" :type :gif)))