• API
• FAQ
• Tools
• Trends
• Archive
SHARE
TWEET

# Untitled

a guest Jan 11th, 2013 119 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
1. import MapGraph
2. import Control.Arrow ((***))
3. import Data.List (minimumBy, nub)
4. import Data.Function (on)
5.
6. -- DATA
7. data RD = RD { rname :: String
8.              , rtype :: String
9.              , rsafety :: Int
10.              } deriving (Show, Ord, Eq)
11.
12. data CN = CN { cname :: String
13.              , ctype :: String
14.              , csafety :: Int
15.              } deriving (Show, Ord, Eq)
16.
17. type Route = ([RD], [CN])
18.
19. type RoadNetwork = Graph Int CN RD
20.
21. -- FUNCTIONS
22. traverseRoute :: Route -> [String]
23. traverseRoute (r, c) = case (r, c) of
24.   ([],[]) -> []
25.   ([], c) -> connection c : traverseRoute theRest
26.   (r, []) -> road r : traverseRoute theRest
27.   (r, c) -> road r : connection c : traverseRoute theRest
28.   where
30.     connection = cname . head
31.     theRest = (stail r, stail c)
32.     stail [] = []
33.     stail (x:xs) = xs
34.
35. createRoute :: Int -> Int -> RoadNetwork -> ([Edge Int RD],[Vertex CN])
36. createRoute s e g = if s == e
37.                     then ([lookupEdge g s],[])
38.                     else createRoute' s e g ([lookupEdge g s],[])
39.   where
40.     createRoute' :: Int -> Int -> RoadNetwork -> ([Edge Int RD],[Vertex CN]) -> ([Edge Int RD],[Vertex CN])
41.     createRoute' s e g (r, c) = if s == e
42.                                 then (r, c)
43.                                 else createRoute' s' e g (r', c')
44.       where
45.         c' = c ++ [snd (evaluateEdge s g)]
46.         r' = r ++ [head (outgoingEdges' (last c') g)]
47.         s' = keyOfEdge (last r') g
48.
49. getRoute :: Int -> Int -> RoadNetwork -> [String]
50. getRoute s e g = traverseRoute ((map fromEdge *** map fromVertex) route)
51.   where
52.     route = createRoute s e g
53.
54. data Path = Path { pcost :: Int
55.                  , proads :: [Edge Int RD]
56.                  , pconnections :: [Vertex CN]
57.                  } deriving (Show, Ord, Eq)
58.
59. createPath :: Edge Int RD -> Vertex CN -> Path -> Path
60. createPath e c p = Path (pcost p + rsafety (fromEdge e) + csafety (fromVertex c)) (nub \$ proads p ++ [e]) (nub \$ pconnections p ++ [c])
61.
62. pathsFromConnection :: Vertex CN -> RoadNetwork -> Path -> [Path]
63. pathsFromConnection c rn p = map (\e -> createPath e c p) (outgoingEdges' c rn)
64.
65. pickMinimum :: [Path] -> Path
66. pickMinimum = minimumBy (compare `on` pcost)
67.
68. pathEndWith :: Path -> Edge Int RD -> Bool
69. pathEndWith p e = e == last (proads p)
70.
71. pathToPaths :: Path -> RoadNetwork -> [Path]
72. pathToPaths p rn = if pconnections p /= []
73.                    then pathsFromConnection (snd \$ evaluateEdge' (edge p) rn) rn p
74.                    else [p]
75.   where
76.     edge = last . proads
77.
78.
79. pickOrExpand :: [Path] -> Edge Int RD -> RoadNetwork -> Path
80. pickOrExpand ps e rn = if s /= []
81.                        then pickMinimum s
82.                        else pickOrExpand (concatMap (`pathToPaths` rn) ps) e rn
83.   where
84.     s = filter (`pathEndWith` e) ps
85.
86. shortestPath :: Int -> Int -> RoadNetwork -> Path
87. shortestPath s e rn = if s == e
88.                       then Path 0 [se] []
89.                       else pickOrExpand (pathToPaths (createPath se cs (Path 0 [] [])) rn) ee rn
90.   where
91.     se = lookupEdge rn s
92.     ee = lookupEdge rn e
93.     cs = snd (evaluateEdge s rn)
94.
95. traversePath :: Path -> [String]
96. traversePath (Path s r c) = case (s,r,c) of
97.   (_,[],[]) -> []
98.   (s,r,[]) -> [road r] ++ traversePath theRest
99.   (s,[],c) -> [connection c] ++ traversePath theRest
100.   (s,r,c) -> [road r] ++ [connection c] ++ traversePath theRest
101.   where
102.     road = rname . fromEdge . head
103.     connection = cname . fromVertex . head
104.     theRest = Path s (stail r) (stail c)
105.     stail [] = []
106.     stail (x:xs) = xs
107.
108.
109. -- TEST DATA --
110. c0 = CN "Nulte" "C" 7
111. c1 = CN "FĂ¸rste" "C" 3
112. c2 = CN "Anden" "C" 4
113. c3 = CN "Tredje" "C" 5
114. c4 = CN "Fjerde" "C" 1
115. c5 = CN "Femte" "C" 2
116. c6 = CN "Sjette" "C" 6
117. c7 = CN "Syvende" "C" 8
118.
119. r1 = RD "First" "R" 6
120. r2 = RD "Second" "R" 3
121. r3 = RD "Thirth" "R" 8
122. r4 = RD "Fourth" "R" 2
123. r5 = RD "Fifth" "R" 5
124. r6 = RD "Sixth" "R" 1
125. r7 = RD "Seventh" "R" 4
126. r8 = RD "Eight" "R" 7
127. r9 = RD "Nineth" "R" 10
128. r10 = RD "Tenth" "R" 9
129.
130. rn :: RoadNetwork
131. rn = buildGraph [(0,c0),(1,c1),(2,c2),(3,c3),(4,c4),(5,c5),(6,c6),(7,c7)] [(1,0,1,r1),(2,1,2,r2),(3,1,3,r3),(4,2,5,r4),(5,3,4,r5),(6,2,4,r6),(7,3,5,r7),(8,5,6,r8),(9,4,6,r9),(10,6,7,r10)]
132. -- END TEST DATA --
RAW Paste Data
Top