;;; The Floyd-Warshall algorithm
;;; John David Stone
;;; Department of Computer Science
;;; Grinnell College
;;; created October 10, 2005
;;; last revised January 9, 2017
(define-library (afp shortest-paths Floyd-Warshall)
(export trivial-table test-connection all-shortest-paths)
(import (afp primitives)
(only (afp constant-procedures) create)
(only (afp sets) fold-set)
(only (afp tables) put-into-table lookup table table-update)
(only (afp graphs) vertices dearc arcs)
(only (afp paths) splice-paths))
(begin
;; ===== trivial-table ================================================
;; graph(alpha, number) ->
;; graph
;; table(alpha, table(alpha, pair(number, list(alpha))))
;; The trivial-table procedure constructs a two-level path table
;; containing the trivial (one-vertex and two-vertex) paths for graph,
;; along with their path sums.
(define (trivial-table graph)
((fold-set (create ((fold-set table
(lambda (vertex tab)
(put-into-table
vertex
(table (cons vertex
(cons 0
(list vertex))))
tab)))
(vertices graph)))
(lambda (arc tab)
(receive (tail head label) (dearc arc)
(if (equal? tail head)
tab
(table-update tail
(sect put-into-table
head
(cons label (list head tail))
<>)
tab)))))
(arcs graph)))
;; ===== test-connection ==============================================
;; (pair(number, list(alpha)) | Boolean),
;; fore
;; (pair(number, list(alpha)) | Boolean),
;; aft
;; (pair(number, list(alpha)) | Boolean),
;; direct
;; alpha, table(alpha, pair(number, list(alpha))) ->
;; goal tab
;; table(alpha, pair(number, list(alpha)))
;; The test-connection procedure returns a path table similar to tab,
;; but updated using information about three potential paths within a
;; graph: one (fore) connecting an "origin" vertex to some intermediate
;; vertex, a second (aft) connecting the intermediate vertex to a
;; "goal" vertex (goal), and a third (direct) connecting the origin to
;; the goal directly. In place of any or all of these paths, the value
;; #f, signifying the absence of a path, may be received.
;; Preconditions:
;; If neither fore nor direct is #f, then the origin of fore is the
;; origin of direct.
;; If neither fore nor aft is #f, then the destination of fore is
;; the origin of aft.
;; If aft is not #f, then the destination of aft is goal.
;; If direct is not #f, then the destination of direct is goal.
;; goal is a key in tab.
(define (test-connection fore aft direct goal tab)
(if (and (pair? fore) (pair? aft))
(put-into-table goal
(if (and (pair? direct)
(< (car direct)
(+ (car fore) (car aft))))
direct
(splice-paths fore aft))
tab)
(if (pair? direct)
(put-into-table goal direct tab)
tab)))
;; ===== all-shortest-paths ===========================================
;; graph(alpha, number) ->
;; graph
;; table(alpha, table(alpha, pair(number, list(alpha))))
;; The all-shortest-paths procedure constructs a two-level path table
;; giving the shortest path from any vertex to any vertex in graph.
;; Precondition:
;; Every arc in graph has a positive label.
(define (all-shortest-paths graph)
(let ((verts (vertices graph)))
((fold-set
(create (trivial-table graph))
(lambda (intermediate tab)
(let ((mid-paths (lookup intermediate tab)))
((fold-set
table
(lambda (origin outer)
(let ((origin-paths (lookup origin tab)))
(let ((forepath (lookup intermediate origin-paths)))
(put-into-table
origin
((fold-set
table
(lambda (goal new-tab)
(test-connection forepath
(lookup goal mid-paths)
(lookup goal origin-paths)
goal
new-tab)))
verts)
outer)))))
verts))))
verts)))))
;;; copyright (C) 2011, 2017 John David Stone
;;; This program is free software. You may redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation -- either version 3 of the License, or (at
;;; your option) any later version. A copy of the GNU General Public
;;; License is available on the World Wide Web at
;;;
;;; http://www.gnu.org/licenses/gpl.html
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY -- without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.