Day 14

4 files changed, 210 insertions, 0 deletions

diff --git a/day14/input.txt b/day14/input.txt
new file mode 100644
index 0000000..91ad454
--- /dev/null
+++ b/day14/input.txt
@@ -0,0 +1,102 @@
+SHPPPVOFPBFCHHBKBNCV
+
+HK -> C
+SP -> H
+VH -> K
+KS -> B
+BC -> S
+PS -> K
+PN -> S
+NC -> F
+CV -> B
+SH -> K
+SK -> H
+KK -> O
+HO -> V
+HP -> C
+HB -> S
+NB -> N
+HC -> K
+SB -> O
+SN -> C
+BP -> H
+FC -> V
+CF -> C
+FB -> F
+VP -> S
+PO -> N
+HN -> N
+BS -> O
+NF -> H
+BH -> O
+NK -> B
+KC -> B
+OS -> S
+BB -> S
+SV -> K
+CH -> B
+OB -> K
+FV -> B
+CP -> V
+FP -> C
+VC -> K
+FS -> S
+SS -> F
+VK -> C
+SF -> B
+VS -> B
+CC -> P
+SC -> S
+HS -> K
+CN -> C
+BN -> N
+BK -> B
+FN -> H
+OK -> S
+FO -> S
+VB -> C
+FH -> S
+KN -> K
+CK -> B
+KV -> P
+NP -> P
+CB -> N
+KB -> C
+FK -> K
+BO -> O
+OV -> B
+OC -> B
+NO -> F
+VF -> V
+VO -> B
+FF -> K
+PP -> O
+VV -> K
+PC -> N
+OF -> S
+PV -> P
+PB -> C
+KO -> V
+BF -> N
+OO -> K
+NV -> P
+PK -> V
+BV -> C
+HH -> K
+PH -> S
+OH -> B
+HF -> S
+NH -> H
+NN -> K
+KF -> H
+ON -> N
+PF -> H
+CS -> H
+CO -> O
+SO -> K
+HV -> N
+NS -> N
+KP -> S
+OP -> N
+KH -> P
+VN -> H
diff --git a/day14/main.hs b/day14/main.hs
new file mode 100644
index 0000000..46974d1
--- /dev/null
+++ b/day14/main.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Main where
+
+import Data.Function (on)
+import qualified Data.List as L
+import Data.Map.Strict (Map, (!))
+import qualified Data.Map.Strict as M
+import Data.Text (pack, replace, unpack)
+import Data.Vector.Unboxed (Vector)
+import qualified Data.Vector.Unboxed as V
+import Debug.Trace (traceShow)
+import Utils
+
+recur1 :: Vector Char -> Map (Char, Char) Char -> Int -> Vector Char
+recur1 initial rules n
+  | n == 0 = initial
+  | otherwise =
+    let pairs = V.zip initial (V.tail initial)
+        inserted = pairs $> V.concatMap (\p@(a, _) -> V.fromList [a, rules ! p])
+        result = V.snoc inserted (V.last initial)
+     in recur1 result rules (n - 1)
+
+e1 initial rules =
+  let polymer = recur1 (V.fromList initial) rules 10
+      lengthPairs = polymer $> V.map (\c -> (c, V.length $ V.filter (== c) polymer))
+      (mc, mcN) = lengthPairs $> V.maximumBy (compare `on` snd)
+      (lc, lcN) = lengthPairs $> V.minimumBy (compare `on` snd)
+   in mcN - lcN
+
+type CPair = (Char, Char)
+
+type PairFreqMap = Map CPair Integer
+
+type CFreqMap = Map Char Integer
+
+type RuleMap = Map CPair Char
+
+type Maps = (PairFreqMap, CFreqMap, RuleMap)
+
+recur2 :: Maps -> Int -> CFreqMap
+recur2 maps@(pairFreq, cFreq, rules) n
+  | n == 0 = cFreq
+  | otherwise =
+    let pairs = M.keys pairFreq
+        (pairFreq', cFreq') =
+          L.foldl'
+            ( \(accPairFreq, accCFreq) pair@(a, b) ->
+                let c = rules ! pair
+                    totalPairFreq = pairFreq ! pair
+                    pairFreq' =
+                      accPairFreq
+                        $> M.insertWith (+) (a, c) totalPairFreq
+                        .> M.insertWith (+) (c, b) totalPairFreq
+                        .> M.adjust (\v -> v - totalPairFreq) pair
+                    cFreq' = M.insertWith (+) c totalPairFreq accCFreq
+                 in (pairFreq', cFreq')
+            )
+            (pairFreq, cFreq)
+            pairs
+     in recur2 (pairFreq', cFreq', rules) (n - 1)
+
+e2 initial rules =
+  let pairs = zip initial (tail initial)
+      pairFreqMap = L.foldl' (\acc p -> M.insertWith (+) p 1 acc) M.empty pairs
+      cFreqMap = L.foldl' (\acc c -> M.insertWith (+) c 1 acc) M.empty initial
+      resultCFreqMap = recur2 (pairFreqMap, cFreqMap, rules) 40
+      mcN = L.maximum (M.elems resultCFreqMap)
+      lcN = L.minimum (M.elems resultCFreqMap)
+   in mcN - lcN
+
+main :: IO ()
+main =
+  do
+    contents <- getContents
+
+    let input = contents $> lines
+    let initial = head input
+    let rules' =
+          tail (tail input)
+            $> map (pack .> replace (pack " -> ") (pack "") .> unpack)
+            .> map (\[x, y, z] -> ((x, y), z))
+
+    let rules = M.fromList rules'
+    e1 initial rules $> print
+    e2 initial rules $> print
diff --git a/day14/test.txt b/day14/test.txt
new file mode 100644
index 0000000..b5594dd
--- /dev/null
+++ b/day14/test.txt
@@ -0,0 +1,18 @@
+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
diff --git a/utils.hs b/utils.hs
index ee89ea1..9fcc553 100644
--- a/utils.hs
+++ b/utils.hs
@@ -37,3 +37,6 @@ splitToPair f lst =
   let x' = takeWhile (not . f) lst
       y' = dropWhile (not . f) lst $> drop 1
    in (x', y')
+
+count :: (a -> Bool) -> [a] -> Int
+count pred xs = xs $> filter pred .> length
\ No newline at end of file