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