327 lines
8.4 KiB
Standard ML
327 lines
8.4 KiB
Standard ML
(*
|
|
Floyd-Warshall algorithm.
|
|
|
|
See https://en.wikipedia.org/w/index.php?title=Floyd%E2%80%93Warshall_algorithm&oldid=1082310013
|
|
*)
|
|
|
|
(*------------------------------------------------------------------(*
|
|
|
|
In this program, I introduce more "abstraction" than there was in
|
|
earlier versions, which were written in the SML-like languages
|
|
OCaml and ATS. This is an example of proceeding from where one has
|
|
gotten so far, to turn a program into a better one. The
|
|
improvements made here could be backported to the other languages.
|
|
|
|
In most respects, though, this program is very similar to the
|
|
OCaml.
|
|
|
|
Standard ML seems to specify its REAL signature is for IEEE
|
|
floating point, so this program assumes there is a positive
|
|
"infinity". (The difference is tiny between an algorithm with
|
|
"infinity" and one without.)
|
|
|
|
*)------------------------------------------------------------------*)
|
|
|
|
(* Square arrays with 1-based indexing. *)
|
|
|
|
signature SQUARE_ARRAY =
|
|
sig
|
|
type 'a squareArray
|
|
val make : int * 'a -> 'a squareArray
|
|
val get : 'a squareArray -> int * int -> 'a
|
|
val set : 'a squareArray -> int * int -> 'a -> unit
|
|
end
|
|
|
|
structure SquareArray : SQUARE_ARRAY =
|
|
struct
|
|
|
|
type 'a squareArray = int * 'a array
|
|
|
|
fun make (n, fill) =
|
|
(n, Array.array (n * n, fill))
|
|
|
|
fun get (n, r) (i, j) =
|
|
Array.sub (r, (i - 1) + (n * (j - 1)))
|
|
|
|
fun set (n, r) (i, j) x =
|
|
Array.update (r, (i - 1) + (n * (j - 1)), x)
|
|
|
|
end
|
|
|
|
(*------------------------------------------------------------------*)
|
|
|
|
(* A vertex is, internally, a positive integer, or 0 for the nil
|
|
object. *)
|
|
|
|
signature VERTEX =
|
|
sig
|
|
exception VertexError
|
|
eqtype vertex
|
|
val nilVertex : vertex
|
|
val isNil : vertex -> bool
|
|
val max : vertex * vertex -> vertex
|
|
val toInt : vertex -> int
|
|
val fromInt : int -> vertex
|
|
val toString : vertex -> string
|
|
val directedListToString : vertex list -> string
|
|
end
|
|
|
|
structure Vertex : VERTEX =
|
|
struct
|
|
|
|
exception VertexError
|
|
|
|
type vertex = int
|
|
|
|
val nilVertex = 0
|
|
|
|
fun isNil u = u = nilVertex
|
|
fun max (u, v) = Int.max (u, v)
|
|
fun toInt u = u
|
|
|
|
fun fromInt i =
|
|
if i < nilVertex then
|
|
raise VertexError
|
|
else
|
|
i
|
|
|
|
fun toString u = Int.toString u
|
|
|
|
fun directedListToString [] = ""
|
|
| directedListToString [u] = toString u
|
|
| directedListToString (u :: tail) =
|
|
(* This implementation is *not* tail recursive. *)
|
|
(toString u) ^ " -> " ^ (directedListToString tail)
|
|
|
|
end
|
|
|
|
(*------------------------------------------------------------------*)
|
|
|
|
(* Graph edges, with weights. *)
|
|
|
|
signature EDGE =
|
|
sig
|
|
type edge
|
|
val make : Vertex.vertex * real * Vertex.vertex -> edge
|
|
val first : edge -> Vertex.vertex
|
|
val weight : edge -> real
|
|
val second : edge -> Vertex.vertex
|
|
end
|
|
|
|
structure Edge : EDGE =
|
|
struct
|
|
|
|
type edge = Vertex.vertex * real * Vertex.vertex
|
|
|
|
fun make edge = edge
|
|
fun first (u, _, _) = u
|
|
fun weight (_, w, _) = w
|
|
fun second (_, _, v) = v
|
|
|
|
end
|
|
|
|
(*------------------------------------------------------------------*)
|
|
|
|
(* The "dist" array and its operations. *)
|
|
|
|
signature DISTANCES =
|
|
sig
|
|
type distances
|
|
val make : int -> distances
|
|
val get : distances -> int * int -> real
|
|
val set : distances -> int * int -> real -> unit
|
|
end
|
|
|
|
structure Distances : DISTANCES =
|
|
struct
|
|
|
|
type distances = real SquareArray.squareArray
|
|
|
|
fun make n = SquareArray.make (n, Real.posInf)
|
|
val get = SquareArray.get
|
|
val set = SquareArray.set
|
|
|
|
end
|
|
|
|
(*------------------------------------------------------------------*)
|
|
|
|
(* The "next" array and its operations. It lets you look up optimum
|
|
paths. *)
|
|
|
|
signature PATHS =
|
|
sig
|
|
type paths
|
|
val make : int -> paths
|
|
val get : paths -> int * int -> Vertex.vertex
|
|
val set : paths -> int * int -> Vertex.vertex -> unit
|
|
val path : (paths * int * int) -> Vertex.vertex list
|
|
val pathString : (paths * int * int) -> string
|
|
end
|
|
|
|
structure Paths : PATHS =
|
|
struct
|
|
|
|
type paths = Vertex.vertex SquareArray.squareArray
|
|
|
|
fun make n = SquareArray.make (n, Vertex.nilVertex)
|
|
val get = SquareArray.get
|
|
val set = SquareArray.set
|
|
|
|
fun path (p, u, v) =
|
|
if Vertex.isNil (get p (u, v)) then
|
|
[]
|
|
else
|
|
let
|
|
fun
|
|
build_path (p, u, v) =
|
|
if u = v then
|
|
[v]
|
|
else
|
|
let
|
|
val i = get p (u, v)
|
|
in
|
|
u :: build_path (p, i, v)
|
|
end
|
|
in
|
|
build_path (p, u, v)
|
|
end
|
|
|
|
fun pathString (p, u, v) =
|
|
Vertex.directedListToString (path (p, u, v))
|
|
|
|
end
|
|
|
|
(*------------------------------------------------------------------*)
|
|
|
|
(* Floyd-Warshall. *)
|
|
|
|
exception FloydWarshallError
|
|
|
|
fun find_max_vertex [] = Vertex.nilVertex
|
|
| find_max_vertex (edge :: tail) =
|
|
(* This implementation is *not* tail recursive. *)
|
|
Vertex.max (Vertex.max (Edge.first edge, Edge.second edge),
|
|
find_max_vertex tail)
|
|
|
|
fun floyd_warshall [] = raise FloydWarshallError
|
|
| floyd_warshall edges =
|
|
let
|
|
val n = find_max_vertex edges
|
|
val dist = Distances.make n
|
|
val next = Paths.make n
|
|
|
|
fun read_edges [] = ()
|
|
| read_edges (edge :: tail) =
|
|
let
|
|
val u = Edge.first edge
|
|
val v = Edge.second edge
|
|
val weight = Edge.weight edge
|
|
in
|
|
(Distances.set dist (u, v) weight;
|
|
Paths.set next (u, v) v;
|
|
read_edges tail)
|
|
end
|
|
|
|
val indices =
|
|
(* Indices in order from 1 .. n. *)
|
|
List.tabulate (n, fn i => i + 1)
|
|
in
|
|
|
|
(* Initialization. *)
|
|
|
|
read_edges edges;
|
|
List.app (fn i => (Distances.set dist (i, i) 0.0;
|
|
Paths.set next (i, i) i))
|
|
indices;
|
|
|
|
(* Perform the algorithm. *)
|
|
|
|
List.app
|
|
(fn k =>
|
|
List.app
|
|
(fn i =>
|
|
List.app
|
|
(fn j =>
|
|
let
|
|
val dist_ij = Distances.get dist (i, j)
|
|
val dist_ik = Distances.get dist (i, k)
|
|
val dist_kj = Distances.get dist (k, j)
|
|
val dist_ikj = dist_ik + dist_kj
|
|
in
|
|
if dist_ikj < dist_ij then
|
|
let
|
|
val new_dist = dist_ikj
|
|
val new_next = Paths.get next (i, k)
|
|
in
|
|
Distances.set dist (i, j) new_dist;
|
|
Paths.set next (i, j) new_next
|
|
end
|
|
else
|
|
()
|
|
end)
|
|
indices)
|
|
indices)
|
|
indices;
|
|
|
|
(* Return the results, as a 3-tuple. *)
|
|
|
|
(n, dist, next)
|
|
|
|
end
|
|
|
|
(*------------------------------------------------------------------*)
|
|
|
|
fun tilde_to_minus s =
|
|
String.translate (fn c => if c = #"~" then "-" else str c) s
|
|
|
|
fun main () =
|
|
let
|
|
val example_graph =
|
|
[Edge.make (Vertex.fromInt 1, ~2.0, Vertex.fromInt 3),
|
|
Edge.make (Vertex.fromInt 3, 2.0, Vertex.fromInt 4),
|
|
Edge.make (Vertex.fromInt 4, ~1.0, Vertex.fromInt 2),
|
|
Edge.make (Vertex.fromInt 2, 4.0, Vertex.fromInt 1),
|
|
Edge.make (Vertex.fromInt 2, 3.0, Vertex.fromInt 3)]
|
|
|
|
val (n, dist, next) = floyd_warshall example_graph
|
|
|
|
val indices =
|
|
(* Indices in order from 1 .. n. *)
|
|
List.tabulate (n, fn i => i + 1)
|
|
in
|
|
print " pair distance path\n";
|
|
print "---------------------------------------\n";
|
|
List.app
|
|
(fn u =>
|
|
List.app
|
|
(fn v =>
|
|
if u <> v then
|
|
(print " ";
|
|
print (Vertex.directedListToString [u, v]);
|
|
print " ";
|
|
if 0.0 <= Distances.get dist (u, v) then
|
|
print " "
|
|
else
|
|
();
|
|
print (tilde_to_minus
|
|
(Real.fmt (StringCvt.FIX (SOME 1))
|
|
(Distances.get dist (u, v))));
|
|
print " ";
|
|
print (Paths.pathString (next, u, v));
|
|
print "\n")
|
|
else
|
|
())
|
|
indices)
|
|
indices
|
|
end;
|
|
|
|
(* Comment out the following line, if you are using Poly/ML. *)
|
|
main ();
|
|
|
|
(*------------------------------------------------------------------*)
|
|
(* local variables: *)
|
|
(* mode: sml *)
|
|
(* sml-indent-level: 2 *)
|
|
(* sml-indent-args: 2 *)
|
|
(* end: *)
|