Day 9

src/Days/D09.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+
+module Days.D09 where
+
+import Common
+import Data.Functor ((<&>))
+
+import Control.Monad (foldM_)
+import Control.Monad.ST (runST)
+import Data.HashTable.ST.Basic qualified as HT
+import Data.Hashable (Hashable (..))
+import Data.List (mapAccumL)
+import Data.Set qualified as Set
+import Data.Tuple (swap)
+import Data.Tuple.Extra (dupe)
+import Parse
+import Text.Megaparsec (oneOf)
+import Text.Megaparsec.Char (space)
+
+data Direction = U | D | L | R deriving (Read, Eq)
+data Move = Move {direction :: Direction, distance :: Int}
+type Intermediate = [Move]
+data V2 = V2 !Int !Int deriving (Eq, Ord)
+type Rope = [V2]
+
+instance Num V2 where
+  (+) (V2 a b) (V2 c d) = V2 (a + c) (b + d)
+  (*) = undefined
+  abs (V2 a b) = V2 (abs a) (abs b)
+  signum (V2 a b) = V2 (signum a) (signum b)
+  fromInteger = undefined
+  negate (V2 a b) = V2 (negate a) (negate b)
+
+instance Hashable V2 where
+  hashWithSalt salt (V2 x y) = 999119999 * x + y + salt
+
+parser :: Parser Intermediate
+parser = someLines move
+ where
+  move = Move <$> direction <* space <*> number
+
+  direction :: Parser Direction
+  direction =
+    oneOf "UDLR" <&> \case
+      'U' -> U
+      'D' -> D
+      'L' -> L
+      'R' -> R
+
+unit :: Direction -> V2
+unit R = V2 1 0
+unit L = V2 (-1) 0
+unit U = V2 0 1
+unit D = V2 0 (-1)
+
+dist :: V2 -> V2 -> Int
+dist x y =
+  let V2 x' y' = abs (x - y)
+   in max x' y'
+
+type State = (V2, V2)
+
+step :: State -> Direction -> State
+step (h, t) direction =
+  let newHead = h + unit direction
+   in (newHead, if doMove newHead t then h else t)
+ where
+  doMove :: V2 -> V2 -> Bool
+  doMove a b =
+    let (V2 x y) = abs (b - a)
+     in x > 1 || y > 1
+
+trace :: Move -> [V2]
+trace (Move{..}) = replicate distance (unit direction)
+
+headTrace :: [Move] -> [V2]
+headTrace = tail . scanl (+) (V2 0 0) . concatMap trace
+
+moveRope :: V2 -> Rope -> (V2, Rope)
+moveRope = mapAccumL go
+ where
+  go :: V2 -> V2 -> (V2, V2)
+  go prev next =
+    let newNext = follow prev next
+     in dupe newNext
+
+  follow prev next =
+    let d = dist prev next
+     in if d < 2 then next else next + signum (prev - next)
+
+initial :: Int -> Rope
+initial len = replicate len (V2 0 0)
+
+uniquesHint :: (Hashable a) => Int -> [a] -> Int
+uniquesHint hint items = runST $ do
+  m <- HT.newSized hint
+  foldM_ (\_ item -> HT.insert m item ()) () items
+  HT.size m
+
+simulate :: Int -> [Move] -> Int
+simulate n = Set.size . Set.fromList . tailTrace
+ where
+  tailTrace :: [Move] -> [V2]
+  tailTrace = snd . mapAccumL ((swap .) . flip moveRope) (initial n) . headTrace
+
+day :: Day
+day = parsecDay parser (definitive . simulate 2, definitive . simulate 9)

src/Lib.hs

@@ -19,6 +19,7 @@ import Days.D05 qualified as D05
 import Days.D06 qualified as D06
 import Days.D07 qualified as D07
 import Days.D08 qualified as D08
+import Days.D09 qualified as D09
 
 import Data.ByteString.Char8 qualified as BS
 import Data.Text.IO qualified as T
@@ -39,4 +40,5 @@ days =
     , [D06.day]
     , [D07.day]
     , [D08.day]
+    , [D09.day]
     ]