never executed always true always false

    1 {-|
    2 Module:      Y2021.D04
    3 Description: Advent of Code 2021 Day 04 Solutions.
    4 License:     MIT
    5 Maintainer:  @tylerjl
    6 
    7 Solutions to the 2021 day 04 set of problems for <adventofcode.com>.
    8 -}
    9 module Y2021.D04 where
   10 
   11 import Data.Attoparsec.Text
   12 import Data.List (transpose)
   13 import Data.Maybe (isNothing, catMaybes)
   14 import Data.Monoid (Sum (Sum), getSum)
   15 import Data.Set (Set)
   16 import Data.Text (Text)
   17 import qualified Data.Set as S
   18 
   19 -- |Fancy data type to represent _game_ state, not just a card
   20 newtype Bingo a = Bingo a deriving Show
   21 -- |I'm not sure if a derive would get this right
   22 instance Functor Bingo where
   23   fmap f (Bingo a) = Bingo (f a)
   24 -- |Represents a game board state
   25 data Card = CardArr [[Square]]
   26           | CardSet RowSet ColSet
   27           deriving Show
   28 -- |Alternative game board representation
   29 type ColSet = Set (Set (Sum Int))
   30 type RowSet = Set (Set (Sum Int))
   31 -- |Small wrapper over how to record marked/unmarked squares
   32 type Square = Maybe (Sum Int)
   33 
   34 -- |Solve part A
   35 part4A :: Text -> Int
   36 part4A (bingoParser -> Right (ns, cs)) = solve4 head ns cs
   37 part4A (bingoParser -> Left err) = error err
   38 
   39 -- |Solve part A - with sets!
   40 part4ASet :: Text -> Int
   41 part4ASet (bingoParser -> Right (ns, map (fmap intoSet) -> cs)) =
   42   solve4 head ns cs
   43 part4ASet (bingoParser -> Left err) = error err
   44 
   45 -- |Solve part B
   46 part4B :: Text -> Int
   47 part4B (bingoParser -> Right (ns, cs)) = solve4 last ns cs
   48 part4B (bingoParser -> Left err) = error err
   49 
   50 -- |Solve part B - with sets!
   51 part4BSet :: Text -> Int
   52 part4BSet (bingoParser -> Right (ns, map (fmap intoSet) -> cs)) =
   53   solve4 last ns cs
   54 part4BSet (bingoParser -> Left err) = error err
   55 
   56 -- |Transform a bingo game from multidimensional-array based to a set-based
   57 -- game.
   58 intoSet :: Card -> Card
   59 intoSet (CardArr (map catMaybes -> rows)) = CardSet rows' cols'
   60   where rows' = S.fromList $ map S.fromList rows
   61         cols' = S.fromList $ map S.fromList (transpose rows)
   62 intoSet c@(CardSet _ _) = c
   63 
   64 -- |Fortunately both A and B are just asking slightly different questions, so we
   65 -- have a higher-order function to determine how to pull the matching value from
   66 -- our resultant list.
   67 solve4 :: ([(Int, Bingo Card)] -> (Int, Bingo Card)) -> [Int] -> [Bingo Card] -> Int
   68 solve4 f x = tally . f . iterateMap x
   69 
   70 -- |Problem-defined method of scoring a card. The "in-progress" scoring isn't
   71 -- actually ever used. Probably a bug.
   72 tally :: (Int, Bingo Card) -> Int
   73 tally (n, Bingo card)  = n * sumCard card
   74 
   75 -- |Yank out the total values for a card.
   76 sumCard :: Card -> Int
   77 sumCard (CardArr board) = (getSum . mconcat . catMaybes . concat) board
   78 sumCard (CardSet rows cols)
   79   | any S.null rows = sumSet rows
   80   | otherwise = sumSet cols
   81   where sumSet = getSum . S.fold mappend (Sum 0) . S.map (S.fold mappend (Sum 0))
   82 
   83 -- |Our main recursive loop to walk through the "called" numbers. We return a
   84 -- list solely of elements that meet the "ended" predicate.
   85 iterateMap :: [Int] -> [Bingo Card] -> [(Int, Bingo Card)]
   86 iterateMap [] _ = []
   87 iterateMap (n:nums) cards = zip (repeat n) needles ++ iterateMap nums haystacks
   88   where (needles, haystacks) = mark ([], []) n cards
   89 
   90 -- |Accept a list of `Bingo Card`s and update each with the called number.
   91 mark :: ([Bingo Card], [Bingo Card]) -> Int -> [Bingo Card] -> ([Bingo Card], [Bingo Card])
   92 mark acc _ [] = acc
   93 mark (l, r) num (card:cards)
   94   | gameEnd card' = mark (card' : l, r) num cards
   95   | otherwise = mark (l, card' : r) num cards
   96   where card' = markRows num card
   97 
   98 -- |Update a `Card` - we make the determination to "end" a game here, so as soon
   99 -- as its "won" the type swaps over to the ended value.
  100 markRows :: Int -> Bingo Card -> Bingo Card
  101 markRows n (Bingo (CardArr board)) = Bingo $ CardArr $ map (map (markRow n)) board
  102   where
  103     markRow _ Nothing = Nothing
  104     markRow n' a@(Just (Sum b)) | b == n'   = Nothing
  105                                 | otherwise = a
  106 markRows n (Bingo (CardSet rows cols)) = Bingo $ CardSet (markSet rows) (markSet cols)
  107   where markSet = S.map (S.delete (Sum n))
  108 
  109 -- |Important function to determine if a card is a winning card.
  110 gameEnd :: Bingo Card -> Bool
  111 gameEnd (Bingo (CardArr card))
  112   = check card || (check . transpose) card
  113   where check = any (all isNothing)
  114 gameEnd (Bingo (CardSet rows cols))
  115   = any S.null rows || any S.null cols
  116 
  117 -- |This is a sort of hairy, but all-in-one, parser for the problem set input. 5
  118 -- is a magic number for board size.
  119 bingoParser :: Text -> Either String ([Int], [Bingo Card])
  120 bingoParser = parseOnly parser
  121   where
  122     parser = (,) <$> (lottoParser <* endOfLine) <*> cardsParser <* atEnd
  123     lottoParser = decimal `sepBy1` char ',' <* endOfLine
  124     rowParser   = (Just . Sum <$> decimal) `sepBy1` many1 (char ' ')
  125     cardParser  = Bingo . CardArr <$>
  126       count 5 (many' space *> rowParser <* endOfLine)
  127     cardsParser = cardParser `sepBy1` endOfLine