(define (make-list len init)
  (vector->list (make-vector len init)))

(define (empty-function)
  (lambda (x)
    (error "empty-function applied")))

(define (update-function f x y)
  (lambda (x1)
    (if (equal? x x1)
	y
	(f x1))))

(define (update-function* f xs ys)
  (if (null? xs)
      f
      (update-function* (update-function f (car xs) (car ys)) (cdr xs) (cdr ys))))

(define-record-type graph
  ((root)
   (nodes)
   (edges))
  ((properties '())))

(define-record-discloser type/graph
  (lambda (p) `(graph ,(graph-root p) ,(graph-nodes p) ,(graph-edges p))))

(define (graph-fetch-property graph name proc)
  (cond
   ((assoc name (graph-properties graph)) => cdr)
   (else
    (let ((value (proc graph)))
      (set-graph-properties!
       graph
       (cons (cons name value)
	     (graph-properties graph)))
      value))))

(define (succ node graph)
  (define (get-succs from edges)
    (filter-map (lambda (edge)
		  (and (equal? (car edge) from) (cdr edge)))
		edges))
  (define (compute-succ graph)
    (let ((sorted-graph
	   (map (lambda (node)
		  (cons node (get-succs node (graph-edges graph))))
		(graph-nodes graph))))
      (lambda (node)
	(cdr (assoc node sorted-graph)))))
  ((graph-fetch-property graph 'succ compute-succ) node))

(define (pred node graph)
  (define (get-preds to edges)
    (filter-map (lambda (edge)
		  (and (equal? (cdr edge) to) (car edge)))
		edges))
  (define (compute-pred graph)
    (let ((sorted-graph
	   (map (lambda (node)
		  (cons node (get-preds node (graph-edges graph))))
		(graph-nodes graph))))
      (lambda (node)
	(cdr (assoc node sorted-graph)))))  
  ((graph-fetch-property graph 'pred compute-pred) node))

(define (depth-first graph)
  (define (compute-depth-first graph)
    (let ((visit
	   (update-function* (empty-function)
			     (graph-nodes graph)
			     (make-list (length (graph-nodes graph)) #f))))
      (let loop ((node (graph-root graph)))
	(set! visit (update-function visit node #t))
	(cons node
	      (flatten
	       (map (lambda (node)
		      (if (visit node)
			  '()
			  (loop node)))
		    (succ node graph)))))))
  (graph-fetch-property graph 'depth-first compute-depth-first))


(define (dominators graph)
  (define (compute-dominators graph)
    (let* ((non-root-nodes (set-minus (graph-nodes graph) (list (graph-root graph))))
	   (depth-first-without-root (set-minus (depth-first graph) (list (graph-root graph))))
	   (change #t)
	   (domin (update-function*
		   (empty-function)
		   (cons (graph-root graph)
			 non-root-nodes)
		   (cons (list (graph-root graph))
			 (make-list (length non-root-nodes) (graph-nodes graph))))))
      (let repeat ()
	(if change
	    (begin
	      (set! change #f)
	      (for-each
	       (lambda (node)
		 (let* ((t
			 (fold-left
			  (lambda (t p)
			    (set-intersect t (domin p)))
			  (graph-nodes graph)
			  (pred node graph)))
			(d (set-union (list node) t)))
		   (if (not (set-equal? d (domin node)))
		       (begin
			 (set! change #t)
			 (set! domin (update-function domin node d))))))
	       depth-first-without-root)
	      (repeat))
	    domin))))
  (graph-fetch-property graph 'dominators compute-dominators))

(define (immediate-dominator graph)
  (define (compute-immediate-dominator graph)
    (let* ((domin (dominators graph))
	   (tmp (update-function*
		 (empty-function)
		 (graph-nodes graph)
		 (map (lambda (node) (set-minus (domin node) (list node))) (graph-nodes graph))))
	   (depth-first-without-root (set-minus (depth-first graph) (list (graph-root graph)))))
      (for-each
       (lambda (n)
	 (for-each
	  (lambda (s)
	    (let ((to-kill
		   (filter-map
		    (lambda (t)
		      (and (not (equal? t s)) (member t (tmp s)) t))
		    (tmp n))))
	      (set! tmp (update-function tmp n (set-minus (tmp n) to-kill)))))
	  (tmp n)))
       depth-first-without-root)
      (update-function*
       (empty-function)
       depth-first-without-root
       (map (lambda (n) (car (tmp n))) depth-first-without-root))))
  (graph-fetch-property graph 'immediate-dominator compute-immediate-dominator))

(define (dominator-tree graph)
  (define (compute-dominator-tree graph)
    (let* ((idom (immediate-dominator graph))
	   (dom-tree-edges
	    (filter-map
	     (lambda (n)
	       (and (not (equal? n (graph-root graph))) (cons (idom n) n)))
	     (graph-nodes graph))))
      (graph-maker (graph-root graph) (graph-nodes graph) dom-tree-edges)))
  (graph-fetch-property graph 'dominator-tree compute-dominator-tree))


(define (post-order tree)
  (let loop ((node (graph-root tree)))
    (let ((succs (succ node tree)))
      (if (null? succs)
	  (list node)
	  (append (flatten (map loop succs)) (list node))))))

(define (dominance-frontier graph)
  (define (compute-dominance-frontier graph)
    (let ((dom-tree (dominator-tree graph)))
      (let loop ((nodes (post-order dom-tree))
		 (df (update-function*
		      (empty-function)
		      (graph-nodes graph)
		      (make-list (length (graph-nodes graph)) '()))))
	(if (null? nodes)
	    df
	    (let* ((x (car nodes))
		   (df-local (succ x graph))
		   (df-global
		    (set-minus
		     (list-union (cons df-local (map df (succ x dom-tree))))
		     (succ x dom-tree))))
	      (loop (cdr nodes) (update-function df x df-global)))))))
  (graph-fetch-property graph 'dominance-frontier compute-dominance-frontier))

(define graph
  (graph-maker
   '1
   '(1 2 3 4 5 6 7 8)
   '((1 . 2) (1 . 6)
     (2 . 3)
     (3 . 2) (3 . 4) (3 . 5)
     (4 . 5)
     (6 . 4) (6 . 7)
     (7 . 8)
     (8 . 7))))

(define graph
  (graph-maker
   'entry
   '(entry b1 b2 b3 b4 b5 b6 exit)
   '((entry . b1)
     (b1 . b2) (b1 . b3)
     (b2 . exit)
     (b3 . b4)
     (b4 . b5) (b4 . b6)
     (b5 . exit)
     (b6 . b4))))

(define graph
  (graph-maker
   'entry
   '(entry b1 b2 b3 b4 b5 b6 exit)
   '((entry . b1)
     (b1 . b2)
     (b2 . b3) (b2 . b4)
     (b3 . b2)
     (b4 . b5) (b4 . b6)
     (b5 . exit)
     (b6 . exit))))

(pred 'exit graph)

(depth-first graph)

(define domin (dominators graph))
(p (map (lambda (node) (list node (domin node))) (graph-nodes graph)))

(define idom (immediate-dominator graph))
(p (filter-map
    (lambda (node)
      (and (not (equal? node (graph-root graph))) (list node (idom node))))
    (graph-nodes graph)))

(define dom-tree (dominator-tree graph))
(p (graph-edges dom-tree))

(define dom-frontier (dominance-frontier graph))
(p (map (lambda (node) (list node (dom-frontier node))) (graph-nodes graph)))