(asdf:operate 'asdf:load-op 'asdf-system-connections)
-(defsystem cl-graph
+(defsystem cl-graph
:version "0.8"
:author "Gary Warren King <gwking@metabang.com>"
:maintainer "Gary Warren King <gwking@metabang.com>"
:depends-on ("graph"))
(:file "graph-algorithms"
:depends-on ("graph"))
- (:file "graphviz-support"
- :depends-on ("graph"))
- (:static-file "notes.text")))
+ (:static-file "notes.text")
+
+ (:module "graphviz" :depends-on ("graph")
+ :components ((:file "graphviz-support")))))
(:module "website"
:components ((:module "source"
:components ((:static-file "index.lml"))))))
:components ((:file "graph-and-variates")
(:file "graph-generation"
:depends-on ("graph-and-variates"))))))
+
+(asdf:defsystem-connection cl-graph-and-cl-graphviz
+ :requires (cl-graph cl-graphviz)
+ :components ((:module "dev"
+ :components
+ ((:module "graphviz"
+ :components
+ ((:file "graphviz-support-optional")))))))
(error "~A not found in ~A" vertex graph))))
;;; ---------------------------------------------------------------------------
-
+;; TODO !!! dispatch is the same as the second method above
(defmethod search-for-vertex ((graph basic-graph) (vertex t)
&key (key (vertex-key graph)) (test 'equal)
(error-if-not-found? t))
+++ /dev/null
-;;;-*- Mode: Lisp; Package: metabang.graph -*-
-
-#| simple-header
-
-$Id: graphviz-support.lisp,v 1.7 2005/06/21 20:51:51 moody Exp $
-
-Copyright 1992 - 2005 Experimental Knowledge Systems Lab,
-University of Massachusetts Amherst MA, 01003-4610
-Professor Paul Cohen, Director
-
-Author: Gary King
-
-DISCUSSION
-
-A color value can be a huesaturation-
-brightness triple (three floating point numbers between 0 and 1, separated
-by commas); one of the colors names listed in Appendix G (borrowed from
-some version of the X window system); or a red-green-blue (RGB) triple4 (three
-hexadecimal number between 00 and FF, preceded by the character Õ#Õ). Thus,
-the values "orchid", "0.8396,0.4862,0.8549" and #DA70D6 are three
-ways to specify the same color.
-
-|#
-(in-package metabang.graph)
-
-;;; ---------------------------------------------------------------------------
-;
-; This outputs the graph to string in accordance with the DOT file format.
-; For more information about DOT file format, search the web for "DOTTY" and
-; "GRAPHVIZ".
-;
-(defmethod graph->dot ((g basic-graph) (stream stream)
- &key
- (graph-formatter 'graph->dot-properties)
- (vertex-key 'vertex-id)
- (vertex-labeler nil)
- (vertex-formatter 'vertex->dot)
- (edge-key nil)
- (edge-labeler 'princ)
- (edge-formatter 'edge->dot))
- (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
- (format stream "[")
- (funcall graph-formatter g stream)
- (format stream "];")
- (terpri stream)
-
- ;; vertex formatting
- (iterate-vertexes
- g
- (lambda (v)
- (terpri stream)
- (let ((key (if vertex-key (funcall vertex-key v) v)))
- (princ key stream)
- (princ " [" stream)
- (when vertex-labeler
- (princ "label=\"" stream)
- (funcall vertex-labeler v stream)
- (princ "\", " stream))
- (funcall vertex-formatter v stream)
- (princ "];" stream))))
-
- (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
- (directed-edge-tag (when (and (contains-undirected-edge-p g)
- (contains-directed-edge-p g))
- "dir=forward, ")))
- (flet ((format-edge (e connector from to directed?)
- (terpri stream)
- (princ (funcall vertex-key from) stream)
- (princ connector stream)
- (princ (funcall vertex-key to) stream)
- (princ " [" stream)
- (when (and directed? directed-edge-tag)
- (princ directed-edge-tag stream))
- (when edge-key
- (princ "label=\"" stream)
- (funcall edge-labeler e stream)
- (princ "\"," stream))
- (funcall edge-formatter e stream)
- (princ "];" stream)))
- ;; directed edges
- (iterate-vertexes
- g
- (lambda (v)
- (iterate-target-edges
- v
- (lambda (e)
- (when (directed-edge-p e)
- (format-edge e directed-edge-connector
- (source-vertex e) (target-vertex e) t))))))
-
- ;; undirected edges
- (let ((edges (make-container 'simple-associative-container)))
- (iterate-vertexes
- g
- (lambda (v)
- (iterate-edges
- v
- (lambda (e)
- (when (and (undirected-edge-p e)
- (not (item-at-1 edges e)))
- (setf (item-at-1 edges e) t)
- (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
-
- (terpri stream)
- (princ "}" stream)
-
- (values g))
-
-
-#+Test
-(let ((g (make-container 'graph-container :default-edge-type :undirected)))
- (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
- (add-edge-between-vertexes g a b))
- (graph->dot g nil))
-
-#+Test
-"graph G {
-E []
-C []
-B []
-A []
-D []
-F []
-D--E []
-E--F []
-B--C []
-A--B []
-B--D []
-D--F []
-}"
-
-#+Test
-(let ((g (make-container 'graph-container :default-edge-type :directed)))
- (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
- (add-edge-between-vertexes g a b))
- (graph->dot g nil))
-
-#+Test
-"digraph G {
-E []
-C []
-B []
-A []
-D []
-F []
-E->F []
-B->C []
-B->D []
-A->B []
-D->E []
-D->F []
-}"
-
-#+Test
-(let ((g (make-container 'graph-container)))
- (loop for (a b) in '((d e) (e f) (d f)) do
- (add-edge-between-vertexes g a b :edge-type :directed))
- (loop for (a b) in '((a b) (b c) (b d)) do
- (add-edge-between-vertexes g a b :edge-type :undirected))
- (graph->dot g nil))
-
-#+Test
-"graph G {
-E []
-C []
-B []
-A []
-D []
-F []
-E--F [dir=forward, ]
-D--E [dir=forward, ]
-D--F [dir=forward, ]
-B--C []
-A--B []
-B--D []
-}"
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod graph->dot ((g basic-graph) (stream (eql nil))
- &rest args &key &allow-other-keys)
- (declare (dynamic-extent args))
- (let ((out (make-string-output-stream)))
- (apply #'graph->dot g out args)
- (get-output-stream-string out)))
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod graph->dot ((g basic-graph) (stream (eql t))
- &rest args &key &allow-other-keys)
- (declare (dynamic-extent args))
- (apply #'graph->dot g *standard-output* args))
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod graph->dot ((g basic-graph) (stream string)
- &rest args &key &allow-other-keys)
- (declare (dynamic-extent args))
- (with-open-file (out stream :direction :output :if-exists :supersede)
- (apply #'graph->dot g out args)))
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod graph->dot ((g basic-graph) (stream pathname)
- &rest args &key &allow-other-keys)
- (declare (dynamic-extent args))
- (apply #'graph->dot g (namestring stream) args))
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod graph->dot-properties ((g t) (stream t))
- (values))
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod vertex->dot ((v basic-vertex) (stream stream))
- (values))
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod edge->dot ((v basic-edge) (stream stream))
- (values))
-
-;;; ---------------------------------------------------------------------------
-;;; dot->graph
-;;; ---------------------------------------------------------------------------
-
-#|
-(defmethod dot->graph ((dot-stream stream)
- &key)
- )
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod dot->graph ((dot-stream string)
- &rest args &key &allow-other-keys)
- (declare (dynamic-extent args))
- (with-open-file (out stream :direction :output :if-exists :supersede)
- (apply #'dot->graph g out args)))
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod dot->graph ((dot-stream pathname)
- &rest args &key &allow-other-keys)
- (declare (dynamic-extent args))
- (with-open-file (out stream :direction :output :if-exists :supersede)
- (apply #'dot->graph g out args))
- (apply #'dot->graph g (namestring stream) args))
-
-|#
-
-(defparameter *dot-graph-attributes*
- '((:size text)
- (:page text)
- (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
- (:margin float)
- (:nodesep float)
- (:ranksep float)
- (:ordering (:out))
- (:rankdir ("LR" "RL" "BT"))
- (:pagedir text)
- (:rank (:same :min :max))
- (:rotate integer)
- (:center integer)
- (:nslimit float)
- (:mclimit float)
- (:layers text)
- (:color text)
- (:bgcolor text)))
-
-(defparameter *dot-vertex-attributes*
- '((:height integer)
- (:width integer)
- (:fixed-size boolean)
- (:label text)
- (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
- :diamond :trapezium :parallelogram :house :hexagon :octagon
- :doublecircle))
- (:fontsize integer)
- (:fontname text)
- (:color text)
- (:fillcolor text)
- (:style (:filled :solid :dashed :dotted :bold :invis))
- (:layer text)))
-
-(defparameter *dot-edge-attributes*
- '((:minlen integer)
- (:weight integer)
- (:label text)
- (:fontsize integer)
- (:fontname text)
- (:fontcolor text)
- (:style (:solid :dashed :dotted :bold :invis))
- (:color text)
- (:dir (:forward :back :both :none))
- (:tailclip boolean)
- (:headclip boolean)
- (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee
- :empty :invempty :open :halfopen :diamond :odiamond
- :box :obox :crow))
- (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee
- :empty :invempty :open :halfopen :diamond :odiamond
- :box :obox :crow))
- (:headlabel text)
- (:taillabel text)
- (:labelfontsize integer)
- (:labelfontname text)
- (:labelfontcolor text)
- (:labeldistance integer)
- (:port-label-distance integer)
- (:decorate boolean)
- (:samehead boolean)
- (:sametail boolean)
- (:constraint boolean)
- (:layer text)))
-
-(defclass* dot-attributes-mixin ()
- ((dot-attributes nil ia))
- (:export-p t))
-
-(defclass* dot-graph-mixin (dot-attributes-mixin) ()
- (:export-p t))
-(defclass* dot-vertex-mixin (dot-attributes-mixin) ()
- (:export-p t))
-(defclass* dot-edge-mixin (dot-attributes-mixin) ()
- (:export-p t))
-
-(defclass* dot-graph (graph-container dot-graph-mixin)
- ()
- (:default-initargs
- :vertex-class 'dot-vertex
- :directed-edge-class 'dot-directed-edge
- :undirected-edge-class 'dot-edge)
- (:export-p t))
-
-(defclass* dot-vertex (graph-container-vertex dot-vertex-mixin) ()
- (:export-p t))
-(defclass* dot-edge (graph-container-edge dot-edge-mixin) ()
- (:export-p t))
-(defclass* dot-directed-edge (directed-edge-mixin dot-edge) ()
- (:export-p t))
-
-(defmethod graph->dot-properties ((graph dot-graph) (stream t))
- (loop for (name value) on (dot-attributes graph) by #'cddr
- do
- (print-dot-key-value name value *dot-graph-attributes* stream)
- (format stream " ;~%")))
-
-(defmethod vertex->dot ((vertex dot-vertex) (stream t))
- (format-dot-attributes vertex *dot-vertex-attributes* stream))
-
-(defmethod edge->dot ((edge dot-edge) (stream t))
- (format-dot-attributes edge *dot-edge-attributes* stream))
-
-(defun format-dot-attributes (object dot-attributes stream)
- (loop for (name value) on (dot-attributes object) by #'cddr
- for prefix = "" then "," do
- (write-string prefix stream)
- (print-dot-key-value name value dot-attributes stream)))
-
-(defun print-dot-key-value (key value dot-attributes stream)
- (destructuring-bind (key value-type)
- (or (assoc key dot-attributes)
- (error "Invalid attribute ~S" key))
- (format stream "~a=~a" (string-downcase key)
- (etypecase value-type
- ((member integer)
- (unless (typep value 'integer)
- (error "Invalid value for ~S: ~S is not an integer"
- key value))
- value)
- ((member boolean)
- (if value
- "true"
- "false"))
- ((member text)
- (textify value))
- ((member float)
- (coerce value 'single-float))
- (list
- (unless (member value value-type :test 'equal)
- (error "Invalid value for ~S: ~S is not one of ~S"
- key value value-type))
- (if (symbolp value)
- (string-downcase value)
- value))))))
-
-(defun textify (object)
- (let ((string (princ-to-string object)))
- (with-output-to-string (stream)
- (write-char #\" stream)
- (loop for c across string do
- ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
- ;; to work.
- (case c
- ((#\")
- (write-char #\\ stream)
- (write-char c stream))
- (#\Newline
- (write-char #\\ stream)
- (write-char #\n stream))
- (t
- (write-char c stream))))
- (write-char #\" stream))))
-
-;;; ---------------------------------------------------------------------------
-;
-; Calls the dot executable to create external output for graphs
-;
-#+(or win32 mswindows)
-(defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
-#+(or linux unix)
-(defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
-
-(defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
- "Generate an external represenation of a graph to a file, by running
-the program in *dot-path*."
- (let ((dot-string (graph->dot g nil))
- (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
- #+lispworks (with-open-stream
- (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
- :direction :input))
- (write-line dot-string s)
- (force-output s)
- (close s))
- #+sbcl
- (sb-ext:run-program *dot-path*
- (list dot-type "-o" file-name)
- :input (make-string-input-stream dot-string)
- :output *standard-output*)
- #-(or sbcl lispworks)
- (error "Don't know how to execute a program on this platform")))
-
-;;; ---------------------------------------------------------------------------
-;
-; Test dot external
-;
-(defun test-dot-external ()
- (let* ((g (make-graph 'dot-graph))
- (v1 (add-vertex g 'a :dot-attributes '(:shape :box
- :color :blue)))
- (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
- :style :filled
- :color :yellow))))
- (add-edge-between-vertexes g v1 v2
- :dot-attributes '(:arrowhead :open
- :arrowtail :normal
- :style :dotted))
- (print (graph->dot g nil))
- (graph->dot-external g "/tmp/test.gif" :type :gif)))
--- /dev/null
+;;;-*- Mode: Lisp; Package: metabang.graph -*-
+
+#| simple-header
+
+$Id: graphviz-support-optional.lisp,v 1.0 2005/06/21 20:51:51 moody Exp $
+
+Author: Attila Lendvai
+
+DISCUSSION
+
+This file contains the stuff that depends on cl-graphviz and is only
+loaded when cl-graphviz is available.
+
+|#
+
+(in-package metabang.graph)
+
+;; TODO these are hacks to be removed later,
+;; the functionality should be provided by graph itself
+(defmethod find-vertex-by-id (g (id integer))
+ (search-for-vertex g id :key 'vertex-id))
+(defmethod find-vertex-by-id (g (id string))
+ (find-vertex-by-id g (parse-integer id)))
+
+;;; ---------------------------------------------------------------------------
+(defmethod layout-graph-with-graphviz ((g dot-graph)
+ &key
+ (algorithm nil algorithm-provided-p))
+ (let* ((dot (with-output-to-string (out) (graph->dot g out)))
+ (args (list dot
+ :graph-visitor
+ (lambda (dot-graph)
+ (setf (dot-attribute :bb g)
+ (graphviz:graph-bounding-box dot-graph)))
+
+ :node-visitor
+ (lambda (node)
+ (bind ((pos (graphviz:node-coordinate node))
+ ((width height) (graphviz:node-size node)))
+ ;;(format t "Node ~a: ~a; ~a, ~a~%"
+ ;; (graphviz:node-name node)
+ ;; pos
+ ;; width height)
+ ;; TODO search-for-vertex is sloooow, use a hashtable or
+ ;; introduce an graph-find-element-by-id-mixin, or similar
+ (let ((vertex (find-vertex-by-id g (graphviz:node-name node))))
+ (setf (dot-attribute :pos vertex) pos)
+ (setf (dot-attribute :width vertex) width)
+ (setf (dot-attribute :height vertex) height))))
+
+ :edge-visitor
+ (lambda (edge)
+ (bind (((from to) (graphviz:edge-between edge)))
+ ;;(format t "Edge: ~a - ~a~%"
+ ;; (graphviz:node-name from)
+ ;; (graphviz:node-name to))
+ (let* ((from-vertex (find-vertex-by-id g (graphviz:node-name from)))
+ (to-vertex (find-vertex-by-id g (graphviz:node-name to)))
+ (real-edge (find-edge-between-vertexes g from-vertex to-vertex))
+ (bezier-points '()))
+ (graphviz:edge-iterate-beziers
+ edge
+ (lambda (bezier)
+ ;;(format t " Bezier: ~a~%"
+ ;; (graphviz:bezier-points bezier))
+ (dolist (el (graphviz:bezier-points bezier))
+ (push el bezier-points))))
+ (setf (dot-attribute :pos real-edge) (nreverse bezier-points))))))))
+ (when algorithm-provided-p
+ (nconc args (list :algorithm algorithm)))
+ (apply 'graphviz:layout-dot-format args))
+ g)
+
+
--- /dev/null
+;;;-*- Mode: Lisp; Package: metabang.graph -*-
+
+#| simple-header
+
+$Id: graphviz-support.lisp,v 1.7 2005/06/21 20:51:51 moody Exp $
+
+Copyright 1992 - 2005 Experimental Knowledge Systems Lab,
+University of Massachusetts Amherst MA, 01003-4610
+Professor Paul Cohen, Director
+
+Author: Gary King, Levente Mészáros, Attila Lendvai
+
+DISCUSSION
+
+This file contains the stuff that does not depend on cl-graphviz.
+
+|#
+(in-package metabang.graph)
+
+;;; ---------------------------------------------------------------------------
+;
+; This outputs the graph to string in accordance with the DOT file format.
+; For more information about DOT file format, search the web for "DOTTY" and
+; "GRAPHVIZ".
+;
+(defmethod graph->dot ((g basic-graph) (stream stream)
+ &key
+ (graph-formatter 'graph->dot-properties)
+ (vertex-key 'vertex-id)
+ (vertex-labeler nil)
+ (vertex-formatter 'vertex->dot)
+ (edge-key nil)
+ (edge-labeler 'princ)
+ (edge-formatter 'edge->dot))
+ (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
+ (format stream "[")
+ (funcall graph-formatter g stream)
+ (format stream "];")
+ (terpri stream)
+
+ ;; vertex formatting
+ (iterate-vertexes
+ g
+ (lambda (v)
+ (terpri stream)
+ (let ((key (if vertex-key (funcall vertex-key v) v)))
+ (princ key stream)
+ (princ " [" stream)
+ (when vertex-labeler
+ (princ "label=\"" stream)
+ (funcall vertex-labeler v stream)
+ (princ "\", " stream))
+ (funcall vertex-formatter v stream)
+ (princ "];" stream))))
+
+ (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
+ (directed-edge-tag (when (and (contains-undirected-edge-p g)
+ (contains-directed-edge-p g))
+ "dir=forward, ")))
+ (flet ((format-edge (e connector from to directed?)
+ (terpri stream)
+ (princ (funcall vertex-key from) stream)
+ (princ connector stream)
+ (princ (funcall vertex-key to) stream)
+ (princ " [" stream)
+ (when (and directed? directed-edge-tag)
+ (princ directed-edge-tag stream))
+ (when edge-key
+ (princ "label=\"" stream)
+ (funcall edge-labeler e stream)
+ (princ "\"," stream))
+ (funcall edge-formatter e stream)
+ (princ "];" stream)))
+ ;; directed edges
+ (iterate-vertexes
+ g
+ (lambda (v)
+ (iterate-target-edges
+ v
+ (lambda (e)
+ (when (directed-edge-p e)
+ (format-edge e directed-edge-connector
+ (source-vertex e) (target-vertex e) t))))))
+
+ ;; undirected edges
+ (let ((edges (make-container 'simple-associative-container)))
+ (iterate-vertexes
+ g
+ (lambda (v)
+ (iterate-edges
+ v
+ (lambda (e)
+ (when (and (undirected-edge-p e)
+ (not (item-at-1 edges e)))
+ (setf (item-at-1 edges e) t)
+ (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
+
+ (terpri stream)
+ (princ "}" stream)
+
+ (values g))
+
+
+#+Test
+(let ((g (make-container 'graph-container :default-edge-type :undirected)))
+ (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
+ (add-edge-between-vertexes g a b))
+ (graph->dot g nil))
+
+#+Test
+"graph G {
+E []
+C []
+B []
+A []
+D []
+F []
+D--E []
+E--F []
+B--C []
+A--B []
+B--D []
+D--F []
+}"
+
+#+Test
+(let ((g (make-container 'graph-container :default-edge-type :directed)))
+ (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
+ (add-edge-between-vertexes g a b))
+ (graph->dot g nil))
+
+#+Test
+"digraph G {
+E []
+C []
+B []
+A []
+D []
+F []
+E->F []
+B->C []
+B->D []
+A->B []
+D->E []
+D->F []
+}"
+
+#+Test
+(let ((g (make-container 'graph-container)))
+ (loop for (a b) in '((d e) (e f) (d f)) do
+ (add-edge-between-vertexes g a b :edge-type :directed))
+ (loop for (a b) in '((a b) (b c) (b d)) do
+ (add-edge-between-vertexes g a b :edge-type :undirected))
+ (graph->dot g nil))
+
+#+Test
+"graph G {
+E []
+C []
+B []
+A []
+D []
+F []
+E--F [dir=forward, ]
+D--E [dir=forward, ]
+D--F [dir=forward, ]
+B--C []
+A--B []
+B--D []
+}"
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot ((g basic-graph) (stream (eql nil))
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (with-output-to-string (out)
+ (apply #'graph->dot g out args)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot ((g basic-graph) (stream (eql t))
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (apply #'graph->dot g *standard-output* args))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot ((g basic-graph) (stream string)
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (with-open-file (out stream :direction :output :if-exists :supersede)
+ (apply #'graph->dot g out args)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot ((g basic-graph) (stream pathname)
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (apply #'graph->dot g (namestring stream) args))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot-properties ((g t) (stream t))
+ (values))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod vertex->dot ((v basic-vertex) (stream stream))
+ (values))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod edge->dot ((v basic-edge) (stream stream))
+ (values))
+
+;;; ---------------------------------------------------------------------------
+;;; dot->graph
+;;; ---------------------------------------------------------------------------
+
+#|
+(defmethod dot->graph ((dot-stream stream)
+ &key)
+ )
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod dot->graph ((dot-stream string)
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (with-open-file (out stream :direction :output :if-exists :supersede)
+ (apply #'dot->graph g out args)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod dot->graph ((dot-stream pathname)
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (with-open-file (out stream :direction :output :if-exists :supersede)
+ (apply #'dot->graph g out args))
+ (apply #'dot->graph g (namestring stream) args))
+
+|#
+
+(defparameter *dot-graph-attributes*
+ '((:size coord)
+ (:bb bounding-box)
+ (:page text)
+ (:ratio (:fill :compress :auto)) ;; Could actually be a float number too
+ (:margin float)
+ (:nodesep float)
+ (:ranksep float)
+ (:ordering (:out))
+ (:rankdir ("LR" "RL" "BT"))
+ (:pagedir text)
+ (:rank (:same :min :max))
+ (:rotate integer)
+ (:center integer)
+ (:nslimit float)
+ (:mclimit float)
+ (:layers text)
+ (:color text)
+ (:bgcolor text)))
+
+(defparameter *dot-vertex-attributes*
+ '((:pos coordinate)
+ (:height float)
+ (:width float)
+ (:fixed-size boolean)
+ (:label text)
+ (:shape (:record :plaintext :ellipse :circle :egg :triangle :box
+ :diamond :trapezium :parallelogram :house :hexagon :octagon
+ :doublecircle))
+ (:fontsize integer)
+ (:fontname text)
+ (:color text)
+ (:fillcolor text)
+ (:style (:filled :solid :dashed :dotted :bold :invis))
+ (:layer text)))
+
+(defparameter *dot-edge-attributes*
+ '((:pos spline)
+ (:minlen integer)
+ (:weight integer)
+ (:label text)
+ (:fontsize integer)
+ (:fontname text)
+ (:fontcolor text)
+ (:style (:solid :dashed :dotted :bold :invis))
+ (:color text)
+ (:dir (:forward :back :both :none))
+ (:tailclip boolean)
+ (:headclip boolean)
+ (:arrowhead (:none :normal :inv :dot :odot :invdot :invodot :tee
+ :empty :invempty :open :halfopen :diamond :odiamond
+ :box :obox :crow))
+ (:arrowtail (:none :normal :inv :dot :odot :invdot :invodot :tee
+ :empty :invempty :open :halfopen :diamond :odiamond
+ :box :obox :crow))
+ (:headlabel text)
+ (:taillabel text)
+ (:labelfontsize integer)
+ (:labelfontname text)
+ (:labelfontcolor text)
+ (:labeldistance integer)
+ (:port-label-distance integer)
+ (:decorate boolean)
+ (:samehead boolean)
+ (:sametail boolean)
+ (:constraint boolean)
+ (:layer text)))
+
+(defclass* dot-attributes-mixin ()
+ ((dot-attributes nil ia))
+ (:export-p t))
+
+(defclass* dot-graph-mixin (dot-attributes-mixin) ()
+ (:export-p t))
+(defclass* dot-vertex-mixin (dot-attributes-mixin) ()
+ (:export-p t))
+(defclass* dot-edge-mixin (dot-attributes-mixin) ()
+ (:export-p t))
+
+(defclass* dot-graph (graph-container dot-graph-mixin)
+ ()
+ (:default-initargs
+ :vertex-class 'dot-vertex
+ :directed-edge-class 'dot-directed-edge
+ :undirected-edge-class 'dot-edge)
+ (:export-p t))
+
+(defclass* dot-vertex (graph-container-vertex dot-vertex-mixin) ()
+ (:export-p t))
+(defclass* dot-edge (graph-container-edge dot-edge-mixin) ()
+ (:export-p t))
+(defclass* dot-directed-edge (directed-edge-mixin dot-edge) ()
+ (:export-p t))
+
+
+(defmethod (setf dot-attribute) :before (value (attr symbol) (thing dot-attributes-mixin))
+ (ensure-valid-dot-attribute attr thing))
+
+(defmethod (setf dot-attribute) (value (attr symbol) (thing dot-attributes-mixin))
+ (setf (getf (dot-attributes thing) attr) value))
+
+(defmethod dot-attribute-value ((attr symbol) (thing dot-attributes-mixin))
+ (getf (dot-attributes thing) attr))
+
+(defmethod graph->dot-properties ((graph dot-graph-mixin) (stream t))
+ (loop for (name value) on (dot-attributes graph) by #'cddr
+ do
+ (print-dot-key-value name value *dot-graph-attributes* stream)
+ (format stream " ;~%")))
+
+(defmethod vertex->dot ((vertex dot-vertex-mixin) (stream t))
+ (format-dot-attributes vertex *dot-vertex-attributes* stream))
+
+(defmethod edge->dot ((edge dot-edge-mixin) (stream t))
+ (format-dot-attributes edge *dot-edge-attributes* stream))
+
+(defun format-dot-attributes (object dot-attributes stream)
+ (loop for (name value) on (dot-attributes object) by #'cddr
+ for prefix = "" then ", " do
+ (write-string prefix stream)
+ (print-dot-key-value name value dot-attributes stream)))
+
+(defmethod ensure-valid-dot-attribute (key (object dot-graph-mixin))
+ (or (assoc key *dot-graph-attributes*)
+ (error "Invalid dot graph attribute ~S" key)))
+
+(defmethod ensure-valid-dot-attribute (key (object dot-vertex-mixin))
+ (or (assoc key *dot-vertex-attributes*)
+ (error "Invalid dot vertex attribute ~S" key)))
+
+(defmethod ensure-valid-dot-attribute (key (object dot-edge-mixin))
+ (or (assoc key *dot-edge-attributes*)
+ (error "Invalid dot edge attribute ~S" key)))
+
+(defun print-dot-key-value (key value dot-attributes stream)
+ (destructuring-bind (key value-type)
+ (or (assoc key dot-attributes)
+ (error "Invalid attribute ~S" key))
+ (format stream "~a=~a" (string-downcase key)
+ (etypecase value-type
+ ((member coordinate)
+ (with-output-to-string (str)
+ (princ "\"" str)
+ (let ((first t))
+ (dolist (el value)
+ (unless first
+ (princ "," str))
+ (princ el str)
+ (setf first nil)))
+ (princ "\"" str)))
+ ((member spline bounding-box)
+ (with-output-to-string (str)
+ (princ "\"" str)
+ (let ((first t))
+ (dolist (el value)
+ (unless first
+ (princ " " str))
+ (princ (first el) str)
+ (princ "," str)
+ (princ (second el) str)
+ (setf first nil)))
+ (princ "\"" str)))
+ ((member integer)
+ (unless (typep value 'integer)
+ (error "Invalid value for ~S: ~S is not an integer"
+ key value))
+ value)
+ ((member boolean)
+ (if value
+ "true"
+ "false"))
+ ((member text)
+ (textify value))
+ ((member float)
+ (coerce value 'single-float))
+ (list
+ (unless (member value value-type :test 'equal)
+ (error "Invalid value for ~S: ~S is not one of ~S"
+ key value value-type))
+ (if (symbolp value)
+ (string-downcase value)
+ value))))))
+
+(defun textify (object)
+ (let ((string (princ-to-string object)))
+ (with-output-to-string (stream)
+ (write-char #\" stream)
+ (loop for c across string do
+ ;; Note: #\\ should not be escaped to allow \n, \l, \N, etc.
+ ;; to work.
+ (case c
+ ((#\")
+ (write-char #\\ stream)
+ (write-char c stream))
+ (#\Newline
+ (write-char #\\ stream)
+ (write-char #\n stream))
+ (t
+ (write-char c stream))))
+ (write-char #\" stream))))
+
+;;; ---------------------------------------------------------------------------
+;
+; Calls the dot executable to create external output for graphs
+;
+#+(or win32 mswindows)
+(defvar *dot-path* "\"C:/Program Files/ATT/Graphviz/bin/dot.exe\"")
+#+(or linux unix)
+(defvar *dot-path* "/usr/bin/dot" "Path to `dot`")
+
+(defmethod graph->dot-external ((g basic-graph) file-name &key (type :ps))
+ "Generate an external represenation of a graph to a file, by running
+the program in *dot-path*."
+ (let ((dot-string (graph->dot g nil))
+ (dot-type (concatenate 'string "-T" (string-downcase (symbol-name type)))))
+ #+lispworks (with-open-stream
+ (s (sys:open-pipe (concatenate 'string *dot-path* " -Tpng -o" file-name)
+ :direction :input))
+ (write-line dot-string s)
+ (force-output s)
+ (close s))
+ #+sbcl
+ (sb-ext:run-program *dot-path*
+ (list dot-type "-o" file-name)
+ :input (make-string-input-stream dot-string)
+ :output *standard-output*)
+ #-(or sbcl lispworks)
+ (error "Don't know how to execute a program on this platform")))
+
+;;; ---------------------------------------------------------------------------
+;
+; Test dot external
+;
+(defun test-dot-external ()
+ (let* ((g (make-graph 'dot-graph))
+ (v1 (add-vertex g 'a :dot-attributes '(:shape :box
+ :color :blue)))
+ (v2 (add-vertex g 'b :dot-attributes '(:shape :circle
+ :style :filled
+ :color :yellow))))
+ (add-edge-between-vertexes g v1 v2
+ :dot-attributes '(:arrowhead :open
+ :arrowtail :normal
+ :style :dotted))
+ (print (graph->dot g nil))
+ (graph->dot-external g "/tmp/test.gif" :type :gif)))
#:target-vertex
#:source-vertex
+ #:layout-graph-with-graphviz
+ #:dot-attribute-value
+ #:dot-attribute
+
#:add-edge ; graph edge
#:delete-edge ; graph edge
projects / cl-graph.git / commitdiff