;;
;; Graph description generator for graphs of arbitrary Scheme objects.
;;
;; Based on the bouquet Common Lisp package by Eugene Zaikonnikov.
;;
;; Copyright 2010-2011 Ivan Raikov and the Okinawa Institute of Science and Technology.
;;
;;
;; 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 object-graph
	
	(assoc-node lookup-node lookup-object-node assoc-node 
         assoc-edge lookup-edge lookup-cluster lookup-property 
	 lookup-node-property lookup-edge-property
	 reset-graph register-node register-edge
	 register-node-unless-exists
	 add-to-cluster new-cluster new-property
	 set-node-property set-edge-property reset-property
	 set-label label 

	 cluster-nodes cluster-name cluster-subclusters cluster-edges
	 node-object node-edges

	 render-graph/tlp
	 render-graph/dot
	 )

	(import scheme chicken)
	(require-library srfi-1 srfi-13 srfi-69)
	(import (only extras format)
		(only ports call-with-output-string)
		(only data-structures ->string alist-ref identity intersperse)
		(only srfi-1 every filter)
		(only srfi-13 string-concatenate)
		(only srfi-69 string-hash)
		)
	

(define-record-type node
  (make-node object edges)
  node?
  (object node-object )
  (edges node-edges ))


(define-record-type edge
  (make-edge from to)
  edge?
  (from edge-from )
  (to edge-to))


(define-record-type cluster
  (make-cluster name nodes edges subclusters)
  cluster?
  (name cluster-name)
  (subclusters cluster-subclusters)
  (nodes cluster-nodes)
  (edges cluster-edges))


(define-record-type property
  (make-property cluster name type nodes-default edges-default node-elements edge-elements)
  property?
  (cluster property-cluster)
  (name property-name)
  (type property-type)
  (nodes-default property-nodes-default) 
  (edges-default property-edges-default)
  (node-elements property-node-elements)
  (edge-elements property-edge-elements))


(define (hash x)  (string-hash (->string x)))

