Shortest path example from §4.4 Escardó & Oliva 2009

Graph.hs

#! /usr/bin/env nix-shell
#! nix-shell -p "haskellPackages.ghcWithPackages (pkgs: with pkgs; [])" -i runhaskell

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
    (*) (Dist m) (Dist n) = Dist (m*n)
    (*) _ _               = Infinity
    abs (Dist m)          = Dist (abs m)
    abs _                 = Infinity
    signum (Dist m)       = Dist (signum m)
    signum _              = Infinity
    (-) (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

main :: IO ()
main = print shortestPath