Day 14

data/polymer.txt

+OOFNFCBHCKBBVNHBNVCP
+
+PH -> V
+OK -> S
+KK -> O
+BV -> K
+CV -> S
+SV -> C
+CK -> O
+PC -> F
+SC -> O
+KC -> S
+KF -> N
+SN -> C
+SF -> P
+OS -> O
+OP -> N
+FS -> P
+FV -> N
+CP -> S
+VS -> P
+PB -> P
+HP -> P
+PK -> S
+FC -> F
+SB -> K
+NC -> V
+PP -> B
+PN -> N
+VN -> C
+NV -> O
+OV -> O
+BS -> K
+FP -> V
+NK -> K
+PO -> B
+HF -> H
+VK -> S
+ON -> C
+KH -> F
+HO -> P
+OO -> H
+BC -> V
+CS -> O
+OC -> B
+VB -> N
+OF -> P
+FK -> H
+OH -> H
+CF -> K
+CC -> V
+BK -> O
+BH -> F
+VV -> N
+KS -> V
+FO -> F
+SH -> F
+OB -> O
+VH -> F
+HH -> P
+PF -> C
+NF -> V
+VP -> S
+CN -> V
+SK -> O
+FB -> S
+FN -> S
+BF -> H
+FF -> V
+CB -> P
+NN -> O
+VC -> F
+HK -> F
+BO -> H
+KO -> C
+CH -> N
+KP -> C
+HS -> P
+NP -> O
+NS -> V
+NB -> H
+HN -> O
+BP -> C
+VF -> S
+KN -> P
+HC -> C
+PS -> K
+BB -> O
+NO -> N
+NH -> F
+BN -> F
+KV -> V
+SS -> K
+CO -> H
+KB -> P
+FH -> C
+SP -> C
+SO -> V
+PV -> S
+VO -> O
+HV -> N
+HB -> V
\ No newline at end of file

src/AOC-14a.hs

 module Main where
 
+import Control.Monad ( void )
+import Data.Char ( isUpper )
+import qualified Data.Map as M
+import Data.Map (Map)
+import Text.ParserCombinators.ReadP
+    ( many, munch1, readP_to_S, satisfy, skipSpaces, string, ReadP )
+
+parsePolymer :: ReadP String
+parsePolymer = munch1 isUpper
+
+parseRule :: ReadP (Char,Char,Char)
+parseRule = do
+  skipSpaces
+  ch1 <- satisfy isUpper
+  ch2 <- satisfy isUpper
+  void $ string " -> "
+  ch3 <- satisfy isUpper
+  pure (ch1,ch2,ch3)
+
+data PolymerProgram = PolymerProgram 
+  { start :: [Char]
+  , rules :: Map (Char,Char) String
+  }
+
+parsePolymerProgram :: ReadP PolymerProgram
+parsePolymerProgram = do
+  polymer <- parsePolymer
+  primRules <- many (parseRule)
+  pure $ PolymerProgram polymer (M.fromList . map (\(a,b,c) -> ((a,b),[a,c])) $ primRules)
+
+instance Read PolymerProgram where
+  readsPrec _ = readP_to_S parsePolymerProgram
+
+step :: Map (Char,Char) String -> String -> String
+step _ [] = []
+step _  [a] = [a]
+step rs (a:b:c) = handlePair (a,b) ++ step rs (b:c) where
+  handlePair cp = M.findWithDefault [a] cp rs
+
+frequencies :: String -> Map Char Int
+frequencies = M.unionsWith (+) . map (\c -> M.singleton c 1)
+
+score :: Map a Int -> Int
+score m = maximum vs - minimum vs where
+  vs = M.elems m
+
 main :: IO ()
-main = pure ()
+main = do
+  prog <- read @PolymerProgram <$> readFile "data/polymer.txt"
+  print . score . frequencies . (!! 10). iterate (step (rules prog)) . start $ prog

src/AOC-14b.hs

 module Main where
 
+import Control.Monad ( void )
+import Data.Char ( isUpper )
+import qualified Data.Map as M
+import Data.Map (Map)
+import Text.ParserCombinators.ReadP
+    ( many, munch1, readP_to_S, satisfy, skipSpaces, string, ReadP )
+
+parsePolymer :: ReadP String
+parsePolymer = munch1 isUpper
+
+parseRule :: ReadP (Char,Char,Char)
+parseRule = do
+  skipSpaces
+  ch1 <- satisfy isUpper
+  ch2 <- satisfy isUpper
+  void $ string " -> "
+  ch3 <- satisfy isUpper
+  pure (ch1,ch2,ch3)
+
+type RuleMap = Map (Char,Char) [(Char,Char)]
+type CountMap a = Map a Integer
+
+data PolymerProgram = PolymerProgram 
+  { start :: [Char]
+  , rules :: Map (Char,Char) [(Char,Char)]
+  }
+
+parsePolymerProgram :: ReadP PolymerProgram
+parsePolymerProgram = do
+  polymer <- parsePolymer
+  primRules <- many (parseRule)
+  pure $ PolymerProgram polymer (M.fromList . map (\(a,b,c) -> ((a,b),[(a,c),(c,b)])) $ primRules)
+
+instance Read PolymerProgram where
+  readsPrec _ = readP_to_S parsePolymerProgram
+
+step :: RuleMap -> CountMap (Char,Char) -> CountMap (Char,Char)
+step rm cm = M.unionsWith (+) . concatMap f . M.assocs $ cm where
+  f (p,n) = do
+    p' <- M.findWithDefault [p] p rm
+    pure $ M.singleton p' n
+
+pairs :: [a] -> [(a,a)]
+pairs [] = []
+pairs [_] = []
+pairs (a:b:cs) = (a,b) : pairs (b:cs)
+
+initialCounts :: String -> CountMap (Char,Char)
+initialCounts s = M.unionsWith (+) $ do
+  p' <- pairs s
+  pure $ M.singleton p' 1
+
+frequencies :: String -> Map Char Int
+frequencies = M.unionsWith (+) . map (\c -> M.singleton c 1)
+
+charCounts :: CountMap (Char,Char) -> CountMap Char
+charCounts cm = fmap (\x -> (x+1) `div` 2) . M.unionsWith (+) $ do
+  ((c,d),n) <- M.assocs cm
+  pure $ M.unionWith (+) (M.singleton c n) (M.singleton d n)
+
+score :: CountMap Char -> Integer
+score m = maximum vs - minimum vs where
+  vs = M.elems m
+
 main :: IO ()
-main = pure ()
+main = do
+  prog <- read @PolymerProgram <$> readFile "data/polymer.txt"
+  print . score . charCounts . (!! 40) . iterate (step (rules prog)) . initialCounts . start $ prog

test/polymer.txt

+NNCB
+
+CH -> B
+HH -> N
+CB -> H
+NH -> C
+HB -> C
+HC -> B
+HN -> C
+NN -> C
+BH -> H
+NC -> B
+NB -> B
+BN -> B
+BB -> N
+BC -> B
+CC -> N
+CN -> C
\ No newline at end of file