Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!
Guest

Untitled

By: a guest on Jan 11th, 2013  |  syntax: None  |  size: 4.30 KB  |  views: 116  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
This paste has a previous version, view the difference. Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  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 --