Day 4, parts 1 & 2: Initial solutions.

Day4/Part1.hs

@@ -0,0 +1,68 @@
+#! /usr/bin/env stack
+-- stack --resolver lts-12.20 --install-ghc script
+{-# LANGUAGE FlexibleContexts #-}
+module Main where
+
+import Control.Applicative
+import Control.Monad.State
+import Data.Bifunctor (first, second)
+import Data.Function (on)
+import Data.Maybe
+
+import qualified Data.List            as L
+import qualified Data.Map             as M
+import qualified Text.Parsec          as P
+import qualified Text.Parsec.Language as PL
+import qualified Text.Parsec.Token    as PT
+
+main :: IO ()
+main = interact $ (show .) $ (. parseEvents) $ \events ->
+   let spansAsleep = flip execState M.empty $ start (L.sort events)
+         where
+            start [] = pure ()
+            start ((Event { evtType = Begins g }):es) = began g es
+            start (e:es) = error $ "start: " ++ show e
+            began g ((Event { evtDate = dt, evtTime = tm, evtType = Sleeps }):es) = slept g dt tm es
+            began _ es = start es
+            slept g sdt stm ((Event { evtDate = wdt, evtTime = wtm, evtType = Wakes }):es) = do
+               modify $ flip (M.unionWith (++)) (M.singleton g [((sdt, stm), (wdt, wtm))])
+               began g es
+       timeAsleep = M.map (sum . map (\((_,stm),(_,wtm)) -> ((-) `on` tmMinute) wtm stm)) spansAsleep
+       mostAsleep = L.maximumBy (compare `on` snd) (M.assocs timeAsleep)
+       minuteAsleep g = L.maximumBy (compare `on` snd) $
+          [ (m, n) | m <- [0..59], let n = length $ filter (\((_,stm),(_,wtm)) -> tmMinute stm <= m && m < tmMinute wtm) (fromJust $ M.lookup g spansAsleep) ]
+   in (mostAsleep, minuteAsleep (fst mostAsleep), fst mostAsleep * fst (minuteAsleep (fst mostAsleep)))
+
+type Guard = Int
+
+data Date = Date { dtYear  :: Int
+                 , dtMonth :: Int
+                 , dtDay   :: Int
+                 } deriving (Eq, Ord, Show)
+
+data Time = Time { tmHour   :: Int
+                 , tmMinute :: Int
+                 } deriving (Eq, Ord, Show)
+
+data EventType = Begins Guard | Sleeps | Wakes deriving (Eq, Ord, Show)
+
+data Event a = Event { evtDate  :: Date
+                     , evtTime  :: Time
+                     , evtType  :: EventType
+                     , evtExtra :: a
+                     } deriving (Eq, Ord, Show)
+
+instance Functor Event where
+   fmap f evt = evt { evtExtra = f (evtExtra evt) }
+
+parseEvents :: String -> [Event ()]
+parseEvents = either (error . show) id . P.runParser (many event <* P.eof) () "input"
+   where
+      decimal    = fromInteger <$> PT.decimal PL.haskell
+      whiteSpace = PT.whiteSpace PL.haskell
+      event = Event <$ P.char '[' <*> date <* whiteSpace <*> time <* P.char ']' <* whiteSpace <*> eventType <* P.endOfLine <*> pure ()
+      date = Date <$> decimal <* P.char '-' <*> decimal <* P.char '-' <*> decimal
+      time = Time <$> decimal <* P.char ':' <*> decimal
+      eventType = (Begins <$ P.string "Guard #" <*> decimal <* P.string " begins shift")
+              <|> (Sleeps <$ P.string "falls asleep")
+              <|> (Wakes  <$ P.string "wakes up")

Day4/Part2.hs

@@ -0,0 +1,68 @@
+#! /usr/bin/env stack
+-- stack --resolver lts-12.20 --install-ghc script
+{-# LANGUAGE FlexibleContexts #-}
+module Main where
+
+import Control.Applicative
+import Control.Monad.State
+import Data.Bifunctor (first, second)
+import Data.Function (on)
+import Data.Maybe
+
+import qualified Data.List            as L
+import qualified Data.Map             as M
+import qualified Text.Parsec          as P
+import qualified Text.Parsec.Language as PL
+import qualified Text.Parsec.Token    as PT
+
+main :: IO ()
+main = interact $ (show .) $ (. parseEvents) $ \events ->
+   let spansAsleep = flip execState M.empty $ start (L.sort events)
+         where
+            start [] = pure ()
+            start ((Event { evtType = Begins g }):es) = began g es
+            start (e:es) = error $ "start: " ++ show e
+            began g ((Event { evtDate = dt, evtTime = tm, evtType = Sleeps }):es) = slept g dt tm es
+            began _ es = start es
+            slept g sdt stm ((Event { evtDate = wdt, evtTime = wtm, evtType = Wakes }):es) = do
+               modify $ flip (M.unionWith (++)) (M.singleton g [((sdt, stm), (wdt, wtm))])
+               began g es
+       minuteAsleep g = L.maximumBy (compare `on` snd) $
+          [ (m, n) | m <- [0..59], let n = length $ filter (\((_,stm),(_,wtm)) -> tmMinute stm <= m && m < tmMinute wtm) (fromJust $ M.lookup g spansAsleep) ]
+       mostAsleep = L.maximumBy (compare `on` snd . snd) $
+          [ (g, minuteAsleep g) | g <- M.keys spansAsleep ]
+   in let m@(g,(minute,_)) = mostAsleep in (m, g*minute)
+
+type Guard = Int
+
+data Date = Date { dtYear  :: Int
+                 , dtMonth :: Int
+                 , dtDay   :: Int
+                 } deriving (Eq, Ord, Show)
+
+data Time = Time { tmHour   :: Int
+                 , tmMinute :: Int
+                 } deriving (Eq, Ord, Show)
+
+data EventType = Begins Guard | Sleeps | Wakes deriving (Eq, Ord, Show)
+
+data Event a = Event { evtDate  :: Date
+                     , evtTime  :: Time
+                     , evtType  :: EventType
+                     , evtExtra :: a
+                     } deriving (Eq, Ord, Show)
+
+instance Functor Event where
+   fmap f evt = evt { evtExtra = f (evtExtra evt) }
+
+parseEvents :: String -> [Event ()]
+parseEvents = either (error . show) id . P.runParser (many event <* P.eof) () "input"
+   where
+      decimal    = fromInteger <$> PT.decimal PL.haskell
+      whiteSpace = PT.whiteSpace PL.haskell
+      event = Event <$ P.char '[' <*> date <* whiteSpace <*> time <* P.char ']' <* whiteSpace <*> eventType <* P.endOfLine <*> pure ()
+      date = Date <$> decimal <* P.char '-' <*> decimal <* P.char '-' <*> decimal
+      time = Time <$> decimal <* P.char ':' <*> decimal
+      eventType = (Begins <$ P.string "Guard #" <*> decimal <* P.string " begins shift")
+              <|> (Sleeps <$ P.string "falls asleep")
+              <|> (Wakes  <$ P.string "wakes up")