Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

Add a hobo floyd warshall implementation #2

Merged
merged 15 commits into from
Commits on Jan 26, 2013
  1. @holdenk

    progress

    holdenk authored
  2. @holdenk

    progress

    holdenk authored
  3. @holdenk

    uhhh works ish?

    holdenk authored
  4. @holdenk

    Yay\!

    holdenk authored
  5. @holdenk
  6. @holdenk

    Clean

    holdenk authored
  7. @holdenk

    Comments

    holdenk authored
  8. @holdenk

    Comments

    holdenk authored
Commits on Feb 3, 2013
  1. @holdenk

    Merge

    holdenk authored
  2. @holdenk
Commits on Feb 11, 2013
  1. @holdenk

    Next node tracking

    holdenk authored
  2. @holdenk

    tests

    holdenk authored
Commits on Feb 23, 2013
  1. @holdenk

    buttons\!

    holdenk authored
  2. @holdenk
  3. @holdenk
This page is out of date. Refresh to see the latest.
Showing with 136 additions and 2 deletions.
  1. +3 −1 graph.meta
  2. +92 −1 graph.scm
  3. +41 −0 test/graph-test.scm
View
4 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"
View
93 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
View
41 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)
Something went wrong with that request. Please try again.