AOC Day 5

quests/AOC/year2024/quest05-1

@@ -0,0 +1,28 @@
+47|53
+97|13
+97|61
+97|47
+75|29
+61|13
+75|53
+29|13
+97|29
+53|29
+61|53
+97|53
+61|29
+47|13
+75|47
+97|75
+47|61
+75|61
+47|29
+75|13
+53|13
+
+75,47,61,53,29
+97,61,53,29,13
+75,29,13
+75,97,47,61,53
+61,13,29
+97,13,75,29,47

src/AOC/Year2024/Quest05.purs

@@ -0,0 +1,93 @@
+module AOC.Year2024.Quest05 where
+
+import PCC.Lib
+
+import Control.Applicative (pure)
+import Control.Bind (bind)
+import Data.Array ((!!))
+import Data.Array as Array
+import Data.BooleanAlgebra (not, (&&))
+import Data.CommutativeRing ((+))
+import Data.EuclideanRing ((-), (/))
+import Data.Foldable (sum)
+import Data.Function (flip, ($), (<<<))
+import Data.Functor ((<$>))
+import Data.Map (Map)
+import Data.Map as Map
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.Ord (clamp)
+import Data.Semigroup ((<>))
+import Data.Set (Set)
+import Data.Set as Set
+import Data.Show (show)
+import Data.String (Pattern(..))
+import Data.String as String
+import Data.String.Utils (lines)
+import Data.Unit (Unit)
+import Effect (Effect)
+import Effect.Class.Console (log)
+
+--------------------------------------------------------------------------------
+-- Write your solutions here
+
+part1 :: String -> Effect Unit
+part1 input = do
+  let {left: ruleStr, right: updateStr} = fromMaybe {left: "", right: ""} $ splitFirst (Pattern "\n\n") input
+  let rules = compileRules $ Array.catMaybes $ splitFirst (Pattern "|") <$> lines ruleStr
+  let updates = Array.mapMaybe parseInt10 <$> String.split (Pattern ",") <$> lines updateStr
+  let result = sum $ middle <$> Array.filter (valid rules) updates
+  log $ "Part 1 ==> " <> show result
+
+part2 :: String -> Effect Unit
+part2 input = do
+  let {left: ruleStr, right: updateStr} = fromMaybe {left: "", right: ""} $ splitFirst (Pattern "\n\n") input
+  let rules = compileRules $ Array.catMaybes $ splitFirst (Pattern "|") <$> lines ruleStr
+  let updates = Array.mapMaybe parseInt10 <$> String.split (Pattern ",") <$> lines updateStr
+  let result = sum $ (middle <<< fixOrder rules) <$> Array.filter (not $ valid rules) updates
+  log $ "Part 2 ==> " <> show result
+
+--------------------------------------------------------------------------------
+
+type Rules = {beforeMap :: Map Int (Set Int), afterMap :: Map Int (Set Int)}
+type Rule = {left :: String, right :: String}
+
+compileRules :: Array Rule -> Rules
+compileRules = Array.foldl compileRulesStep {beforeMap: Map.empty, afterMap: Map.empty}
+  where
+  compileRulesStep :: Rules -> Rule -> Rules
+  compileRulesStep {beforeMap: bm, afterMap: am} {left, right} = fromMaybe {beforeMap: bm, afterMap: am} do
+    leftInt <- parseInt10 left
+    rightInt <- parseInt10 right
+    let beforeMap = Map.alter (setInsert rightInt) leftInt bm
+    let afterMap = Map.alter (setInsert leftInt) rightInt am
+    pure {beforeMap, afterMap}
+  setInsert v = Just <<< maybe (Set.singleton v) (Set.insert v)
+
+middle :: Array Int -> Int
+middle arr = fromMaybe 0 $ arr !! (Array.length arr / 2)
+
+valid :: Rules -> Array Int -> Boolean
+valid rules arr = case Array.uncons arr of
+  Nothing -> true
+  Just {head, tail} -> 
+    (Set.subset (Set.fromFoldable tail) $ fromMaybe (Set.empty) (Map.lookup head rules.beforeMap))
+    && (valid rules tail)
+
+fixOrder :: Rules -> Array Int -> Array Int
+fixOrder rules arr = Array.foldl go [] arr
+  where
+  findIndex order a mp = do
+    set <- Map.lookup a mp
+    Array.findIndex (flip Set.member set) order
+  go order a = do
+    let beforeIndex = findIndex order a rules.beforeMap
+    let afterIndex = findIndex order a rules.afterMap
+    fromMaybe order do
+       let idx = clamp 0 (Array.length order) (locationBetween beforeIndex afterIndex)
+       Array.insertAt idx a order
+
+locationBetween :: Maybe Int -> Maybe Int -> Int
+locationBetween _ (Just after) = after + 1
+locationBetween (Just before) _ = before - 1
+locationBetween Nothing Nothing = 0
+