(define graph-nodes (make-parameter '()))

(define graph-edges (make-parameter '()))

(define graph-clusters (make-parameter '()))

(define graph-properties (make-parameter '()))

(define object-count (make-parameter 0))

(define (push obj param)  (param (cons obj (param))))

(define (assoc-node node) (assoc (hash (node-object node)) (graph-nodes)))

(define (lookup-node node) (alist-ref (hash (node-object node)) (graph-nodes)))

(define (lookup-object-node object) (alist-ref (hash object) (graph-nodes)))

(define (assoc-edge edge)
  (let ((h (hash (cons (node-object (edge-from edge)) (node-object (edge-to edge))))))
    (assoc h  (graph-edges))))

(define (lookup-edge from to)  (alist-ref (hash (cons from to)) (graph-edges)))

(define (lookup-cluster name)  (alist-ref (hash name) (graph-clusters)))

(define (lookup-property name)  (alist-ref (hash name) (graph-properties)))

(define (lookup-node-property name node)
  (let ((property (lookup-property name)))
    (and property (alist-ref (hash (node-object node)) 
			     ((property-node-elements property))))))

(define (lookup-edge-property name edge)
  (let ((property (lookup-property name)))
    (and property (alist-ref (hash (cons (edge-from edge) (edge-to edge)))
			     ((property-edge-elements property))))))

(define (reset-graph)
  (graph-nodes '())
  (graph-edges '())
  (graph-clusters '())
  (graph-properties '())
  (new-property "viewLabel" 'string #f)
  (new-property "viewSize" 'size #f 
		 nodes-default: "(10,10,10)" 
		 edges-default: "(1,1,1)")
  )

;; Registers an object and returns its node
(define (register-node object)
  (let ((node (make-node object (make-parameter '()))))
    (if (lookup-node node)
	(error 'register-node "graph node is already defined" node))
    (push (cons (hash (node-object node)) node) graph-nodes)
    node))


(define (register-node-unless-exists node)
  (if (lookup-node node) node (register-node node)))


;; Registers a directed edge from -> to, and returns its handle
(define (register-edge from to)
  (let ((from (if (node? from) from (lookup-object-node from)))
	(to (if (node? to) to (lookup-object-node to))))
    (if (not (and from to)) (error 'register-edge "undefined node given"))
    (if  (lookup-edge from to)
	 (error 'register-edge "Graph edge is already defined" from to))
    (let ((edge (make-edge from to)))
      (push (cons (hash (cons (node-object from) (node-object to))) edge) graph-edges)
      (push edge (node-edges from))
      (push edge (node-edges to))
      edge)))


;; Adds object to cluster; returns the object, to allow composition
(define (add-to-cluster cluster object)
  (if (not (cluster? cluster))
      (error 'add-to-cluster "invalid cluster argument given" cluster))
  (cond ((node? object)
	 (let ((p (assoc-node object)))
	   (if (not p) (error 'add-to-cluster "invalid node given" object))
	   (push p (cluster-nodes cluster))
	   p))
	((edge? object)
	 (let ((p (assoc-edge object)))
	   (if (not p) (error 'add-to-cluster "invalid edge given" object))
	   (push p (cluster-edges cluster))
	   p))
	(else (add-to-cluster cluster (lookup-object-node object)))))

;; Creates a cluster from the given nodes, edges and subcluster objects
(define (new-cluster name #!key 
		      (nodes '())
		      (edges '())
		      (subclusters '()))
  (if (not (every node? nodes))
      (error 'new-cluster "arguments nodes must be a list of nodes" nodes))
  (if (not (every edge? edges))
      (error 'new-cluster "arguments edges must be a list of edges" edges))
  (if (not (every cluster? subclusters))
      (error 'new-cluster "arguments subclusters must be a list of clusters" subclusters))
  (let ((cluster (make-cluster name
			       (make-parameter (map assoc-node nodes) )
			       (make-parameter (map assoc-edge edges) )
			       (make-parameter subclusters))))
    (push (cons (hash name) cluster) graph-clusters)
    cluster))

(define (new-property name type cluster  
		      #!key (nodes-default "") (edges-default ""))
  (let ((property (make-property cluster name type nodes-default edges-default 
				 (make-parameter '())
				 (make-parameter '()))))
    (push (cons (hash name) property) graph-properties)
    property))


(define (set-node-property property node value)
  (push (cons (hash (node-object node)) value) 
	 (property-node-elements property))
  property)

(define (set-edge-property property edge value)
  (push (cons (hash (cons (node-object (edge-from edge)) (node-object (edge-to edge)))) value)
	 (property-edge-elements property))
  property)

(define (reset-property property)
  ((property-edge-elements property) (make-parameter '()))
  ((property-node-elements property) (make-parameter '()))
  property)


(define (set-label object value)
  (let ((property (lookup-property "viewLabel")))
    (cond ((node? object) 
	   (set-node-property property object value))
	  ((edge? object)
	   (set-edge-property property object value))
	  (else
	   (set-label (lookup-object-node object) value)))))

(define (label object)
  (cond ((node? object)
	 (lookup-node-property "viewLabel" object))
	((edge? object)
	 (lookup-edge-property "viewLabel" object))
	(else
	 (label (lookup-object-node object)))))

;; Prints the graph in Tulip .tlp format to the given output port

(define (render-graph/tlp out)

  (define (format-edge p)
    (let ((id (car p))
	  (edge (cdr p)))
      (let ((from (hash (node-object (edge-from edge))))
	    (to (hash (node-object (edge-to edge)))))
      (format out "~A~%" `(edge ,id ,from ,to)))))

  (define (format-cluster out p)
    (let ((id (car p))
	  (cluster (cdr p)))
      (format out "(cluster ~A ~A~%~A~%~A~%~A)~%"
	      id (cluster-name cluster)
	      `(nodes . ,(map car ((cluster-nodes cluster))))
	      `(edges . ,(map car ((cluster-edges cluster))))
	      (call-with-output-string
	       (lambda (out)
		 (for-each (lambda (c) (format-cluster out c)) ((cluster-subclusters cluster)))))
	      )))

  (define (format-property property )
    (format out "(property ~A ~A ~A (default ~S ~S)~%~A~A)~%"
	    (or (property-cluster property) 0)
	    (property-type property)
	    (property-name property)
	    (property-nodes-default property)
	    (property-edges-default property)
	    (call-with-output-string
	     (lambda (out)
	       (for-each 
		(lambda (n) (format out "~S~%" `(node ,(car n) ,(cdr n))))
		((property-node-elements property)))))
	    (call-with-output-string
	     (lambda (out)
	       (for-each 
		(lambda (e) (format out "~S~%" `(edge ,(car e) ,(cdr e))))
		((property-edge-elements property)))))
	    ))

  (let ((all-nodes (map car (graph-nodes)))
	(all-edges (graph-edges))
	(all-clusters (graph-clusters))
	(all-properties (map cdr (graph-properties))))
    (format out "(tlp ~S~%" "2.0")
    (format out "~A~%" `(nodes . ,all-nodes))
    (for-each format-edge all-edges)
    (for-each (lambda (c) (format-cluster out c)) all-clusters)
    (for-each format-property all-properties)
    (format out ")")
    ))


;; Prints the graph in Graphviz dot format to the given output port

(define (render-graph/dot out)
  (define (format-edge p)
    (let ((id (car p))
	  (edge (cdr p)))
      (let ((from (hash (node-object (edge-from edge))))
	    (to (hash (node-object (edge-to edge)))))
      (format out "n~A -> n~A;~%" from to))))

  (define (format-cluster out p)
    (let ((id (car p))
	  (cluster (cdr p)))
      (format out "subgraph c~A {~%" id)
      ;;(cluster-name cluster)
      (for-each (lambda (node) (format out "n~A;~%" node)) (map car ((cluster-nodes cluster))))
      (for-each format-edge ((cluster-edges cluster)))
      (call-with-output-string
       (lambda (out)
	 (for-each (lambda (c) (format-cluster out c)) ((cluster-subclusters cluster)))))
      (format out "}~%")
      ))

  (let ((all-nodes (map car (graph-nodes)))
	(all-edges (graph-edges))
	(all-clusters (graph-clusters))
	(all-properties (map cdr (graph-properties))))
    (format out "digraph G {~%")
    (for-each (lambda (node-hash) 
		  (let ((attrs (filter identity
				        (map (lambda (p) 
					       (let ((pn   (property-name p))
						     (nes  ((property-node-elements p))))
						 (let ((n (cond ((equal? pn "viewLabel") "label")
								(else pn)))
						       (v (alist-ref node-hash nes)))
						   (and v (sprintf "~A=~S" n v)))))
					     all-properties)
					)))
		    (if (null? attrs)
			(format out "n~A;~%" node-hash)
			(format out "n~A[~A];~%" node-hash (string-concatenate (intersperse attrs ","))))
		    ))
	      all-nodes)
    (for-each format-edge all-edges)
    (for-each (lambda (c) (format-cluster out c)) all-clusters)
    (format out "}~%")
    ))



)