Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

buttons\!

  • Loading branch information...
commit 7fb02bd95de007cd6f82cf29c0979539565a0b7a 1 parent ca16745
Holden Karau authored
Showing with 45 additions and 5 deletions.
  1. +33 −4 graph.scm
  2. +12 −1 test/graph-test.scm
37 graph.scm
View
@@ -192,7 +192,7 @@
;; edge-label))))
;; Floyd-warhsall all points shortest path (currently just the weights)
-;; Constructs two |V|x|V| vectors
+;; 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)))
@@ -200,7 +200,13 @@
(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)))))
+ (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)
@@ -221,7 +227,6 @@
(hash-table-ref vertex-map (vertex-label (edge-in e)))
)
) (graph-edges graph))
- distances
(let loop ((k 0))
(if (= k vertex-count)
distances
@@ -249,9 +254,33 @@
))
(loop (+ k 1))
)))
- (list distances next vertex-map)
+ (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
13 test/graph-test.scm
View
@@ -36,6 +36,17 @@
(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-end "flyod-warshall")
(test-exit)
Please sign in to comment.
Something went wrong with that request. Please try again.