;;
;; 
;; Persistent directed graph based on adjacency intervals.
;;
;; Copyright 2010-2013 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 interval-digraph


 (
  interval-digraph  
  <IntervalDigraph> 
;;  digraph-union digraph-disjoint-union digraph-rename
;;  make-random-gnp-digraph
  )

		   
 (import scheme chicken)
 (require-extension rb-tree typeclass)
 (require-library cis )
 (import (prefix cis cis:))
 (import (only data-structures alist-ref compose ->string)
	 (only srfi-1 find any append-reverse delete-duplicates fold))


(define (interval-digraph:error x . rest)
  (let ((port (open-output-string)))
    (let loop ((objs (cons x rest)))
      (if (null? objs)
	  (begin
	    (newline port)
	    (error 'digraph (get-output-string port)))
	  (begin (display (car objs) port)
		 (display " " port)
		 (loop (cdr objs)))))))


(define (alist-update k v alst #!optional (eq eq?))
  (cons (cons k v)
        (let recur ((alst alst) (ax '()))
          (cond ((null? alst) (reverse ax))
                ((eq k (car (car alst))) (recur (cdr alst) ax))
                (else (recur (cdr alst) (cons (car alst) ax)))))))


(define (node-set-lookup-compare x y)
  (if (cis:subset? x y)  0
      (let ((xmax (cis:get-max x))
	    (xmin (cis:get-min x))
	    (ymax (cis:get-max y))
	    (ymin (cis:get-min y)))
	(cond ((fx= ymax xmax) (fx- ymin xmin))
	      (else (fx- ymax xmax))))
      ))

	
(define (node-set-insdel-compare x y)
  (let ((xmax (cis:get-max x))
	(xmin (cis:get-min x))
	(ymax (cis:get-max y))
	(ymin (cis:get-min y)))
    (cond ((fx= ymax xmax) (fx- ymin xmin))
	  (else (fx- ymax xmax)))))


(define-record-type interval-digraph
  (make-interval-digraph name label nodes context-tree)
  interval-digraph?
  (name         graph-name)
  (label        graph-label)
  (nodes        graph-nodes)
  (context-tree graph-context)
  )


(define-record-type context
  (make-context node label edges)
  context?
  (node         context-node)
  (label        context-label)
  (edges        context-edges)
  )


(define (context-add-edge c e)
  (make-context (context-node c)
                (context-label c)
                (cons e (context-edges c))))

(define prop-map
  (rb-tree-map node-set-lookup-compare 
               insdel-key-compare: node-set-insdel-compare))


(define node-map
  (rb-tree-map fx-))


(import-instance (<PersistentMap> prop-map prop.)
		 (<PersistentMap> node-map node.))


(define-class <IntervalDigraph> 
  empty
  empty?
  size
  order
  nodes
  nodes-with-labels
  node-label
  edges
  edges-with-labels
  edge-label
  add-node
  add-node-interval
  add-edge
  add-edge-interval
  get-succ
  out-edges
  has-edge
  has-node
  has-node-interval
  foreach-node
  foreach-node-with-label
  foreach-edge
  foreach-edge-with-label
  )


(define (empty name label)
  (make-interval-digraph name label cis:empty (node.empty) ))


(define (get-nodes g) (cis:elements (graph-nodes g)))

  
(define (get-nodes-with-labels g) 
  ((node.map (graph-context g))
   (lambda (v) 
     (cons (context-node v)
           (context-label v)))
   ))
  

(define (node-label g i) 
  (let ((context (graph-context g)))
    (let ((c ((node.get-value context) i)))
      (context-label c))))


(define (get-edges g) 
  ((node.foldi (graph-context g))
   (lambda (i v ax) 
     (fold (lambda (e ax)
             (cis:fold-left (lambda (j ax) (cons (list i j) ax)) ax (car e)))
           ax (context-edges v))
     )
   '()
   ))



(define (get-edges-with-labels g) 
  ((node.foldi (graph-context g))
   (lambda (i v ax) 
     (fold
      (lambda (e ax) 
        (let ((l (cdr e)))
          (cis:fold-left (lambda (j ax) (cons (list i j l) ax)) ax (car e))))
      ax (context-edges v))
     )
   '() 
   ))


(define (edge-label g i j) 
  (let ((context (graph-context g)))
    (let ((c ((node.get-value context) i)))
      (let ((es (context-edges c)))
        (let ((e (find (lambda (e) (cis:in? j (car e))) es)))
          (and e (cdr e))
          ))
      ))
  )



(define (order g)  (cis:cardinal (graph-nodes g)))

(define (size g)   ((node.fold (graph-context g))
                    (lambda (v ax) 
                      (fold
                       (lambda (e ax) (+ (cis:cardinal (car e)) ax))
                       ax (context-edges v)))
                    0))


(define (add-node g i #!key (label #f) )
  (make-interval-digraph 
   (graph-name g) (graph-label g)
   (cis:add i (graph-nodes g))
   (node.put (graph-context g)
             i (make-context i label (list) ))
   ))


(define (add-node-interval g i #!key (label #f) )
  (make-interval-digraph 
   (graph-name g) (graph-label g)
   (cis:union i (graph-nodes g))
   (cis:fold-left
    (lambda (ii ax)
      (node.put ax
                ii (make-context ii label (list) )))
    (graph-context g) i)
   ))
	    

(define (add-edge g e #!key (label #f))
  
  (cond ((and (pair? e) (pair? (cdr e)))
         
         (let ((i (car e)) (j (cadr e)) 
               (nodes (graph-nodes g)) 
               (context (graph-context g)))
           
           (and (cis:in? i nodes) (cis:in? j nodes) 
                (let ((oi ((node.get-value context) i)))

                  (let ((context1 (node.put context i (context-add-edge oi (cons (cis:singleton j) label)))))

                    (make-interval-digraph 
                     (graph-name g) (graph-label g)
                     nodes context1)
                    ))
                ))
         )

        (else (interval-digraph:error 'add-edge ": invalid edge " e))
        ))


(define (add-edge-interval g es #!key (label #f))
  
  (cond ((and (pair? es) (pair? (cdr es)))
         
         (let ((i (car es)) (j (cadr es)) 
               (nodes (graph-nodes g)) 
               (context (graph-context g)))
           
           (and (cis:in? i nodes) (cis:subset? j nodes) 
                (let ((oi ((node.get-value context) i)))
                  (let ((context-tree1 (node.put context i (context-add-edge oi (cons j label)))))
                    (make-interval-digraph 
                     (graph-name g) (graph-label g)
                     nodes context-tree1)
                    ))
                ))
         )

        (else (interval-digraph:error 'add-edge ": invalid edge " es))
        ))


(define (get-succ g i)
  (and (cis:in? i (graph-nodes g)
                ((node.get-value (graph-context g)) i))))


(define (out-edges g i)
  (and (cis:in? i (graph-nodes g) )
       (let ((c ((node.get-value (graph-context g)) i)))
         (fold (lambda (e ax) (cis:fold-left (lambda (j ax) (list i j))  ax (car e)))
               '()
               (context-edges c)))))


(define (has-edge g i j)   
  (and (cis:in? i (graph-nodes g))
       (let ((c ((node.get-value (graph-context g)) i)))
         (any (lambda (e ax) (cis:in? j (car e))) 
              (context-edges c)))))
				       
  
(define (has-node g i)           (cis:in? i (graph-nodes g) ))

(define (has-node-interval g i)  (cis:subset? i (graph-nodes g) ))



(define (foreach-node g f)   (cis:foreach (lambda (i) (f i)) (graph-nodes g)))


(define (foreach-node-with-label g f)
  ((node.for-each-ascending (graph-context g))
   (lambda (v) 
     (f (context-node v) (context-label v)))
   ))


(define (foreach-edge g f #!key (default-label 'undefined))
  ((node.for-each-ascending (graph-context g))
   (lambda (v) 
     (let ((i (context-node (cdr v))))
       (for-each
        (lambda (e)
          (cis:foreach (lambda (j) (f i j)) (car e)))
        (context-edges (cdr v))))
     )
   ))


(define (foreach-edge-with-label g f)
  ((node.for-each-ascending (graph-context g))
   (lambda (v) 
     (let ((i (context-node (cdr v))))
       (for-each
        (lambda (e)
          (let ((l (cdr e)))
            (cis:foreach (lambda (j) (f i j l)) (car e))))
        (context-edges (cdr v))))
     )
   ))


(define (interval-digraph)
  (make-<IntervalDigraph>
  ;; empty
  empty
  ;; empty?
  (lambda (g) (cis:empty? (graph-nodes g)))
  ;; size
  size
  ;; order
  order
  ;; nodes
  get-nodes
  ;; nodes-with-labels
  get-nodes-with-labels
  ;; node-label
  node-label
  ;; edges
  get-edges
  ;; edges-with-labels
  get-edges-with-labels
  ;; edge-label
  edge-label
  ;; add-node
  add-node
  ;; add-node-interval
  add-node-interval
  ;; add-edge
  add-edge
  ;; add-edge-interval
  add-edge-interval
  get-succ
  out-edges
  has-edge
  has-node
  has-node-interval
  foreach-node
  foreach-node-with-label
  foreach-edge
  foreach-edge-with-label
  ))



#|
(define (merge a b compare merge-fn)
  (let recur ((a a) (b b) (l '()))
    (cond ((and (null? a) (null? b)) (reverse l))
	  ((null? a) (append-reverse l b))
	  ((null? b) (append-reverse l a))
	  (else
	   (let ((c (compare (car a) (car b))))
	     (cond ((negative? c)  (recur (cdr a) b (cons (car a) l)))
		   ((zero? c)      (recur (cdr a) (cdr b) (cons (merge-fn (car a) (car b)) l)))
		   ((positive? c)  (recur a (cdr b) (cons (car b) l))))))
	  )))



(define (digraph-union a b merge-label)

  (define (merge-nodes a b)
    (merge a b
     (lambda (x y) (fx- (car x) (car y)))
     (lambda (x y) x)))

  (define (merge-nodes-with-labels a b)
    (merge a b
     (lambda (x y) (fx- (car x) (car y)))
     (lambda (x y) (list (car x) (merge-label (cadr x) (cadr y))))))

  (define (merge-edges a b)
    (merge a b
     (lambda (x y) (let ((c (fx- (car x) (car y))))
		     (if (zero? c) (fx- (cadr x) (cadr y)) c)))
     (lambda (x y) x)))

  (define (merge-edges-with-labels a b)
    (merge a b
	   (lambda (x y) (let ((c (fx- (car x) (car y))))
			   (if (zero? c) (fx- (cadr x) (cadr y)) c)))
	   (lambda (x y) (list (car x) (cadr x) (merge-label (caddr x) (caddr y))))))

  
  (let recur ((a a) (b b))

    (let* (;; accessors
	   (name                  (string-append "union " (a 'name) (b 'name)))
	   (label                 (merge-label (a 'label) (b 'label)))
	   (nodes                 (lambda () (cis:elements (cis:union (a 'node-intervals) (b 'node-intervals)))))
	   (nodes-with-labels     (lambda ()
				    (merge-nodes-with-labels
				     (a 'nodes-with-labels)
				     (b 'nodes-with-labels))))
	   (node-intervals        (lambda () (cis:union (a 'node-intervals) (b 'node-intervals))))
	   (edges                 (lambda () (merge-edges (a 'edges) (b 'edges))))
	   (edges-with-labels     (lambda () (merge-edges-with-labels 
					      (a 'edges-with-labels) 
					      (b 'edges-with-labels))))
	   (order                  (lambda () (cis:cardinal (cis:union (a 'node-intervals) (b 'node-intervals)))))
	   (size                   (lambda () (length (edges))))
	   (capacity               order)
	   (out-edges                (lambda (i)   (merge-edges ((a 'out-edges) i) ((b 'out-edges) i))))
	   (succ                     (lambda (i)   (cis:elements (cis:union ((a 'succ-interval) i)  ((b 'succ-interval) i)))))
	   (succ-interval            (lambda (i)   (cis:union ((a 'succ-interval) i)  ((b 'succ-interval) i))))
	   (has-edge                 (lambda (i j) (or ((a 'has-edge) i j) ((b 'has-edge) i j))))
	   (has-node                 (lambda (i)   (or ((a 'has-node) i) ((b 'has-node) i))))
	   (has-node-interval        (lambda (i)   (or ((a 'has-node-interval) i) ((b 'has-node-interval) i))))
	   (node-property-list-keys       (lambda ()   (delete-duplicates (append ((a 'node-property-list-keys)) ((b 'node-property-list-keys))))))
	   (node-property            (lambda (p i)  (or ((a 'node-property) p i) ((b 'node-property) p i))))
	   (node-interval-property   (lambda (p i)  (or ((a 'node-interval-property) p i) ((b 'node-interval-property) p i))))
	   (node-label               (lambda (i)    (or ((a 'node-label) i) ((b 'node-label) i))))
	   (edge-property-list-keys  (lambda () (delete-duplicates (append ((a 'edge-property-list-keys)) ((b 'edge-property-list-keys))))))
	   (edge-property-list-map   (lambda () (delete-duplicates (append ((a 'edge-property-list-map)) ((b 'edge-property-list-map))))))
	   (edge-property            (lambda (p i j)  (or ((a 'edge-property) p i j) ((b 'edge-property) i j))))
	   (edge-interval-property   (lambda (p i j)  (or ((a 'edge-interval-property) p i j) ((b 'edge-interval-property) i j))))
	   (foreach-node             (lambda (f) (for-each f (nodes))))
	   (foreach-node-with-label  (lambda (f) (for-each f (nodes-with-labels))))
	   (foreach-edge             (lambda (f) (for-each f (edges))))

	   ;; transformers
	   (add-node
	    (lambda (n #!key (label #f))
	      (recur ((a 'add-node) n label: label) ((b 'add-node) n label: label))))
	   (add-node-interval
	    (lambda (i #!key (label #f))
	      (recur ((a 'add-node-interval) i label: label) ((b 'add-node-interval) i label: label))))
	   (add-edge-interval  
	    (lambda (e)
	      (recur ((a 'add-edge-interval) e) ((b 'add-edge-interval) e))))
			  
	   (edge-interval-property-set      
	    (lambda (p i j v)  (let* ((a1 ((a 'edge-interval-property-set) p i j v))
				      (b1 (and (not a1) ((b 'edge-interval-property-set) p i j v))))
				 (cond (a1 (recur a1 b))
				       (b1 (recur a b1))
				       (else (recur a b))))))
	   (node-interval-property-set      
	    (lambda (p i v)    (let* ((a1 ((a 'node-interval-property-set) p i v))
				      (b1 (and (not a1) ((b 'node-interval-property-set) p i v))))
				 (cond (a1 (recur a1 b))
				       (b1 (recur a b1))
				       (else (recur a b))))))
	   (node-label-set         
	    (lambda (i v)      (let* ((a1 ((a 'node-label-set) i v))
				      (b1 (and (not a1) ((b 'node-label-set) i v))))
				 (cond (a1 (recur a1 b))
				       (b1 (recur a b1))
				       (else (recur a b))))))
	   (node-property-set      
	    (lambda (p i v)    (let* ((a1 ((a 'node-property-set) p i v))
				      (b1 (and (not a1) ((b 'node-property-set) p i v))))
				 (cond (a1 (recur a1 b))
				       (b1 (recur a b1))
				       (else (recur a b))))))
	   (edge-property-set      
	    (lambda (p i j v)  (let* ((a1 ((a 'edge-property-set) p i j v))
				      (b1 (and (not a1) ((b 'edge-property-set) p i j v))))
				 (cond (a1 (recur a1 b))
				       (b1 (recur a b1))
				       (else (recur a b))))))
				 
	   )

    (lambda (selector)
      (case selector
	;; accessors
	((name)                        name)
	((label)                       label)
	((nodes)                       nodes)
	((nodes-with-labels)           nodes-with-labels)
	((node-intervals)              node-intervals)
	((edges)                       edges)
	((edges-with-labels)           edges-with-labels)
	((order)                       order)
	((size)                        size)
	((capacity)                    capacity)
	((out-edges)                   out-edges)
	((succ)                        succ)
	((succ-interval)               succ-interval)
	((has-edge)                    has-edge)
	((has-node)                    has-node)
	((has-node-interval)           has-node-interval)
	((node-property-list-keys)          node-property-list-keys)
	((node-property)               node-property)
	((node-interval-property)      node-interval-property)
	((node-label)                  node-label)
	((edge-property)               edge-property)
	((edge-property-list-keys)     edge-property-list-keys)
	((edge-property-list-map)      edge-property-list-map)
	((foreach-node)                foreach-node)
	((foreach-node-with-label)     foreach-node-with-label)
        ((foreach-edge)                foreach-edge)

	;; transformers
	((add-node)                    add-node)
	((add-node-interval)           add-node-interval)
	((add-edge-interval)           add-edge-interval)
	((node-label-set)              node-label-set)
	((node-property-set)           node-property-set)
	((node-interval-property-set)  node-interval-property-set)
	((edge-property-set)           edge-property-set)
	((edge-interval-property-set)  edge-interval-property-set)
	
        (else
          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
    
    )))
			 
;;
;; Adds a number k to all node ids of the graph
;;


(define (digraph-rename k a)

  (define (rename-nodes ns) (map (lambda (x) (list (fx+ k x))) ns))
  (define (rename-nodes-with-labels ns) (map (lambda (x) (list (fx+ k (car x)) (cadr x))) ns))
  (define (rename-edges es) (map (lambda (e) (list (fx+ k (car e)) (fx+ k (cadr e)))) es))
  (define (rename-edges-with-labels es) (map (lambda (e) (list (fx+ k (car e)) (fx+ k (cadr e)) (caddr e))) es))

  (let recur ((a a))

    (let* (;; accessors
	   (name                     (a 'name))
	   (label                    (a 'label))
	   (nodes                    (lambda () (cis:elements (cis:shift k (a 'node-intervals) ))))
	   (nodes-with-labels        (lambda () (rename-nodes-with-labels (a 'nodes-with-labels))))
	   (node-intervals           (lambda () (cis:shift k (a 'node-intervals) )))
	   (edges                    (lambda () (rename-edges (a 'edges) )))
	   (edges-with-labels        (lambda () (rename-edges-with-labels (a 'edges-with-labels) )))
	   (order                    (lambda () (a 'order)))
	   (size                     (a 'size))
	   (capacity                 order)
	   (out-edges                (lambda (i)      (rename-edges ((a 'out-edges) (fx- i k)))))
	   (succ                     (lambda (i)      (cis:elements (cis:shift k ((a 'succ-interval) (fx- i k) )))))
	   (succ-interval            (lambda (i)      (cis:shift k ((a 'succ-interval) (fx- i k) ))))
	   (has-edge                 (lambda (i j)    ((a 'has-edge) (fx- i k) (fx- j k))))
	   (has-node                 (lambda (i)      ((a 'has-node) (fx- i k))))
	   (has-node-interval        (lambda (i)      ((a 'has-node-interval) (cis:shift (fxneg k) i))))
	   (node-property-list-keys       (a 'node-property-list-keys))
	   (node-property            (lambda (p i)    ((a 'node-property) p (fx- i k) )))
	   (node-interval-property   (lambda (p i)    ((a 'node-interval-property) p (cis:shift (fxneg k) i) )))
	   (node-label               (lambda (i)      ((a 'node-label) (fx- i k))))
	   (edge-property-list-keys       (a 'edge-property-list-keys))
	   (edge-property-list-map        (a 'edge-property-list-map))
	   (edge-property            (lambda (p i j)  ((a 'edge-property) p (fx- i k) (fx- j k) )))
	   (edge-interval-property   (lambda (p i j)  ((a 'edge-interval-property) p (cis:shift (fxneg k) i) (cis:shift (fxneg k) j) )))
	   (foreach-node             (lambda (f)      (for-each (lambda (i) (f (fx+ i k))) (nodes))))
	   (foreach-node-with-label  (lambda (f)      (for-each (lambda (x) (f (fx+ (car x) k) (cadr x))) (nodes-with-labels))))
	   (foreach-edge             (lambda (f)      (for-each (lambda (e) (f (list (fx+ (car e) k) (fx+ (cadr e) k)))) (edges))))
	   
	   ;; transformers
	   (add-node    (lambda (n #!key (label #f))  (recur ((a 'add-node) (fx- n k) label: label) )))

	   (add-node-interval    (lambda (i #!key (label #f))  (recur ((a 'add-node-interval) (cis:shift (fxneg k) i) label: label) )))

	   (add-edge    (lambda (e #!key (label #f))  (recur ((a 'add-edge) (list (fx- (car e) k) (fx- (cadr e) k)) label: label) )))
	   (add-edge-interval (lambda (e)  (recur ((a 'add-edge-interval) (list (fx- (car e) k) (fx- (cadr e) k)) ))))

	   (edge-interval-property-set      
	    (lambda (p i j v)  (recur ((a 'edge-interval-property-set) p 
				       (cis:shift (fxneg k) i) (cis:shift (fxneg k) j) v))))

	   (node-interval-property-set      
	    (lambda (p i v)    (recur ((a 'node-interval-property-set) p 
				       (cis:shift (fxneg k) i) v))))

	   (node-label-set         
	    (lambda (i v)      (recur ((a 'node-label-set) (fx- i k) v))))

	   (node-property-set      
	    (lambda (p i v)    (recur ((a 'node-property-set) p (fx- i k) v))))

	   (edge-property-set      
	    (lambda (p i j v)  (recur ((a 'edge-property-set) p (fx- i k) (fx- j k) v))))

	   )
      
    (lambda (selector)
      (case selector
	;; accessors
	((name)                        name)
	((label)                       label)
	((nodes)                       nodes)
	((nodes-with-labels)           nodes-with-labels)
	((node-intervals)              node-intervals)
	((edges)                       edges)
	((edges-with-labels)           edges-with-labels)
	((order)                       order)
	((size)                        size)
	((capacity)                    capacity)
	((out-edges)                   out-edges)
	((succ)                        succ)
	((succ-interval)               succ-interval)
	((has-edge)                    has-edge)
	((has-node)                    has-node)
	((has-node-interval)           has-node-interval)
	((node-property-list-keys)          node-property-list-keys)
	((node-property)               node-property)
	((node-interval-property)      node-interval-property)
	((node-label)                  node-label)
	((edge-property-list-keys)     edge-property-list-keys)
	((edge-property-list-map)      edge-property-list-map)
	((edge-property)               edge-property)
	((foreach-node)                foreach-node)
	((foreach-node-with-label)     foreach-node-with-label)
        ((foreach-edge)                foreach-edge)

	;; transformers
	((add-node)                    add-node)
	((add-node-interval)           add-node-interval)
	((add-edge)                    add-edge)
	((add-edge-interval)           add-edge-interval)
	((node-label-set)              node-label-set)
	((node-property-set)           node-property-set)
	((node-interval-property-set)  node-interval-property-set)
	((edge-property-set)           edge-property-set)
	((edge-interval-property-set)  edge-interval-property-set)
	
        (else
          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
    
    )))


(define (digraph-disjoint-union a b) 
  (digraph-union a (digraph-rename ((a 'capacity)) b) 
                 (string->symbol (string-append (->string (a 'label)) "+" (->string (b 'label))))))

;;
;; Naive implementation: randomly choosing edges from NxN possibilities with probability P 
;;

(define (make-random-gnp-digraph name label N P R S loops)

  (if (< N 10) (error 'make-random-gnp-digraph "N is too small" N))
  (if (not (and (< 0 P) (<= P 1))) (error 'make-random-gnp-digraph "P must be in the interval (0, 1]"))

  (let* ((E     (* N N))
	 (nodes (cis:interval 1 N))
	 (a     (make-digraph name label))
	 (a     ((a 'add-node-interval) nodes)))
    
    (let recur ((a a) (s S) (e 0))

      (if (> e E) a

	  (let* ((i (inexact->exact (R N P s)))
		 (j (inexact->exact (R N P s))))

	    (if (or (zero? i) (zero? j) (and (= i j) (not loops)) ((a 'has-edge) i j))
		(recur a s (+ 1 e))
		(recur ((a 'add-edge) (list i j)) s (+ 1 e))
		)))
    )))

|#
)