Add a hobo floyd warshall implementation

graph.meta

@@ -13,7 +13,9 @@
   (traversal "1.1")
   (object-graph "1.2")
   (nondeterminism "1.0")
-  miscmacros)
+  (miscmacros "2.95")
+  (list-utils "1.1.0")
+  (vector-lib "1.2"))
  (test-depends test)
  (files "graph.meta" 
         "graph.release-info"

graph.scm

@@ -1,6 +1,6 @@
 (module graph * 
 (import chicken scheme extras srfi-1)
-(use srfi-1 srfi-18 srfi-69 miscmacros define-structure traversal)
+(use srfi-1 srfi-18 srfi-69 miscmacros define-structure traversal vector-lib list-utils)
 (use nondeterminism object-graph files)
 
 ;; TODO this doesn't belong here
@@ -178,6 +178,97 @@
         (let ((node (minimump (lambda (v) (hash-table-ref distances v)) unvisited)))
          (loop (removeq node unvisited) node)))))))
 
+;; Floyd-warhsall all points shortest path (currently just the weights)
+;; Constructs two |V|x|V| vectors and a hash-table
+;; See http://en.wikipedia.org/wiki/Floyd%E2%80%93Warshall_algorithm
+(define (floyd-warshall-algorithm graph edge->weight)
+ (letrec ((vertex-count (length (graph-vertices graph)))
+       (vertex-map 
+	(alist->hash-table 
+	 (zip-alist
+	  (map (lambda (f) (vertex-label f)) (graph-vertices graph))
+	  (unfold (lambda (x) (>= x vertex-count)) (lambda (x) x) (lambda (x) (+ x 1)) 0))))
+       (vertex-reverse-map 
+	(alist->hash-table 
+	 (zip-alist
+	  (unfold (lambda (x) (>= x vertex-count)) (lambda (x) x) (lambda (x) (+ x 1)) 0)
+	  (map (lambda (f) (vertex-label f)) (graph-vertices graph)))))
+       )
+   (let ((distances (vector-unfold (lambda (i) 
+				     (cond
+				      ((eq? (quotient i vertex-count) (modulo i vertex-count)) 0)
+				      (else +inf.0)
+				      )) (* vertex-count vertex-count)))
+	 (next (vector-unfold (lambda (i) -1) (* vertex-count vertex-count)))
+	 )
+     (map (lambda (e)
+	    (vector-set! distances (+ 
+				    (hash-table-ref vertex-map (vertex-label (edge-in e)))
+				    (* vertex-count (hash-table-ref vertex-map (vertex-label (edge-out e))))
+				    )
+			 (edge->weight e))
+	    (vector-set! next (+ 
+				    (hash-table-ref vertex-map (vertex-label (edge-in e)))
+				    (* vertex-count (hash-table-ref vertex-map (vertex-label (edge-out e))))
+				    ) 
+			 (hash-table-ref vertex-map (vertex-label (edge-in e)))
+			 )
+		  ) (graph-edges graph))
+     (let loop ((k 0))
+       (if (= k vertex-count)
+	   distances
+	   (begin 
+	     (let loop ((i 0))
+	       (if (= i vertex-count)
+		   distances
+		   (begin
+		     (let loop ((j 0))
+		       (if (= j vertex-count)
+			   distances
+			   (let ((newPathCost (+ (vector-ref distances (+ i (* vertex-count k)))
+					     (vector-ref distances (+ k (* vertex-count j)))
+					     )))
+			     (cond ((< newPathCost
+				    (vector-ref distances (+ i (* vertex-count j))))
+				    (vector-set! next (+ i (* vertex-count j)) k)
+				    (vector-set! distances (+ i (* vertex-count j)) newPathCost)
+				     )
+				 )
+			     (loop (+ j 1))
+			     )
+			   ))
+		     (loop (+ i 1)))
+		   ))
+	     (loop (+ k 1))
+	     )))
+     (list distances next vertex-map vertex-reverse-map)
+       )))
+
+(define (floyd-warshall-extract-path start dest floydwarshall-info)
+  (let*
+      ((distance (car floydwarshall-info))
+       (next (cadr floydwarshall-info))
+       (vertex-map (caddr floydwarshall-info))
+       (vertex-reverse-map (cadddr floydwarshall-info))
+       (vertex-count (hash-table-size vertex-map))
+       (i (hash-table-ref vertex-map start))
+       (j (hash-table-ref vertex-map dest))
+       )
+    (if (= (vector-ref distance (+ j (* vertex-count i)))  +inf.0)
+	(list "pand!s")
+	(letrec
+	    ((find-path (lambda (x)
+			  (if (= x j)
+			      (cons x '())
+			      (cons x (find-path (vector-ref next (+ j (* vertex-count x)))))
+			  )
+			  )))
+	  (map (lambda (x) (hash-table-ref vertex-reverse-map x)) (find-path i))
+	  )
+	)
+    )
+)
+
 (define (for-each-b/d-fs f root graph bfs? #!key (duplicate-nodes? #t))
  ;; default is dfs
  ;; f :: new -> parent -> r; parent is #f for the root

test/graph-test.scm

@@ -14,4 +14,45 @@
      (g f 11))))
  edge-label)))
 (test-end "minimum spanning tree")
+(test-begin "flyod-warshall")
+(test (vector 0 1 1 0)
+      (car (floyd-warshall-algorithm
+       (digraph->graph
+	(alist->digraph
+	 '((a d 1))))
+       edge-label)))
+(test (vector 0 1 +inf.0 0)
+      (car (floyd-warshall-algorithm
+	(alist->digraph
+	 '((a d 1)))
+       edge-label)))
+(test (vector 0 1 101 +inf.0 0 100 +inf.0 +inf.0 0)
+      (car (floyd-warshall-algorithm
+	(alist->digraph
+	 '((a d 1) (d c 100)))
+       edge-label)))
+(test (vector -1 1 1 -1 -1 2 -1 -1 -1)
+      (cadr (floyd-warshall-algorithm
+	(alist->digraph
+	 '((a d 1) (d c 100)))
+       edge-label)))
+(test '(a) 
+      (floyd-warshall-extract-path 'a 'a
+				   (floyd-warshall-algorithm
+				    (alist->digraph
+				     '((a d 1) (d c 100)))
+				    edge-label)))
+(test '(a d) 
+      (floyd-warshall-extract-path 'a 'd
+				   (floyd-warshall-algorithm
+				    (alist->digraph
+				     '((a d 1) (d c 100)))
+				    edge-label)))
+(test '(a d c) 
+      (floyd-warshall-extract-path 'a 'c
+				   (floyd-warshall-algorithm
+				    (alist->digraph
+				     '((a d 1) (d c 100)))
+				    edge-label)))
+(test-end "flyod-warshall")
 (test-exit)