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 coordinate)
 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     (:fontcolor text)
 277     (:color text)
 278     (:fillcolor text)
 279     (:style (:filled :solid :dashed :dotted :bold :invis))
 280     (:layer text)
 281     (:url text)))
 282
 283 (defparameter *dot-edge-attributes*
 284   '((:pos spline)
 285     (:minlen integer)
 286     (:weight integer)
 287     (:label text)
 288     (:fontsize integer)
 289     (:fontname text)
 290     (:fontcolor text)
 291     (:style (:solid :dashed :dotted :bold :invis))
 292     (:color text)
 293     (:dir (:forward :back :both :none))
 294     (:tailclip boolean)
 295     (:headclip boolean)
 296     (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee
 297                  :empty :invempty :open :halfopen :diamond :odiamond
 298                  :box :obox :crow))
 299     (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee
 300                  :empty :invempty :open :halfopen :diamond :odiamond
 301                  :box :obox :crow))
 302     (:headlabel text)
 303     (:taillabel text)
 304     (:labelfontsize integer)
 305     (:labelfontname text)
 306     (:labelfontcolor text)
 307     (:labeldistance integer)
 308     (:port-label-distance integer)
 309     (:decorate boolean)
 310     (:samehead boolean)
 311     (:sametail boolean)
 312     (:constraint boolean)
 313     (:layer text)))
 314
 315 (defclass* dot-attributes-mixin ()
 316   ((dot-attributes nil ia))
 317   (:export-p t))
 318
 319 (defclass* dot-graph-mixin (dot-attributes-mixin) ()
 320   (:export-p t)
 321   (:default-initargs
 322     :vertex-class 'dot-vertex
 323     :directed-edge-class 'dot-directed-edge
 324     :undirected-edge-class 'dot-edge))
 325 (defclass* dot-vertex-mixin (dot-attributes-mixin) ()
 326   (:export-p t))
 327 (defclass* dot-edge-mixin (dot-attributes-mixin) ()
 328   (:export-p t))
 329
 330 (defclass* dot-graph (dot-graph-mixin graph-container)
 331   ()
 332   (:export-p t))
 333
 334 (defclass* dot-vertex (dot-vertex-mixin graph-container-vertex) ()
 335   (:export-p t))
 336 (defclass* dot-edge (dot-edge-mixin graph-container-edge) ()
 337   (:export-p t))
 338 (defclass* dot-directed-edge (dot-edge directed-edge-mixin) ()
 339   (:export-p t))
 340
 341
 342 (defmethod (setf dot-attribute-value) :before (value (attr symbol) (thing dot-attributes-mixin))
 343   (declare (ignore value))
 344   (ensure-valid-dot-attribute attr thing))
 345
 346 (defmethod (setf dot-attribute-value) (value (attr symbol) (thing dot-attributes-mixin))
 347   (setf (getf (dot-attributes thing) attr) value))
 348
 349 (defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
 350   (getf (dot-attributes thing) attr))
 351
 352 (defmethod graph->dot-properties ((graph dot-graph-mixin) (stream t))
 353   (loop for (name value) on (dot-attributes graph) by #'cddr
 354         do
 355         (print-dot-key-value name value *dot-graph-attributes* stream)))
 356
 357 (defmethod vertex->dot ((vertex dot-vertex-mixin) (stream t))
 358   (format-dot-attributes vertex *dot-vertex-attributes* stream))
 359
 360 (defmethod edge->dot ((edge dot-edge-mixin) (stream t))
 361   (format-dot-attributes edge *dot-edge-attributes* stream))
 362
 363 (defun format-dot-attributes (object dot-attributes stream)
 364   (loop for (name value) on (dot-attributes object) by #'cddr
 365         for prefix = "" then ", " do
 366         (write-string prefix stream)
 367         (print-dot-key-value name value dot-attributes stream)))
 368
 369 (defmethod ensure-valid-dot-attribute (key (object dot-graph-mixin))
 370   (or (assoc key *dot-graph-attributes*)
 371       (error "Invalid dot graph attribute ~S" key)))
 372
 373 (defmethod ensure-valid-dot-attribute (key (object dot-vertex-mixin))
 374   (or (assoc key *dot-vertex-attributes*)
 375       (error "Invalid dot vertex attribute ~S" key)))
 376
 377 (defmethod ensure-valid-dot-attribute (key (object dot-edge-mixin))
 378   (or (assoc key *dot-edge-attributes*)
 379       (error "Invalid dot edge attribute ~S" key)))
 380
 381 (defun print-dot-key-value (key value dot-attributes stream)
 382   (destructuring-bind (key value-type)
 383       (or (assoc key dot-attributes)
 384           (error "Invalid attribute ~S" key))
 385     (write-name-for-dot key stream)
 386     (format stream "=~a"
 387             (etypecase value-type
 388               ((member coordinate)
 389                (with-output-to-string (str)
 390                  (princ "\"" str)
 391                  (let ((first t))
 392                    (dolist (el value)
 393                      (unless first
 394                        (princ "," str))
 395                      (princ el str)
 396                      (setf first nil)))
 397                  (princ "\"" str)))
 398               ((member spline)
 399                (with-output-to-string (str)
 400                  (princ "\"" str)
 401                  (let ((first t))
 402                    (dolist (el value)
 403                      (unless first
 404                        (princ " " str))
 405                      (princ (first el) str)
 406                      (princ "," str)
 407                      (princ (second el) str)
 408                      (setf first nil)))
 409                  (princ "\"" str)))
 410               ((member bounding-box)
 411                (with-output-to-string (str)
 412                  (princ "\"" str)
 413                  (let ((first t))
 414                    (dolist (el value)
 415                      (unless first
 416                        (princ ", " str))
 417                      (princ (first el) str)
 418                      (princ "," str)
 419                      (princ (second el) str)
 420                      (setf first nil)))
 421                  (princ "\"" str)))
 422               ((member integer)
 423                (unless (typep value 'integer)
 424                  (error "Invalid value for ~S: ~S is not an integer"
 425                         key value))
 426                value)
 427               ((member boolean)
 428                (if value
 429                    "true"
 430                    "false"))
 431               ((member text)
 432                (textify value))
 433               ((member float)
 434                (coerce value 'single-float))
 435               (list
 436                (unless (member value value-type :test 'equal)
 437                  (error "Invalid value for ~S: ~S is not one of ~S"
 438                         key value value-type))
 439                (if (symbolp value)
 440                    (string-downcase value)
 441                    value))))))
 442
 443 (defmethod write-name-for-dot (attribute stream)
 444   (format stream "~(~A~)" attribute))
 445
 446 (defmethod write-name-for-dot ((attribute (eql :url)) stream)
 447   (format stream "URL"))
 448
 449 (defun textify (object)
 450   (let ((string (princ-to-string object)))
 451     (with-output-to-string (stream)
 452       (write-char #\" stream)
 453       (loop for c across string do
 454             ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
 455             ;; to work.
 456             (case c
 457               ((#\")
 458                (write-char #\\ stream)
 459                (write-char c stream))
 460               (#\Newline
 461                (write-char #\\ stream)
 462                (write-char #\n stream))
 463               (t
 464                (write-char c stream))))
 465       (write-char #\" stream))))
 466
 467 ;;; ---------------------------------------------------------------------------
 468 ;
 469 ; Calls the dot executable to create external output for graphs
 470 ;
 471 #+(or win32 mswindows)
 472 (defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
 473 #+(or linux unix)
 474 (defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
 475
 476 (defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
 477   "Generate an external represenation of a graph to a file, by running
 478 the program in *dot-path*."
 479   (let ((dot-string (graph->dot g nil))
 480         (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
 481     #+lispworks (with-open-stream
 482                     (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
 483                                       :direction :input))
 484                     (write-line dot-string s)
 485                     (force-output s)
 486                     (close s))
 487     #+sbcl
 488     (sb-ext:run-program *dot-path*
 489                         (list dot-type "-o" file-name)
 490                         :input (make-string-input-stream dot-string)
 491                         :output *standard-output*)
 492     #-(or sbcl lispworks)
 493     (error "Don't know how to execute a program on this platform")))
 494
 495 ;;; ---------------------------------------------------------------------------
 496 ;
 497 ; Test dot external
 498 ;
 499 (defun test-dot-external ()
 500   (let* ((g (make-graph 'dot-graph))
 501          (v1 (add-vertex g 'a :dot-attributes '(:shape :box
 502                                                 :color :blue)))
 503          (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
 504                                                 :style :filled
 505                                                 :color :yellow))))
 506     (add-edge-between-vertexes g v1 v2
 507                                :dot-attributes '(:arrowhead :open
 508                                                  :arrowtail :normal
 509                                                  :style :dotted))
 510     (print (graph->dot g nil))
 511     (graph->dot-external g "/tmp/test.gif" :type :gif)))