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