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 Copyright 1992 - 2005 Experimental Knowledge Systems Lab,
   8 University of Massachusetts Amherst MA, 01003-4610
   9 Professor Paul Cohen, Director
  10
  11 Author: Gary King, Levente Mészáros, Attila Lendvai
  12
  13 DISCUSSION
  14
  15 This file contains the stuff that does not depend on cl-graphviz.
  16
  17 |#
  18 (in-package metabang.graph)
  19
  20 (export '(
  21           print-dot-key-value
  22           dot-attribute-value
  23           dot-attributes-mixin
  24           *dot-graph-attributes*
  25           ))
  26
  27 ;;; ---------------------------------------------------------------------------
  28 ;
  29 ; This outputs the graph to string in accordance with the DOT file format.
  30 ; For more information about DOT file format, search the web for "DOTTY" and
  31 ; "GRAPHVIZ".
  32 ;
  33 (defmethod graph->dot ((g basic-graph) (stream stream)
  34                        &key
  35                        (graph-formatter 'graph->dot-properties)
  36                        (vertex-key 'vertex-id)
  37                        (vertex-labeler nil)
  38                        (vertex-formatter 'vertex->dot)
  39                        (edge-key nil)
  40                        (edge-labeler 'princ)
  41                        (edge-formatter 'edge->dot))
  42   (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
  43   (format stream "[")
  44   (funcall graph-formatter g stream)
  45   (format stream "];")
  46   (terpri stream)
  47
  48   ;; vertex formatting
  49   (iterate-vertexes
  50    g
  51    (lambda (v)
  52      (terpri stream)
  53      (let ((key (if vertex-key (funcall vertex-key v) v)))
  54        (princ key stream)
  55        (princ " [" stream)
  56        (when vertex-labeler
  57          (princ "label=\"" stream)
  58          (funcall vertex-labeler v stream)
  59          (princ "\", " stream))
  60        (funcall vertex-formatter v stream)
  61        (princ "];" stream))))
  62
  63   (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
  64         (directed-edge-tag (when (and (contains-undirected-edge-p g)
  65                                       (contains-directed-edge-p g))
  66                              "dir=forward, ")))
  67     (flet ((format-edge (e connector from to directed?)
  68              (terpri stream)
  69              (princ (funcall vertex-key from) stream)
  70              (princ connector stream)
  71              (princ (funcall vertex-key to) stream)
  72              (princ " [" stream)
  73              (when (and directed? directed-edge-tag)
  74                (princ directed-edge-tag stream))
  75              (when edge-key
  76                (princ "label=\"" stream)
  77                (funcall edge-labeler e stream)
  78                (princ "\"," stream))
  79              (funcall edge-formatter e stream)
  80              (princ "];" stream)))
  81       ;; directed edges
  82       (iterate-vertexes
  83        g
  84        (lambda (v)
  85          (iterate-target-edges
  86           v
  87           (lambda (e)
  88             (when (directed-edge-p e)
  89               (format-edge e directed-edge-connector
  90                            (source-vertex e) (target-vertex e) t))))))
  91
  92       ;; undirected edges
  93       (let ((edges (make-container 'simple-associative-container)))
  94         (iterate-vertexes
  95          g
  96          (lambda (v)
  97            (iterate-edges
  98             v
  99             (lambda (e)
 100               (when (and (undirected-edge-p e)
 101                          (not (item-at-1 edges e)))
 102                 (setf (item-at-1 edges e) t)
 103                 (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
 104
 105   (terpri stream)
 106   (princ "}" stream)
 107
 108   (values g))
 109
 110
 111 #+Test
 112 (let ((g (make-container 'graph-container :default-edge-type :undirected)))
 113   (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
 114         (add-edge-between-vertexes g a b))
 115   (graph->dot g nil))
 116
 117 #+Test
 118 "graph G {
 119 E []
 120 C []
 121 B []
 122 A []
 123 D []
 124 F []
 125 D--E []
 126 E--F []
 127 B--C []
 128 A--B []
 129 B--D []
 130 D--F []
 131 }"
 132
 133 #+Test
 134 (let ((g (make-container 'graph-container :default-edge-type :directed)))
 135   (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
 136         (add-edge-between-vertexes g a b))
 137   (graph->dot g nil))
 138
 139 #+Test
 140 "digraph G {
 141 E []
 142 C []
 143 B []
 144 A []
 145 D []
 146 F []
 147 E->F []
 148 B->C []
 149 B->D []
 150 A->B []
 151 D->E []
 152 D->F []
 153 }"
 154
 155 #+Test
 156 (let ((g (make-container 'graph-container)))
 157   (loop for (a b) in '((d e) (e f) (d f)) do
 158         (add-edge-between-vertexes g a b :edge-type :directed))
 159   (loop for (a b) in '((a b) (b c) (b d)) do
 160         (add-edge-between-vertexes g a b :edge-type :undirected))
 161   (graph->dot g nil))
 162
 163 #+Test
 164 "graph G {
 165 E []
 166 C []
 167 B []
 168 A []
 169 D []
 170 F []
 171 E--F [dir=forward, ]
 172 D--E [dir=forward, ]
 173 D--F [dir=forward, ]
 174 B--C []
 175 A--B []
 176 B--D []
 177 }"
 178
 179 ;;; ---------------------------------------------------------------------------
 180
 181 (defmethod graph->dot ((g basic-graph) (stream (eql nil))
 182                        &rest args &key &allow-other-keys)
 183   (declare (dynamic-extent args))
 184   (with-output-to-string (out)
 185     (apply #'graph->dot g out args)))
 186
 187 ;;; ---------------------------------------------------------------------------
 188
 189 (defmethod graph->dot ((g basic-graph) (stream (eql t))
 190                        &rest args &key &allow-other-keys)
 191   (declare (dynamic-extent args))
 192   (apply #'graph->dot g *standard-output* args))
 193
 194 ;;; ---------------------------------------------------------------------------
 195
 196 (defmethod graph->dot ((g basic-graph) (stream string)
 197                        &rest args &key &allow-other-keys)
 198   (declare (dynamic-extent args))
 199   (with-open-file (out stream :direction :output :if-exists :supersede)
 200     (apply #'graph->dot g out args)))
 201
 202 ;;; ---------------------------------------------------------------------------
 203
 204 (defmethod graph->dot ((g basic-graph) (stream pathname)
 205                        &rest args &key &allow-other-keys)
 206   (declare (dynamic-extent args))
 207   (apply #'graph->dot g (namestring stream) args))
 208
 209 ;;; ---------------------------------------------------------------------------
 210
 211 (defmethod graph->dot-properties ((g t) (stream t))
 212   (values))
 213
 214 ;;; ---------------------------------------------------------------------------
 215
 216 (defmethod vertex->dot ((v basic-vertex) (stream stream))
 217   (values))
 218
 219 ;;; ---------------------------------------------------------------------------
 220
 221 (defmethod edge->dot ((v basic-edge) (stream stream))
 222   (values))
 223
 224 ;;; ---------------------------------------------------------------------------
 225 ;;; dot->graph
 226 ;;; ---------------------------------------------------------------------------
 227
 228 #|
 229 (defmethod dot->graph ((dot-stream stream)
 230                        &key)
 231   )
 232
 233 ;;; ---------------------------------------------------------------------------
 234
 235 (defmethod dot->graph ((dot-stream string)
 236                        &rest args &key &allow-other-keys)
 237   (declare (dynamic-extent args))
 238   (with-open-file (out stream :direction :output :if-exists :supersede)
 239     (apply #'dot->graph g out args)))
 240
 241 ;;; ---------------------------------------------------------------------------
 242
 243 (defmethod dot->graph ((dot-stream pathname)
 244                        &rest args &key &allow-other-keys)
 245   (declare (dynamic-extent args))
 246   (with-open-file (out stream :direction :output :if-exists :supersede)
 247     (apply #'dot->graph g out args))
 248   (apply #'dot->graph g (namestring stream) args))
 249
 250 |#
 251
 252 (defparameter *dot-graph-attributes*
 253   '((:size coordinate)
 254     (:bb bounding-box)
 255     (:page text)
 256     (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
 257     (:margin float)
 258     (:nodesep float)
 259     (:ranksep float)
 260     (:ordering (:out))
 261     (:rankdir ("LR" "RL" "BT"))
 262     (:pagedir text)
 263     (:rank (:same :min :max))
 264     (:rotate integer)
 265     (:center integer)
 266     (:nslimit float)
 267     (:mclimit float)
 268     (:layers text)
 269     (:color text)
 270     (:bgcolor text)))
 271
 272 (defparameter *dot-vertex-attributes*
 273   '((:pos coordinate)
 274     (:height float)
 275     (:width float)
 276     (:fixed-size boolean)
 277     (:label text)
 278     (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
 279              :diamond :trapezium :parallelogram :house :hexagon :octagon
 280              :doublecircle))
 281     (:fontsize integer)
 282     (:fontname text)
 283     (:fontcolor text)
 284     (:color text)
 285     (:fillcolor text)
 286     (:style (:filled :solid :dashed :dotted :bold :invis))
 287     (:layer text)
 288     (:url text)))
 289
 290 (defparameter *dot-edge-attributes*
 291   '((:pos spline)
 292     (:minlen integer)
 293     (:weight integer)
 294     (:label text)
 295     (:fontsize integer)
 296     (:fontname text)
 297     (:fontcolor text)
 298     (:style (:solid :dashed :dotted :bold :invis))
 299     (:color text)
 300     (:dir (:forward :back :both :none))
 301     (:tailclip boolean)
 302     (:headclip boolean)
 303     (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee
 304                  :empty :invempty :open :halfopen :diamond :odiamond
 305                  :box :obox :crow))
 306     (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee
 307                  :empty :invempty :open :halfopen :diamond :odiamond
 308                  :box :obox :crow))
 309     (:headlabel text)
 310     (:taillabel text)
 311     (:labelfontsize integer)
 312     (:labelfontname text)
 313     (:labelfontcolor text)
 314     (:labeldistance integer)
 315     (:port-label-distance integer)
 316     (:decorate boolean)
 317     (:samehead boolean)
 318     (:sametail boolean)
 319     (:constraint boolean)
 320     (:layer text)))
 321
 322 (defclass* dot-attributes-mixin ()
 323   ((dot-attributes nil ia))
 324   (:export-p t))
 325
 326 (defclass* dot-graph-mixin (dot-attributes-mixin) ()
 327   (:export-p t)
 328   (:default-initargs
 329     :vertex-class 'dot-vertex
 330     :directed-edge-class 'dot-directed-edge
 331     :undirected-edge-class 'dot-edge))
 332 (defclass* dot-vertex-mixin (dot-attributes-mixin) ()
 333   (:export-p t))
 334 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
 335   (:export-p t))
 336
 337 (defclass* dot-graph (dot-graph-mixin graph-container)
 338   ()
 339   (:export-p t))
 340
 341 (defclass* dot-vertex (dot-vertex-mixin graph-container-vertex) ()
 342   (:export-p t))
 343 (defclass* dot-edge (dot-edge-mixin graph-container-edge) ()
 344   (:export-p t))
 345 (defclass* dot-directed-edge (dot-edge directed-edge-mixin) ()
 346   (:export-p t))
 347
 348
 349 (defmethod (setf dot-attribute-value) :before (value (attr symbol) (thing dot-attributes-mixin))
 350   (ensure-valid-dot-attribute attr thing))
 351
 352 (defmethod (setf dot-attribute-value) (value (attr symbol) (thing dot-attributes-mixin))
 353   (setf (getf (dot-attributes thing) attr) value))
 354
 355 (defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
 356   (getf (dot-attributes thing) attr))
 357
 358 (defmethod graph->dot-properties ((graph dot-graph-mixin) (stream t))
 359   (loop for (name value) on (dot-attributes graph) by #'cddr
 360         do
 361         (print-dot-key-value name value *dot-graph-attributes* stream)))
 362
 363 (defmethod vertex->dot ((vertex dot-vertex-mixin) (stream t))
 364   (format-dot-attributes vertex *dot-vertex-attributes* stream))
 365
 366 (defmethod edge->dot ((edge dot-edge-mixin) (stream t))
 367   (format-dot-attributes edge *dot-edge-attributes* stream))
 368
 369 (defun format-dot-attributes (object dot-attributes stream)
 370   (loop for (name value) on (dot-attributes object) by #'cddr
 371         for prefix = "" then ", " do
 372         (write-string prefix stream)
 373         (print-dot-key-value name value dot-attributes stream)))
 374
 375 (defmethod ensure-valid-dot-attribute (key (object dot-graph-mixin))
 376   (or (assoc key *dot-graph-attributes*)
 377       (error "Invalid dot graph attribute ~S" key)))
 378
 379 (defmethod ensure-valid-dot-attribute (key (object dot-vertex-mixin))
 380   (or (assoc key *dot-vertex-attributes*)
 381       (error "Invalid dot vertex attribute ~S" key)))
 382
 383 (defmethod ensure-valid-dot-attribute (key (object dot-edge-mixin))
 384   (or (assoc key *dot-edge-attributes*)
 385       (error "Invalid dot edge attribute ~S" key)))
 386
 387 (defun print-dot-key-value (key value dot-attributes stream)
 388   (destructuring-bind (key value-type)
 389       (or (assoc key dot-attributes)
 390           (error "Invalid attribute ~S" key))
 391     (write-name-for-dot key stream)
 392     (format stream "=~a"
 393             (etypecase value-type
 394               ((member coordinate)
 395                (with-output-to-string (str)
 396                  (princ "\"" str)
 397                  (let ((first t))
 398                    (dolist (el value)
 399                      (unless first
 400                        (princ "," str))
 401                      (princ el str)
 402                      (setf first nil)))
 403                  (princ "\"" str)))
 404               ((member spline)
 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 (first el) str)
 412                      (princ "," str)
 413                      (princ (second el) str)
 414                      (setf first nil)))
 415                  (princ "\"" str)))
 416               ((member bounding-box)
 417                (with-output-to-string (str)
 418                  (princ "\"" str)
 419                  (let ((first t))
 420                    (dolist (el value)
 421                      (unless first
 422                        (princ ", " str))
 423                      (princ (first el) str)
 424                      (princ "," str)
 425                      (princ (second el) str)
 426                      (setf first nil)))
 427                  (princ "\"" str)))
 428               ((member integer)
 429                (unless (typep value 'integer)
 430                  (error "Invalid value for ~S: ~S is not an integer"
 431                         key value))
 432                value)
 433               ((member boolean)
 434                (if value
 435                    "true"
 436                    "false"))
 437               ((member text)
 438                (textify value))
 439               ((member float)
 440                (coerce value 'single-float))
 441               (list
 442                (unless (member value value-type :test 'equal)
 443                  (error "Invalid value for ~S: ~S is not one of ~S"
 444                         key value value-type))
 445                (if (symbolp value)
 446                    (string-downcase value)
 447                    value))))))
 448
 449 (defmethod write-name-for-dot (attribute stream)
 450   (format stream "~(~A~)" attribute))
 451
 452 (defmethod write-name-for-dot ((attribute (eql :url)) stream)
 453   (format stream "URL"))
 454
 455 (defun textify (object)
 456   (let ((string (princ-to-string object)))
 457     (with-output-to-string (stream)
 458       (write-char #\" stream)
 459       (loop for c across string do
 460             ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
 461             ;; to work.
 462             (case c
 463               ((#\")
 464                (write-char #\\ stream)
 465                (write-char c stream))
 466               (#\Newline
 467                (write-char #\\ stream)
 468                (write-char #\n stream))
 469               (t
 470                (write-char c stream))))
 471       (write-char #\" stream))))
 472
 473 ;;; ---------------------------------------------------------------------------
 474 ;
 475 ; Calls the dot executable to create external output for graphs
 476 ;
 477 #+(or win32 mswindows)
 478 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
 479 #+(or linux unix)
 480 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
 481
 482 (defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
 483   "Generate an external represenation of a graph to a file, by running
 484 the program in *dot-path*."
 485   (let ((dot-string (graph->dot g nil))
 486         (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
 487     #+lispworks (with-open-stream
 488                     (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
 489                                       :direction :input))
 490                     (write-line dot-string s)
 491                     (force-output s)
 492                     (close s))
 493     #+sbcl
 494     (sb-ext:run-program *dot-path*
 495                         (list dot-type "-o" file-name)
 496                         :input (make-string-input-stream dot-string)
 497                         :output *standard-output*)
 498     #-(or sbcl lispworks)
 499     (error "Don't know how to execute a program on this platform")))
 500
 501 ;;; ---------------------------------------------------------------------------
 502 ;
 503 ; Test dot external
 504 ;
 505 (defun test-dot-external ()
 506   (let* ((g (make-graph 'dot-graph))
 507          (v1 (add-vertex g 'a :dot-attributes '(:shape :box
 508                                                 :color :blue)))
 509          (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
 510                                                 :style :filled
 511                                                 :color :yellow))))
 512     (add-edge-between-vertexes g v1 v2
 513                                :dot-attributes '(:arrowhead :open
 514                                                  :arrowtail :normal
 515                                                  :style :dotted))
 516     (print (graph->dot g nil))
 517     (graph->dot-external g "/tmp/test.gif" :type :gif)))