From b621ac7a68fbf0d4ee562c4b2eeb7b6d707efa81 Mon Sep 17 00:00:00 2001 From: "attila.lendvai" Date: Sat, 18 Feb 2006 20:17:13 -0500 Subject: [PATCH] Initial cl-graphviz integration darcs-hash:20060219011713-6b9e8-f0bdaddb78f2f121dc95a94e4e4f5468130d1399.gz --- cl-graph.asd | 17 +- dev/graph.lisp | 2 +- dev/graphviz-support.lisp | 450 ------------------------ dev/graphviz/graphviz-support-optional.lisp | 74 ++++ dev/graphviz/graphviz-support.lisp | 490 +++++++++++++++++++++++++++ dev/package.lisp | 4 + 6 files changed, 582 insertions(+), 455 deletions(-) delete mode 100644 dev/graphviz-support.lisp create mode 100644 dev/graphviz/graphviz-support-optional.lisp create mode 100644 dev/graphviz/graphviz-support.lisp diff --git a/cl-graph.asd b/cl-graph.asd index 3bad408..9fe2530 100644 --- a/cl-graph.asd +++ b/cl-graph.asd @@ -20,7 +20,7 @@ instructions.")) (asdf:operate 'asdf:load-op 'asdf-system-connections) -(defsystem cl-graph +(defsystem cl-graph :version "0.8" :author "Gary Warren King " :maintainer "Gary Warren King " @@ -42,10 +42,11 @@ instructions.")) :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")))))) @@ -65,3 +66,11 @@ instructions.")) :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"))))))) diff --git a/dev/graph.lisp b/dev/graph.lisp index 8a17dc1..8a7bd94 100644 --- a/dev/graph.lisp +++ b/dev/graph.lisp @@ -672,7 +672,7 @@ something is putting something on the vertexes plist's (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)) diff --git a/dev/graphviz-support.lisp b/dev/graphviz-support.lisp deleted file mode 100644 index b77cfa4..0000000 --- a/dev/graphviz-support.lisp +++ /dev/null @@ -1,450 +0,0 @@ -;;;-*- 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))) diff --git a/dev/graphviz/graphviz-support-optional.lisp b/dev/graphviz/graphviz-support-optional.lisp new file mode 100644 index 0000000..b1b2e07 --- /dev/null +++ b/dev/graphviz/graphviz-support-optional.lisp @@ -0,0 +1,74 @@ +;;;-*- 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) + + diff --git a/dev/graphviz/graphviz-support.lisp b/dev/graphviz/graphviz-support.lisp new file mode 100644 index 0000000..e07e661 --- /dev/null +++ b/dev/graphviz/graphviz-support.lisp @@ -0,0 +1,490 @@ +;;;-*- 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))) diff --git a/dev/package.lisp b/dev/package.lisp index 22dcebc..5cf6d08 100644 --- a/dev/package.lisp +++ b/dev/package.lisp @@ -92,6 +92,10 @@ DISCUSSION #:target-vertex #:source-vertex + #:layout-graph-with-graphviz + #:dot-attribute-value + #:dot-attribute + #:add-edge ; graph edge #:delete-edge ; graph edge -- 1.7.10.4