advent04/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2021/12/04/advent-of-code-2021-day-4/
   2
   3 import Data.Text ()
   4 import qualified Data.Text.IO as TIO
   5
   6 import Data.Attoparsec.Text
   7 import Control.Applicative
   8
   9 import Data.List
  10
  11 type Square = [[Int]]
  12
  13 data BingoNum = BingoNum Int Bool
  14   deriving (Eq, Show)
  15
  16 type BingoSquare = [[BingoNum]]
  17
  18 data BingoState = BingoState Int [BingoSquare]
  19   deriving (Eq, Show)
  20
  21
  22
  23 main :: IO ()
  24 main =
  25   do  text <- TIO.readFile "data/advent04.txt"
  26       let (nums, rawSquares) = successfulParse text
  27       let squares = map mkSquare rawSquares
  28       print $ part1 nums squares
  29       print $ part2 nums squares
  30
  31 part1 :: [Int] -> [BingoSquare] -> Int
  32 part1 callNums squares = finalCalled * winningSum
  33   where allSteps = scanl' bingoStep (BingoState 0 squares) callNums
  34         BingoState finalCalled finalSquares = head $ dropWhile (not . hasCompletedSquare) allSteps
  35         winningSquare = head $ filter completed finalSquares
  36         winningSum = unmarkedSum winningSquare
  37
  38 part2 :: [Int] -> [BingoSquare] -> Int
  39 part2 callNums squares = finalCalled * winningSum
  40   where allSteps = scanl' pruningBingoStep (BingoState 0 squares) callNums
  41         BingoState finalCalled finalSquares =
  42           head $ dropWhile (not . hasCompletedSquare)
  43                $ dropWhile manyRemainingSquares allSteps
  44         winningSquare = head finalSquares
  45         winningSum = unmarkedSum winningSquare
  46
  47
  48 bingoStep :: BingoState -> Int -> BingoState
  49 bingoStep (BingoState _ squares) caller = BingoState caller squares'
  50   where squares' = map (callSquare caller) squares
  51
  52 pruningBingoStep :: BingoState -> Int -> BingoState
  53 pruningBingoStep (BingoState _ squares) caller = BingoState caller squares''
  54   where squares' = filter (not . completed) squares
  55         squares'' = map (callSquare caller) squares'
  56
  57 hasCompletedSquare :: BingoState -> Bool
  58 hasCompletedSquare (BingoState _n squares) = any completed squares
  59
  60 unmarkedSum :: BingoSquare -> Int
  61 unmarkedSum bingoSquare =
  62   sum [value bn | r <- bingoSquare, bn <- r, (not $ isCalled bn)]
  63
  64 manyRemainingSquares :: BingoState -> Bool
  65 manyRemainingSquares (BingoState _ squares) = (length squares) > 1
  66
  67
  68 mkBingoNum :: Int -> BingoNum
  69 mkBingoNum n = BingoNum n False
  70
  71 forceCall :: BingoNum -> BingoNum
  72 forceCall (BingoNum n _) = BingoNum n True
  73
  74 call :: Int -> BingoNum -> BingoNum
  75 call num (BingoNum target called)
  76   | num == target = BingoNum target True
  77   | otherwise = BingoNum target called
  78
  79 isCalled :: BingoNum -> Bool
  80 isCalled (BingoNum _ c) = c
  81
  82 value :: BingoNum -> Int
  83 value (BingoNum n _) = n
  84
  85 mkSquare :: Square -> BingoSquare
  86 mkSquare = map (map mkBingoNum)
  87
  88 callSquare :: Int -> BingoSquare -> BingoSquare
  89 callSquare n = map (map (call n))
  90
  91 completed :: BingoSquare -> Bool
  92 completed sq = (any completedRow sq) || (any completedRow $ transpose sq)
  93
  94 completedRow :: [BingoNum] -> Bool
  95 completedRow = all isCalled
  96
  97 -- Parse the input file
  98
  99 bingoP = (,) <$> calledP <*> (blankLines *> squaresP)
 100
 101 calledP = decimal `sepBy` ","
 102
 103 squaresP = squareP `sepBy` blankLines
 104 squareP = rowP `sepBy` endOfLine
 105 rowP = paddedDecimal `sepBy1` " "
 106
 107 -- paddedDecimal :: Parser Text Int
 108 paddedDecimal = (many " ") *> decimal
 109
 110 blankLines = many1 endOfLine
 111
 112 -- successfulParse :: Text -> (Integer, [Maybe Integer])
 113 successfulParse input =
 114   case parseOnly bingoP input of
 115     Left  _err -> ([], []) -- TIO.putStr $ T.pack $ parseErrorPretty err
 116     Right bingo -> bingo