never executed always true always false

    1 {-|
    2 Module:      Y2021.D14
    3 Description: Advent of Code 2021 Day 14 Solutions.
    4 License:     MIT
    5 Maintainer:  @tylerjl
    6 
    7 Solutions to the 2021 day 14 set of problems for <adventofcode.com>.
    8 -}
    9 module Y2021.D14
   10   ( parse14
   11   , part14A
   12   , part14B
   13   ) where
   14 
   15 import Data.Attoparsec.Text
   16 import Data.Either.Utils (fromRight)
   17 import Data.Foldable     (foldl')
   18 import Data.Map.Strict   (Map)
   19 import Data.Monoid
   20 import Data.MultiSet     (MultiSet)
   21 import Data.Text         (Text)
   22 import Data.Tuple.Extra  ((&&&))
   23 
   24 import qualified Data.Map.Strict as M
   25 import qualified Data.MultiSet   as S
   26 
   27 type PolySubs = Map String Char
   28 type Polymer = Map String (Sum Int)
   29 
   30 -- |Solution to part A
   31 part14A :: Text -> Int
   32 part14A = uncurry (solve14 10) . parse14
   33 
   34 -- |Solution to part B
   35 part14B :: Text -> Int
   36 part14B = uncurry (solve14 40) . parse14
   37 
   38 -- |Day 14 solution applicable to either parts A or B. Most of the dirty work
   39 -- happens in `react`, but this does the output calculation logic.
   40 solve14 :: Int -> Polymer -> PolySubs -> S.Occur
   41 solve14 iterations polymer subs =
   42   abs $
   43   uncurry subtract $
   44   (minimum &&& maximum) $
   45   map (adjust . snd) $
   46   S.toOccurList $ aggregate $ flip (!!) iterations $ iterate (react subs) polymer
   47   where
   48     adjust n
   49       | even n = n `div` 2
   50       | otherwise = (n + 1) `div` 2
   51 
   52 -- |Turn our map of tracked pairs into a `MultiSet` of characters. This number
   53 -- won't offer the solution (occurrences for each character) but just needs
   54 -- minor adjustments later to be accurate.
   55 aggregate :: Map [Char] (Sum S.Occur) -> MultiSet Char
   56 aggregate (M.toList -> chains) = foldl' summate S.empty chains
   57   where
   58     summate acc (chain, getSum -> n) = foldl' addTo acc $ zip (repeat n) chain
   59       where
   60         addTo multiset (instances, sym) =
   61           S.insertMany sym instances multiset
   62 
   63 -- |Function that's suitable to be fed into `iterate`. It's probably fairly
   64 -- memory-hungry since it builds up some big structures recursively, but it does
   65 -- the job.
   66 react :: PolySubs -> Polymer -> Polymer
   67 react subs polymer = foldl' expand M.empty (M.toList polymer)
   68   where
   69     expand newPoly (chain@[a, b], n) =
   70       case M.lookup chain subs of
   71         Nothing -> addSum newPoly chain n
   72         Just sub -> foldl' (uncurry . addSum) newPoly chains
   73           where chains = zip [[a, sub], [sub, b]] (repeat n)
   74     expand _ _ = error "unreachable"
   75 
   76 -- |Rearrange a few arguments to make inserting a running sum easier.
   77 addSum :: Polymer -> String -> Sum Int -> Polymer
   78 addSum set k v = M.insertWith mappend k v set
   79 
   80 -- |Pair up adjacent list elements into groups of two.
   81 twos :: [a] -> [[a]]
   82 twos (a:b:xs) = [a, b] : twos (b : xs)
   83 twos _ = []
   84 
   85 -- |Parse out a sequence of chars followed by the reaction translations.
   86 parse14 :: Text -> (Polymer, PolySubs)
   87 parse14 = fromRight . parseOnly (parser <* endOfLine <* endOfInput)
   88   where
   89     parser =
   90       (,) <$> (template <* endOfLine) <*>
   91       (M.fromList <$> sub `sepBy1` endOfLine)
   92     template =
   93       M.fromList . flip zip (repeat (Sum 1)) . twos <$> many1 cap <* endOfLine
   94     sub = (,) <$> caps <* string " -> " <*> cap
   95     caps = many1 cap
   96     cap = satisfy (`elem` ['A' .. 'Z'])