dev/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
  12
  13 DISCUSSION
  14
  15 A color value can be a huesaturation-
  16 brightness triple (three floating point numbers between 0 and 1, separated
  17 by commas); one of the colors names listed in Appendix G (borrowed from
  18 some version of the X window system); or a red-green-blue (RGB) triple4 (three
  19 hexadecimal number between 00 and FF, preceded by the character Õ#Õ). Thus,
  20 the values "orchid", "0.8396,0.4862,0.8549" and #DA70D6 are three
  21 ways to specify the same color.
  22
  23 |#
  24 (in-package metabang.graph)
  25
  26 ;;; ---------------------------------------------------------------------------
  27 ;
  28 ; This outputs the graph to string in accordance with the DOT file format.
  29 ; For more information about DOT file format, search the web for "DOTTY" and
  30 ; "GRAPHVIZ".
  31 ;
  32 (defmethod graph->dot ((g basic-graph) (stream stream)
  33                        &key
  34                        (graph-formatter 'graph->dot-properties)
  35                        (vertex-key 'vertex-id)
  36                        (vertex-labeler nil)
  37                        (vertex-formatter 'vertex->dot)
  38                        (edge-key nil)
  39                        (edge-labeler 'princ)
  40                        (edge-formatter 'edge->dot))
  41   (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
  42   (format stream "[")
  43   (funcall graph-formatter g stream)
  44   (format stream "];")
  45   (terpri stream)
  46
  47   ;; vertex formatting
  48   (iterate-vertexes
  49    g
  50    (lambda (v)
  51      (terpri stream)
  52      (let ((key (if vertex-key (funcall vertex-key v) v)))
  53        (princ key stream)
  54        (princ " [" stream)
  55        (when vertex-labeler
  56          (princ "label=\"" stream)
  57          (funcall vertex-labeler v stream)
  58          (princ "\", " stream))
  59        (funcall vertex-formatter v stream)
  60        (princ "]" stream))))
  61
  62   (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
  63         (directed-edge-tag (when (and (contains-undirected-edge-p g)
  64                                       (contains-directed-edge-p g))
  65                              "dir=forward, ")))
  66     (flet ((format-edge (e connector from to directed?)
  67              (terpri stream)
  68              (princ (funcall vertex-key from) stream)
  69              (princ connector stream)
  70              (princ (funcall vertex-key to) stream)
  71              (princ " [" stream)
  72              (when (and directed? directed-edge-tag)
  73                (princ directed-edge-tag stream))
  74              (when edge-key
  75                (princ "label=\"" stream)
  76                (funcall edge-labeler e stream)
  77                (princ "\"," stream))
  78              (funcall edge-formatter e stream)
  79              (princ "]" stream)))
  80       ;; directed edges
  81       (iterate-vertexes
  82        g
  83        (lambda (v)
  84          (iterate-target-edges
  85           v
  86           (lambda (e)
  87             (when (directed-edge-p e)
  88               (format-edge e directed-edge-connector
  89                            (source-vertex e) (target-vertex e) t))))))
  90
  91       ;; undirected edges
  92       (let ((edges (make-container 'simple-associative-container)))
  93         (iterate-vertexes
  94          g
  95          (lambda (v)
  96            (iterate-edges
  97             v
  98             (lambda (e)
  99               (when (and (undirected-edge-p e)
 100                          (not (item-at-1 edges e)))
 101                 (setf (item-at-1 edges e) t)
 102                 (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
 103
 104   (terpri stream)
 105   (princ "}" stream)
 106
 107   (values g))
 108
 109
 110 #+Test
 111 (let ((g (make-container 'graph-container :default-edge-type :undirected)))
 112   (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
 113         (add-edge-between-vertexes g a b))
 114   (graph->dot g nil))
 115
 116 #+Test
 117 "graph G {
 118 E []
 119 C []
 120 B []
 121 A []
 122 D []
 123 F []
 124 D--E []
 125 E--F []
 126 B--C []
 127 A--B []
 128 B--D []
 129 D--F []
 130 }"
 131
 132 #+Test
 133 (let ((g (make-container 'graph-container :default-edge-type :directed)))
 134   (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
 135         (add-edge-between-vertexes g a b))
 136   (graph->dot g nil))
 137
 138 #+Test
 139 "digraph G {
 140 E []
 141 C []
 142 B []
 143 A []
 144 D []
 145 F []
 146 E->F []
 147 B->C []
 148 B->D []
 149 A->B []
 150 D->E []
 151 D->F []
 152 }"
 153
 154 #+Test
 155 (let ((g (make-container 'graph-container)))
 156   (loop for (a b) in '((d e) (e f) (d f)) do
 157         (add-edge-between-vertexes g a b :edge-type :directed))
 158   (loop for (a b) in '((a b) (b c) (b d)) do
 159         (add-edge-between-vertexes g a b :edge-type :undirected))
 160   (graph->dot g nil))
 161
 162 #+Test
 163 "graph G {
 164 E []
 165 C []
 166 B []
 167 A []
 168 D []
 169 F []
 170 E--F [dir=forward, ]
 171 D--E [dir=forward, ]
 172 D--F [dir=forward, ]
 173 B--C []
 174 A--B []
 175 B--D []
 176 }"
 177
 178 ;;; ---------------------------------------------------------------------------
 179
 180 (defmethod graph->dot ((g basic-graph) (stream (eql nil))
 181                        &rest args &key &allow-other-keys)
 182   (declare (dynamic-extent args))
 183   (let ((out (make-string-output-stream)))
 184     (apply #'graph->dot g out args)
 185     (get-output-stream-string out)))
 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 |#