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