Advertisement
Guest User

Untitled

a guest
Jan 11th, 2013
181
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 4.30 KB | None | 0 0
  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
  29. road = rname . head
  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 --
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement