···11module AoC (module X) where
2233import AoC.Y2018.Day1 as X
44-import AoC.Y2018.Day2 as X44+import AoC.Y2018.Day2 as X
55+import AoC.Y2018.Day3 as X
+98
src/AoC/Y2018/Day3.hs
···11+{-# LANGUAGE TemplateHaskell #-}
22+33+module AoC.Y2018.Day3 where
44+55+import Papa
66+import qualified Data.Text as T (unpack)
77+import qualified Data.Text.IO as T (readFile)
88+import qualified Data.Map.Strict as C
99+import qualified Control.Monad.Combinators as P
1010+import qualified Text.Megaparsec as P
1111+import qualified Text.Megaparsec.Char as P
1212+import qualified Text.Megaparsec.Char.Lexer as L
1313+1414+newtype CellID = CellID (Integer,Integer) deriving (Eq, Ord, Show)
1515+1616+type ClaimID = Integer
1717+1818+data ClaimEntry = ClaimEntry {
1919+ _claimID :: ClaimID
2020+ , _left :: Integer
2121+ , _top :: Integer
2222+ , _width :: Integer
2323+ , _height :: Integer
2424+ } deriving Show
2525+makeLenses ''ClaimEntry
2626+2727+-- | Parser stuff
2828+2929+type Parser = P.Parsec Void String
3030+3131+sc :: Parser ()
3232+sc = L.space P.space1 P.empty P.empty
3333+3434+lexeme :: Parser a -> Parser a
3535+lexeme = L.lexeme sc
3636+3737+symbol :: String -> Parser String
3838+symbol = L.symbol sc
3939+4040+integer :: Parser Integer
4141+integer = lexeme L.decimal
4242+4343+headPartial :: [Integer] -> Integer
4444+headPartial [x] = x
4545+headPartial _ = 0
4646+4747+claimParser :: Parser [ClaimEntry]
4848+claimParser = some $ do
4949+ _ <- P.char '#'
5050+ i <- integer
5151+ _ <- symbol "@"
5252+ l <- headPartial <$> P.someTill L.decimal (P.char ',')
5353+ t <- headPartial <$> P.someTill L.decimal (symbol ":")
5454+ w <- headPartial <$> P.someTill L.decimal (P.char 'x')
5555+ h <- headPartial <$> P.endBy1 L.decimal P.eol
5656+ return $ ClaimEntry i l t w h
5757+5858+parseClaimsInput' :: Parser [ClaimEntry] -> String -> [ClaimEntry]
5959+parseClaimsInput' p s = let ps = P.parse p "" s
6060+ in
6161+ case ps of
6262+ Left _ -> []
6363+ Right xs -> xs
6464+6565+parseClaimsInput :: FilePath -> IO [ClaimEntry]
6666+parseClaimsInput f = parseClaimsInput' claimParser . T.unpack <$> T.readFile f
6767+6868+-- | Parser stuff complete
6969+7070+claimLoc :: ClaimEntry -> [(CellID, ClaimID)]
7171+claimLoc c = let cs :: [(Integer, Integer)]
7272+ cs = [(c^.top + j, c^.left + i) | j <- [1..c^.height] , i <- [1..c^.width]]
7373+ in
7474+ (\ccs -> (CellID ccs, c^.claimID)) <$> cs
7575+7676+mkMap :: [[(CellID, ClaimID)]] -> C.Map CellID [ClaimID]
7777+mkMap = C.fromListWith (++) . (<$>) (\(c,ii) -> (c,[ii])) . concat
7878+7979+pristineClaim :: C.Map CellID [ClaimID] -> [ClaimID]
8080+pristineClaim m = let s = nub $ concat $ C.elems $ C.filter ((==1) . length) m
8181+ ns = nub $ concat $ C.elems $ C.filter ((\l -> l > 1 && l <=2) . length) m
8282+ is = nub $ intersect s ns
8383+ in
8484+ s \\ is
8585+8686+day3Puzzle1 :: FilePath -> IO Int
8787+day3Puzzle1 f = do
8888+ p <- parseClaimsInput f
8989+ return $ C.size $ C.filter ((>1) . length) $ mkMap $ claimLoc <$> p
9090+9191+day3Puzzle2 :: FilePath -> IO (Maybe ClaimID)
9292+day3Puzzle2 f = do
9393+ p <- parseClaimsInput f
9494+ let xs = pristineClaim $ mkMap $ claimLoc <$> p
9595+ return $
9696+ case xs of
9797+ [x] -> Just x
9898+ _ -> Nothing