;;
;; Prints a graph in various formats.
;;
;; Copyright 2007-2009 Ivan Raikov.
;;
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;

(module format-graph

 (make-format-graph
  graph->sexp)
		   
 (import scheme chicken data-structures )

 (require-extension srfi-1 srfi-13 matchable)


(define (graph->sexp g)
  `(graph (name  ,(g 'name))
	  (nodes ,@(map (lambda (iv) `(node (id ,(car iv)) (info ,(cadr iv))))
			((g 'nodes))))
	  (edges ,@(map (lambda (v) `(edge (i ,(car v)) (j ,(cadr v)) (info ,(caddr v))))  
			((g 'edges))))))

(define (make-format-graph type)
  (case type
    ((dot)      dotformat)
    ((vcg)      vcgformat)
    (else (error 'make-format-graph "unknown format type " type))))


;; GraphViz dot format
(define (dotformat out g . rest)
  (display "digraph " out)
  (display (g 'name) out)
  (display " {\n" out)
  ;; statements for e.g. default attributes of nodes and edges
  (for-each 
   (lambda (x) 
     (match x ((stmt name val) 
	       (begin
		 (display "  " out)
		 (display stmt out)
		 (display " [" out)
		 (display name out)
		 (display "=" out)
		 (if (string? val)
		     (write val out)
		     (display val out))
		 (display "];\n" out)))
	    ((name val) 
	     (begin
		 (display name out)
		 (display "=" out)
		 (if (string? val)
		     (write val out)
		     (display val out))
		 (display ";\n" out)))
	    ((stmt)  (begin
		       (display stmt out)
		       (display ";\n" out)))
	    (else (void)))) rest)
  ;; print nodes
  (for-each (lambda (iv) 
	      (display "  n" out)
	      (display (car iv) out)
	      (let ((info (cadr iv)))
		(if info 
		    (begin
		      (display " [label=" out)
		      (if (string? info)
			  (write info out)
			  (begin (display "\"" out)
				 (display info out)
				 (display "\"" out)))
		      (display "]" out))))
	      (display ";\n" out))
	    ((g 'nodes)))
  ;; print edges
  (for-each (lambda (v) 
	      (match v
		     ((i j info)   
		      (begin
			(display "  n" out)
			(display i out)
			(display " -> " out)
			(display "n" out)
			(display j out)
			(if info 
			    (begin
			      (display " [label=" out)
			      (if (string? info)
				  (write info out)
				  (begin (display "\"" out)
					 (display info out)
					 (display "\"" out)))
			      (display "]" out)))
			(display ";\n" out)))
		     (else (error 'dotformat "invalid edge: " v))))
	    ((g 'edges)))
  (display "\n}\n" out))
  


;; VCG format
(define (vcgformat out g . rest)

  (define (node-title i out)
    (write (string-concatenate (list "n" (number->string i)))
	   out))

  (display "graph: {\n" out)
  (display "  title: " out)
  (let ((title (g 'name)))
    (if (string? title)
	(write title out)
	(begin (display "\"" out)
	       (display title out)
	       (display "\"" out))))
  (display "\n" out)
  ;; statements for e.g. default attributes of nodes and edges
  (for-each 
   (lambda (x) 
     (match x ((name val) 
	       (begin
		 (display "  " out)
		 (display name out)
		 (display ": " out)
		 (display val out)
		 (display "\n" out)))
	    (else (void)))) rest)
  ;; print nodes
  (for-each (lambda (iv) 
	      (display "  node: {\n" out)
	      (display "    title: " out)
	      (node-title (car iv) out)
	      (display "\n")
	      (let ((info (cadr iv)))
		(if info 
		    (begin
		      (display "    label: " out)
		      (if (string? info)
			  (write info out)
			  (begin (display "\"" out)
				 (display info out)
				 (display "\"" out)))
		      (display "\n" out))))
	      (display "  }\n" out))
	    ((g 'nodes)))
  ;; print edges
  (for-each (lambda (v) 
	      (match v
		     ((i j info)   
		      (begin
			(display "  edge: {\n" out)
			(display "    sourcename: " out)
			(node-title i out)
			(display "\n" out)
			(display "    targetname: " out)
			(node-title j out)
			(display "\n" out)
			(if info 
			    (begin
			      (display "    label: " out)
			      (if (string? info)
				  (write info out)
				  (begin (display "\"" out)
					 (display info out)
					 (display "\"" out)))
			      (display "\n" out)))
			(display "  }\n" out)))
		     (else (error 'dotformat "invalid edge: " v))))
	    ((g 'edges)))
  (display "\n}\n" out))
)