traintable/dijkstra.hs at master · bobbykrk/traintable · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
    import List
    import Data.Maybe

    type Id = Int

    type Weight = Int

    type Edge = ( Id, Id )

    type Graph = [ ( Edge, Weight ) ]

    data Cost = Finite Weight | Infinity
                deriving ( Eq, Ord, Show )

    type PathCost = ( Cost, Id )


    g1 :: Graph
    g1 = [
     ( ( 0, 1 ), 1 ),
     ( ( 0, 2 ), 3 ),
     ( ( 0, 4 ), 6 ),
     ( ( 1, 2 ), 1 ),
     ( ( 1, 3 ), 3 ),
     ( ( 2, 0 ), 1 ),
     ( ( 2, 1 ), 2 ),
     ( ( 2, 3 ), 1 ),
     ( ( 3, 0 ), 3 ),
     ( ( 3, 4 ), 2 ),
     ( ( 4, 3 ), 1 ),
     ( ( 5, 2 ), 9 ) ]

    g2 :: Graph
    g2 = [ ( ( 0, 1 ), 1 ),
           ( ( 1, 2 ), 4 ) ]

    -----------------------------------------------------------------

    edges :: Graph -> Int
    edges = length

    totalWeight :: Graph -> Weight
    totalWeight
       = sum . map snd

    nodes :: Graph -> [ Id ]
    nodes
       = nub . fst . unzip . map fst


    instance Num Cost where
       (+) = addCosts

    addCosts :: Cost -> Cost -> Cost
    addCosts (Finite weightA) (Finite weightB) = Finite ( weightA + weightB )
    addCosts _ _ = Infinity

    lookUp :: Edge -> Graph -> Cost
    lookUp edge = maybe Infinity Finite . lookup edge

    remove :: Eq a => a -> [ a ] -> [ a ]
    remove = flip (\\) . flip (:) []

    allPaths :: Graph -> [ PathCost ]
    allPaths graph = addRemainingPaths [((lookUp ( 0 , node ) graph), node) | node <- nodes graph] []
       where
        addRemainingPaths :: [ PathCost ] -> [ PathCost ] -> [ PathCost ]
        addRemainingPaths [] acc = acc
        addRemainingPaths ps acc
           = addRemainingPaths (map relaxation (remove minp ps)) (minp : acc)
             where
              minp@(cmin, j) = minimum ps
              relaxation (c,i) = (c', i)
               where
                c' = min c ( cmin  + ( lookUp (j,i) graph ) )