Dijkstra algorithm in Haskell.

dijkstra.hs

type Node = String
type Length = Int

type Path = [Node]

data Way = Way Path | Visited | Unknown
type Ways = [(Node, Way)]

type Connection = (Node, Length)
type Connections = [Connection]
type Graph = [(Node,Connections)]

aGraph :: Graph
aGraph = [("A0", [("A1", 50)]),
        ("A1", [("A0", 50), ("B1", 30), ("A2", 5 )]),
        ("A2", [("A1", 5 ), ("B2", 20), ("A3", 40)]),
        ("A3", [("A2", 40), ("B3", 25), ("A4", 10)]),
        ("A4", [("A3", 10), ("B4", 0 )]),
        ("B0", [("B1", 10)]),
        ("B1", [("B0", 10), ("A1", 30), ("B2", 90)]),
        ("B2", [("B1", 90), ("A2", 20), ("B3", 2 )]),
        ("B3", [("B2", 2 ), ("A3", 25), ("B4", 8 )]),
        ("B4", [("A4", 0 ), ("B3", 8 )])]
        
dijkstra :: Node -> Node -> Graph -> Maybe Path
dijkstra start end graph = findWay start end graph $ map (\(n,_) -> if n == s then (n, Way [n]) else (n, Unknown)) m

findWay :: Node -> Node -> Graph -> Ways -> Maybe Path
findWay current end graph ways
    | current == end = Just (reverse way)
        where (Way way) = findKey end ways
findWay current end graph ways = findWay nextCurrent end graph newWays
    where (Way currentPath) = findKey current ways
          connections = findKey current graph
          complementedWays = complementWays graph currentPath connections ways
          newWays = insert current Visited complementedWays
          nextCurrent = nearest newWays graph
          
complementWays :: Graph -> Path -> Connections -> Ways -> Ways
complementWays graph currentPath connections ways = map (complementWay graph currentPath connections) ways

complementWay :: Graph -> Path -> Connections -> (Node, Way) -> (Node, Way)
complementWay graph currentPath connections (node, Way knownPath)
    | connectionExists && (newPathLength < (lengthOfPath graph knownPath)) = (node, Way newPath)
    | otherwise                                                            = (node, Way knownPath)
    where newPath          = node:currentPath
          newPathLength    = lengthOfPath graph newPath
          connectionExists = contains node connections
complementWay graph currentPath connections (node, Unknown)
    | connectionExists = (node, Way path)
    | otherwise        = (node, Unknown)
    where connectionExists = contains node connections
          path             = node:currentPath
complementWay _ _ _ (node, Visited) = (node, Visited)

lengthOfPath :: Graph -> Path -> Length
lengthOfPath graph (node1:[]) = 0
lengthOfPath graph (node1:node2:path) = (findKey node2 $ findKey node1 graph) + (lengthOfPath graph $ node2:path)

nearest :: Ways -> Graph -> Node
nearest ways graph = node
    where Just (node, _) = foldl (chooseNearest graph) Nothing ways

chooseNearest :: Graph -> Maybe (Node, Length) -> (Node, Way) -> Maybe (Node, Length)
chooseNearest graph yetNearest (node, Unknown) = yetNearest
chooseNearest graph yetNearest (node, Visited) = yetNearest
chooseNearest graph Nothing (node, Way path) = Just (node, lengthOfPath graph path)
chooseNearest graph (Just (nearest, distance)) (node, Way path) =
    if lengthOfPath graph path < distance
        then Just (node, lengthOfPath graph path)
        else Just (nearest, distance)
    
findKey :: (Eq k) => k -> [(k,v)] -> v
findKey key [] = error "key not found"
findKey key ((k,v):xs) = if key == k then v else findKey key xs

insert :: (Eq k) => k -> v -> [(k,v)] -> [(k,v)]
insert key value [] =
    [(key, value)]
insert key value ((x@(k,v)):xs) =
    if key == k
        then (k,value):xs
        else x:insert key value xs
        
contains :: (Eq k) => k -> [(k,v)] -> Bool
contains key [] = False
contains key ((k,_):xs)
    | key == k  = True
    | otherwise = contains key xs