Google Code Jam/Train Timetable

The program produces a list of trains. A train is added whenever there is no train ready to run, in the right place for a journey. When there is a suitable train it is used. The journeys are pooled and sorted by ascending starting time. The trains are stateful and carry around the next place they will be ready to leave with the minimum time. Minimum leaving time is last arrival time plus turning time. Journeys are examinated one by one and used trains updated.

import Data.List data City = A | B deriving (Eq,Ord,Show) type Time = Int -- | A point in time and space data TP = TP {at :: Time , pos :: City} deriving (Ord,Eq) data Tratta = Tratta { from :: TP, to :: TP} deriving (Ord,Eq) -- | the name of the city the train started at beginning and the TP it will be ready next data Train = Train {started :: City , doing ::TP} deriving Eq -- | test for a Train if it can do a Tratta ready :: Tratta -> Train -> Bool ready (Tratta from _) (Train _ doing) = pos from == pos doing && at doing <= at from -- | update a list of Train , a new train is added if no other can be used busy :: [Train] -> Tratta -> [Train] busy ts x = case find (ready x) ts of Nothing -> Train (pos . from $ x) (to x) : ts Just t -> Train (started t) (to x) : delete t ts -- | creates the trains from a list of Tratta to be done trains :: [Tratta] -> [Train] trains = foldl' busy [] type Versus = (City,City) parseTratta :: Int -> Versus -> String -> Tratta parseTratta ta (a,b) x = let [t1,t2] = map toMinute . words $ x toMinute (h1:h2:':':m1:[m2]) = read [h1,h2] * 60 + read [m1,m2] in Tratta (TP t1 a) (TP (t2 + ta) b) parseCase [] = Nothing parseCase (ta:m:xs) = let [t1,t2] = map read . words $ m (das,xs') = splitAt t1 xs (dbs,xs'') = splitAt t2 xs' pta = parseTratta (read ta) in Just (sort $ map (pta (A,B)) das ++ map (pta (B,A)) dbs,xs'') parseCases :: String -> [[Tratta]] parseCases x = let (n:ts) = lines x in take (read n) . unfoldr parseCase $ ts main = do ts <- parseCases `fmap` getContents flip mapM_ (zip [1..] ts) $ \(i,ns) -> do putStr $ "Case #" ++ show i ++ ": " let (as,bs) = partition ((==A). started) $ trains ns putStrLn $ (show (length as) ++ " " ++ show (length bs))