Shortest path example from §4.4 Escardó & Oliva 2009

Vanessa McHale
2025-01-24T14:23:17Z

Graph.hs

| module Graph where
|
| import qualified Data.Array as A
| import Data.List (find, inits)
|
| type J r x = (x -> r) -> x
|
| data R = Dist Integer
| | Infinity deriving Eq
|
| instance Num R where
| (+) (Dist m) (Dist n) = Dist (m+n)
| (+) _ _ = Infinity
|
| fromInteger i = Dist i
|
| instance Ord R where
| (Dist m) <= (Dist n) = m<=n
| Dist{} <= Infinity = True
| Infinity <= Dist{} = False
| Infinity <= Infinity = False
|
| type Vertex = Int
| type X = [Vertex]
|
| vertices :: X
| vertices = [1,2,3,4,5,6]
|
| -- https://commons.wikimedia.org/wiki/File:Dijkstra_Animation.gif
| d :: A.Array (Vertex, Vertex) R
| d = A.array ((1,1), (6,6))
| [ ((1,1), 0), ((1,2), 7), ((1,3), 9), ((1,4), Infinity), ((1,5), Infinity), ((1,6), 14)
| , ((2,1), 7), ((2,2), 0), ((2,3), 10), ((2,4), 15), ((2,5), Infinity), ((2,6), Infinity)
| , ((3,1), 9), ((3,2), 10), ((3,3), 0), ((3,4), 11), ((3,5), Infinity), ((3,6), 2)
| , ((4,1), Infinity), ((4,2), 15), ((4,3), 11), ((4,4), 0), ((4,5), 6), ((4,6), Infinity)
| , ((5,1), Infinity), ((5,2), Infinity), ((5,3), Infinity), ((5,4), 6), ((5,5), 0), ((5,6), 9)
| , ((6,1), 14), ((6,2), Infinity), ((6,3), 2), ((6,4), Infinity), ((6,5), 9), ((6,6),0)
| ]
|
| u, v :: Vertex
| u = 1
| v = 5
|
| bigotimes :: [J r x] -> J r [x]
| bigotimes [] = \_ -> []
| bigotimes (ε:εs) = ε `otimes` bigotimes εs
| where
| otimes ε δ p = a : b a where b = \x -> δ (\xs -> p (x:xs))
| a = ε (\x -> p (x:b x))
|
| ε :: J R Vertex
| ε p | Just v <- find (\x -> p x == inf) vertices = v
| where
| inf = minimum [ p x | x <- vertices ]
|
| properPath :: [Vertex] -> Bool
| properPath (x:y:ys) | Dist{} <- d A.! (x,y), all (x/=) (y:ys) = properPath (y:ys)
| | otherwise = False
| properPath _ = True
|
| pathLength :: [Vertex] -> R
| pathLength (x:y:ys) = d A.! (x,y) + pathLength (y:ys)
| pathLength _ = 0
|
| q :: [Vertex] -> R
| q xs | Just x_p <- find properPath [(u:x_k++[v]) | x_k <- inits xs] = pathLength x_p
| | otherwise = Infinity
|
| a :: [Vertex]
| a = bigotimes (replicate 6 ε) q
|
| shortestPath :: [Vertex]
| shortestPath = u:takeUntil (\n -> d A.! (n,v) == Infinity) a++[v]
|
| takeUntil :: (x -> Bool) -> [x] -> [x]
| takeUntil p (x:xs@(y:_)) | p x = [x,y]
| | otherwise = x:takeUntil p xs
| takeUntil _ xs = xs