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 --