
(define dfs
  (lambda (v G)
    (if (not (has-vertex? G v))
	empty-graph
	(let ((seen (make-hash-table))
	      (tree (vertex v)))
	  (hashtable-set! seen v #t)
	  (let loop ((x v))
	    (for-all (lambda (y)
                       (unless (hashtable-ref seen y #f)
                         (hashtable-set! seen y #t)
                         (set! tree (insert-edge x y tree))
                         (loop y)))
                     (adjacent x G)))
	  tree))))

(define bfs
  (lambda (v G)
    (if (not (has-vertex? G v))
	empty-graph
	(let ((seen (make-hash-table))
	      (tree (vertex v)))
	  (hashtable-set! seen v #t)
	  (let loop ((Q (q:snocq q:empty v)))
	    (unless (q:empty? Q)
	      (let ((x (q:headq Q)))
		(hashtable-set! seen x #t)
		(loop (fold-left (lambda (Q y)
				   (if (hashtable-ref seen y #f)
                                       Q
                                       (begin
                                         (hashtable-set! seen y #t)
                                         (set! tree (insert-edge x y tree))
                                         (q:snocq Q y))))
				 (q:tailq Q)
				 (adjacent x G))))))
	  tree))))

(define topological-sort
  (lambda (G)
    (call/cc
     (lambda (cyclic)
       (let ((seen (make-hash-table))
             (tree (make-hash-table))
             (ordering '()))
         (define (dfs-state v)
           (hashtable-ref seen v #f))
         (define (find-cycle head cycle)
           (if (eq? head (car cycle))
               cycle
               (find-cycle head
                           (cons (hashtable-ref tree
                                                (car cycle)
                                                #f)
                                 cycle))))
         (define (enter x y)
           (hashtable-set! seen y 'entered)
           (hashtable-set! tree y x))
         (define (exit y)
           (hashtable-set! seen y 'exited)
           (push! y ordering))
         (define (dfs x)
           (for-each (lambda (y)
                       (let ((y-state (dfs-state y)))
                         (cond ((eq? y-state 'entered)
                                (cyclic (cons 'cyclic (find-cycle y (list x)))))
                               ((eq? y-state 'exited))
                               (else
                                (enter x y)
                                (dfs y)
                                (exit y)))))
                     (adjacent-descending x G)))
         (for-each (lambda (v)
                     (unless (dfs-state v)
                       (dfs v)
                       (exit v)))
                   (vertex-list-descending G))
         (cons 'dag ordering))))))

(define acyclic?
  (lambda (G)
    (eq? 'dag (car (topological-sort G)))))

(define dag?
  (lambda (G)
    (acyclic? G)))

(define scc
  (lambda (G)
    (let ((preorder 0)
          (component 0)
          (preorders (make-hash-table))
          (components (make-hash-table))
          (boundary '())
          (path '()))
      (define (preorder-id v)
        (hashtable-ref preorders v #f))
      (define (component-id v)
        (hashtable-ref components v #f))
      (define (set-component! v)
        (hashtable-set! components v component))
      (define (set-preorder! v)
        (hashtable-set! preorders v preorder)
        (inc! preorder))
      (define (enter v)
        (set-preorder! v)
        (push! v boundary)
        (push! v path))
      (define (pop-boundary v)
        (let ((p-v (preorder-id v)))
          (let walk ((x (pop! boundary)))
            (if (< p-v (preorder-id x))
                (walk (pop! boundary))
                (push! x boundary)))))
      (define (exit v)
        (when (= v (car boundary))
          (pop! boundary)
          (set-component! v)
          (let walk ((x (pop! path)))
            (unless (= x v)
              (set-component! x)
              (walk (pop! path))))
          (inc! component)))
      (define (dfs u)
        (enter u)
        (for-all (lambda (v)
                   (if (preorder-id v)
                       (unless (component-id v)
                         (pop-boundary v))
                       (dfs v)))
                 (adjacent u G))
        (exit u))
      (for-all (lambda (v)
                 (unless (preorder-id v)
                   (dfs v)))
               (vertex-list G))
      components)))

(define scc-count
  (lambda (G)
    (fx1+ (fold-left fxmax -1 (vector->list (hashtable-values (scc G)))))))
