Code IQ チケットゴブル問題 Haskell勉強

ticketgobble.hs

import System.Environment
import System.Exit
import System.Locale
import Control.Monad
import Data.Char (isSpace)
import Data.Maybe (catMaybes)
import Text.Printf (printf)
import Text.Read (readMaybe)
import Data.Time.Format
import Data.Time.Clock
import qualified Data.List as List

data Ticket = Ticket {
    nation :: String
  , depature :: UTCTime
  , arrival :: UTCTime
}

instance Show Ticket where
  show ticket =
    nation ticket
     ++ " "
     ++ (formatTime defaultTimeLocale "%m/%d" $ depature ticket)
     ++ "-"
     ++ (formatTime defaultTimeLocale "%m/%d" $ arrival ticket)

main = do
  argv <- getArgs
  when (length argv /= 1) $ do
    putStrLn "usage:command filename"
    exitFailure

  tickets <- readTicketsFromFile (argv !! 0)
  let plan = genPlan $ tickets
  debugPrint plan
  -- putStr $ show (length plan) ++ " "
  -- answerPrint plan
  exitSuccess

debugPrint :: [Ticket] -> IO [()]
debugPrint plan = mapM putStrLn $ map show plan

answerPrint :: [Ticket] -> IO [()]
answerPrint plan = mapM putStr $ map ((++ " ") . nation) $ List.sortBy func plan
  where func = (\ a b -> compare (nation a) (nation b))

doublebooked :: Ticket -> Ticket -> Bool
doublebooked x y =
  not $ (arrival y) < (depature x) || (arrival x) < (depature y)

genPlan :: [Ticket] -> [Ticket]
genPlan [] = []
genPlan xs =
  let (plan : remainder) = xs
      nextCanditate = filter (not . (doublebooked plan)) remainder
  in plan : (genPlan nextCanditate)

readTicketsFromFile :: FilePath -> IO [Ticket]
readTicketsFromFile filePath = do
  contents <- readFile (filePath)
  return $ List.sortBy func $
     catMaybes . map (readTicket . chomp) $ lines contents
  where
     func = (\ a b -> compare (arrival a) (arrival b))

chomp :: String -> String
chomp = List.dropWhileEnd isSpace

split :: Eq a => a -> [a] -> [[a]]
split _ [] = [[]]
split delim str =
  let (before, remainder) = span (/= delim) str
  in before : case remainder of
              [] -> []
              x -> split delim $ tail x

readDateField :: String -> Maybe UTCTime
readDateField str = case split '/' str of
                  (month : (day : [])) ->
                    liftM2 buildDateString (format month) (format day) >>=
                    readUTCTime
                  _ -> Nothing

buildDateString :: String -> String -> String
buildDateString m d = "2012" ++ "/" ++ m ++ "/" ++ d

readUTCTime :: String -> Maybe UTCTime
readUTCTime = parseTime defaultTimeLocale "%Y/%m/%d"

format :: String -> Maybe String
format str = liftM (printf "%02d") ((readMaybe str) :: Maybe Int)

getNation :: String -> Maybe (String, String)
getNation line = let both@(nation , _) =
                       (break isSpace) . (dropWhile isSpace) $ line
                 in if length nation == 0
                    then Nothing
                    else Just both

getDate :: String -> Maybe (String, String)
getDate str = let (depature : (arrival : _)) =
                      (split '-') . (dropWhile isSpace) $ str
              in if length depature == 0 || length arrival == 0
                    then Nothing
                    else Just (depature, arrival)

readTicket :: String -> Maybe Ticket
readTicket line =
  getNation line >>=
  \ (nation, remainder) -> getDate remainder >>=
  \ (depature, arrival) -> liftM3
     Ticket (Just nation) (readDateField depature) (readDateField arrival)