Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- import MapGraph
- import Control.Arrow ((***))
- import Data.List (minimumBy, nub)
- import Data.Function (on)
- -- DATA
- data RD = RD { rname :: String
- , rtype :: String
- , rsafety :: Int
- } deriving (Show, Ord, Eq)
- data CN = CN { cname :: String
- , ctype :: String
- , csafety :: Int
- } deriving (Show, Ord, Eq)
- type Route = ([RD], [CN])
- type RoadNetwork = Graph Int CN RD
- -- FUNCTIONS
- traverseRoute :: Route -> [String]
- traverseRoute (r, c) = case (r, c) of
- ([],[]) -> []
- ([], c) -> connection c : traverseRoute theRest
- (r, []) -> road r : traverseRoute theRest
- (r, c) -> road r : connection c : traverseRoute theRest
- where
- road = rname . head
- connection = cname . head
- theRest = (stail r, stail c)
- stail [] = []
- stail (x:xs) = xs
- createRoute :: Int -> Int -> RoadNetwork -> ([Edge Int RD],[Vertex CN])
- createRoute s e g = if s == e
- then ([lookupEdge g s],[])
- else createRoute' s e g ([lookupEdge g s],[])
- where
- createRoute' :: Int -> Int -> RoadNetwork -> ([Edge Int RD],[Vertex CN]) -> ([Edge Int RD],[Vertex CN])
- createRoute' s e g (r, c) = if s == e
- then (r, c)
- else createRoute' s' e g (r', c')
- where
- c' = c ++ [snd (evaluateEdge s g)]
- r' = r ++ [head (outgoingEdges' (last c') g)]
- s' = keyOfEdge (last r') g
- getRoute :: Int -> Int -> RoadNetwork -> [String]
- getRoute s e g = traverseRoute ((map fromEdge *** map fromVertex) route)
- where
- route = createRoute s e g
- data Path = Path { pcost :: Int
- , proads :: [Edge Int RD]
- , pconnections :: [Vertex CN]
- } deriving (Show, Ord, Eq)
- createPath :: Edge Int RD -> Vertex CN -> Path -> Path
- createPath e c p = Path (pcost p + rsafety (fromEdge e) + csafety (fromVertex c)) (nub $ proads p ++ [e]) (nub $ pconnections p ++ [c])
- pathsFromConnection :: Vertex CN -> RoadNetwork -> Path -> [Path]
- pathsFromConnection c rn p = map (\e -> createPath e c p) (outgoingEdges' c rn)
- pickMinimum :: [Path] -> Path
- pickMinimum = minimumBy (compare `on` pcost)
- pathEndWith :: Path -> Edge Int RD -> Bool
- pathEndWith p e = e == last (proads p)
- pathToPaths :: Path -> RoadNetwork -> [Path]
- pathToPaths p rn = if pconnections p /= []
- then pathsFromConnection (snd $ evaluateEdge' (edge p) rn) rn p
- else [p]
- where
- edge = last . proads
- pickOrExpand :: [Path] -> Edge Int RD -> RoadNetwork -> Path
- pickOrExpand ps e rn = if s /= []
- then pickMinimum s
- else pickOrExpand (concatMap (`pathToPaths` rn) ps) e rn
- where
- s = filter (`pathEndWith` e) ps
- shortestPath :: Int -> Int -> RoadNetwork -> Path
- shortestPath s e rn = if s == e
- then Path 0 [se] []
- else pickOrExpand (pathToPaths (createPath se cs (Path 0 [] [])) rn) ee rn
- where
- se = lookupEdge rn s
- ee = lookupEdge rn e
- cs = snd (evaluateEdge s rn)
- traversePath :: Path -> [String]
- traversePath (Path s r c) = case (s,r,c) of
- (_,[],[]) -> []
- (s,r,[]) -> [road r] ++ traversePath theRest
- (s,[],c) -> [connection c] ++ traversePath theRest
- (s,r,c) -> [road r] ++ [connection c] ++ traversePath theRest
- where
- road = rname . fromEdge . head
- connection = cname . fromVertex . head
- theRest = Path s (stail r) (stail c)
- stail [] = []
- stail (x:xs) = xs
- -- TEST DATA --
- c0 = CN "Nulte" "C" 7
- c1 = CN "Første" "C" 3
- c2 = CN "Anden" "C" 4
- c3 = CN "Tredje" "C" 5
- c4 = CN "Fjerde" "C" 1
- c5 = CN "Femte" "C" 2
- c6 = CN "Sjette" "C" 6
- c7 = CN "Syvende" "C" 8
- r1 = RD "First" "R" 6
- r2 = RD "Second" "R" 3
- r3 = RD "Thirth" "R" 8
- r4 = RD "Fourth" "R" 2
- r5 = RD "Fifth" "R" 5
- r6 = RD "Sixth" "R" 1
- r7 = RD "Seventh" "R" 4
- r8 = RD "Eight" "R" 7
- r9 = RD "Nineth" "R" 10
- r10 = RD "Tenth" "R" 9
- rn :: RoadNetwork
- 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)]
- -- END TEST DATA --
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement