From 5fd2159be1d33c12b8a687b29270c5f0432b641f Mon Sep 17 00:00:00 2001 From: "Jill \"oatmealine\" Monoids" Date: Fri, 9 Dec 2022 13:43:49 +0300 Subject: [PATCH] day 9 --- 9-a.hs | 70 +++++++++++++++++++++++++++++++++++++++ 9-b.hs | 101 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 171 insertions(+) create mode 100644 9-a.hs create mode 100644 9-b.hs diff --git a/9-a.hs b/9-a.hs new file mode 100644 index 0000000..01052e0 --- /dev/null +++ b/9-a.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +import Prelude hiding (Left, Right) +import Data.List + +data Direction = Left | Down | Up | Right + deriving (Eq, Show) + +newtype Instruction = Instruction (Int, Direction) + deriving (Eq, Show) + +parseDirection "L" = Left +parseDirection "D" = Down +parseDirection "U" = Up +parseDirection "R" = Right + +directionToOffset :: Direction -> (Int, Int) +directionToOffset Left = (-1, 0) +directionToOffset Down = (0, -1) +directionToOffset Up = (0, 1) +directionToOffset Right = (1, 0) + +parseInstructions :: String -> [Instruction] +parseInstructions = map (Instruction . (\[d, n] -> (read n, parseDirection d)) . words) . lines + +unrollInstructions :: [Instruction] -> [Direction] +unrollInstructions = concatMap (\(Instruction (n, d)) -> replicate n d) + +taxicabDist :: (Int, Int) -> (Int, Int) -> Int +taxicabDist (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2) + +addPos :: (Int, Int) -> (Int, Int) -> (Int, Int) +addPos (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) + +run :: [Direction] -> [(Int, Int)] +run = (\(a, b, l) -> l) . foldl stepAccum ((0, 0), (0, 0), [(0, 0)]) + where stepAccum :: ((Int, Int), (Int, Int), [(Int, Int)]) -> Direction -> ((Int, Int), (Int, Int), [(Int, Int)]) + stepAccum (posHead, posTail, l) i = (newPosHead, newPosTail, if newPosTail `elem` l then l else newPosTail : l) + where (newPosHead, newPosTail) = step (posHead, posTail) i + + step :: ((Int, Int), (Int, Int)) -> Direction -> ((Int, Int), (Int, Int)) + step ((hX, hY), (tX, tY)) dir = ((hXNew, hYNew), (tXNew, tYNew)) + where (offsetX, offsetY) = directionToOffset dir + (hXNew, hYNew) = addPos (hX, hY) (offsetX, offsetY) + tailDistNew = (tX, tY) `taxicabDist` (hXNew, hYNew) + (tXNew, tYNew) + -- directly touching, no problem + | tailDistNew <= 1 = (tX, tY) + -- diagonally touching, no problem + | tailDistNew == 2 && (tX /= hXNew) && (tY /= hYNew) = (tX, tY) + -- horizontally offset, catch up + | hYNew == tY = (tX + offsetX, hYNew) + -- vertically offset, catch up + | hXNew == tX = (hXNew, tY + offsetY) + -- diagonally offset moving horizontally, vertically align and catch up + | offsetY == 0 = (tX + offsetX, hYNew) + -- diagonally offset moving vertically, horizontally align and catch up + | offsetX == 0 = (hXNew, tY + offsetY) + +-- for debugging +renderSeenMap :: [(Int, Int)] -> String +renderSeenMap positions = intercalate "\n" $ map (\y -> map (\x -> if (x, y) `elem` positions then '#' else '.') [0..maxX]) (reverse [0..maxY]) + where maxX = maximum $ map fst positions + maxY = maximum $ map snd positions + +main = interact $ + show + . length . run + . unrollInstructions . parseInstructions \ No newline at end of file diff --git a/9-b.hs b/9-b.hs new file mode 100644 index 0000000..4151a43 --- /dev/null +++ b/9-b.hs @@ -0,0 +1,101 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +import Prelude hiding (Left, Right) +import Data.List +import GHC.IO +import Control.DeepSeq + +knotN = 10 + +data Direction = Left | Down | Up | Right + deriving (Eq, Show) + +newtype Instruction = Instruction (Int, Direction) + deriving (Eq, Show) + +-- help +{-# NOINLINE debug #-} +debug :: Show a => a -> () +debug = unsafePerformIO . print + +trace :: Show b => b -> a -> a +trace s = deepseq (debug s) + +parseDirection "L" = Left +parseDirection "D" = Down +parseDirection "U" = Up +parseDirection "R" = Right + +directionToOffset :: Direction -> (Int, Int) +directionToOffset Left = (-1, 0) +directionToOffset Down = (0, -1) +directionToOffset Up = (0, 1) +directionToOffset Right = (1, 0) + +parseInstructions :: String -> [Instruction] +parseInstructions = map (Instruction . (\[d, n] -> (read n, parseDirection d)) . words) . lines + +unrollInstructions :: [Instruction] -> [Direction] +unrollInstructions = concatMap (\(Instruction (n, d)) -> replicate n d) + +taxicabDist :: (Int, Int) -> (Int, Int) -> Int +taxicabDist (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2) + +addPos :: (Int, Int) -> (Int, Int) -> (Int, Int) +addPos (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) + +subPos :: (Int, Int) -> (Int, Int) -> (Int, Int) +subPos (x1, y1) (x2, y2) = (x1 - x2, y1 - y2) + +run :: [Direction] -> [(Int, Int)] +run = snd . foldl stepAccum (replicate knotN (0, 0), [(0, 0)]) + where stepAccum :: ([(Int, Int)], [(Int, Int)]) -> Direction -> ([(Int, Int)], [(Int, Int)]) + stepAccum (knots, l) i = (newKnots, if lastKnot `elem` l then l else lastKnot : l) + where newKnots = step' knots i + lastKnot = last newKnots + + -- accounts for >2 knots + step' :: [(Int, Int)] -> Direction -> [(Int, Int)] + step' knots dir = map snd $ scanl foldStep (h, newHead) t + where h = head knots + t = tail knots + offset = directionToOffset dir + newHead = h `addPos` offset + foldStep (oldKnot, newKnot) thisKnot = (thisKnot, step (oldKnot, thisKnot) (newKnot `subPos` oldKnot)) + + step :: ((Int, Int), (Int, Int)) -> (Int, Int) -> (Int, Int) + step ((hX, hY), (tX, tY)) (offsetX, offsetY) = (tXNew, tYNew) + where (hXNew, hYNew) = (hX, hY) `addPos` (offsetX, offsetY) + tailDistNew = (tX, tY) `taxicabDist` (hXNew, hYNew) + (tXNew, tYNew) + -- directly touching, no problem + | tailDistNew <= 1 = (tX, tY) + -- diagonally touching, no problem + | tailDistNew == 2 && (tX /= hXNew) && (tY /= hYNew) = (tX, tY) + -- horizontally offset, catch up + | hYNew == tY = (tX + offsetX, hYNew) + -- vertically offset, catch up + | hXNew == tX = (hXNew, tY + offsetY) + -- diagonally offset moving horizontally, vertically align and catch up + | offsetY == 0 = (tX + offsetX, hYNew) + -- diagonally offset moving vertically, horizontally align and catch up + | offsetX == 0 = (hXNew, tY + offsetY) + -- diagonally offset moving diagonally but previous offset was horizontal, vertically align and recurse + | offsetX /= 0 && offsetY /= 0 && (hY - tY) == 0 = step ((hX, hY), (tX, hYNew)) (offsetX, offsetY) + -- diagonally offset moving diagonally but previous offset was vertical, horizontally align and recurse + | offsetX /= 0 && offsetY /= 0 && (hX - tX) == 0 = step ((hX, hY), (hXNew, tY)) (offsetX, offsetY) + -- diagonally offset moving diagonally by previous offset was diagonal, move in the same direction and recurse + | offsetX /= 0 && offsetY /= 0 && (hX - tX) /= 0 && (hY - tY) /= 0 = step ((hX, hY), (tX + offsetX, tY + offsetY)) (offsetX, offsetY) + | otherwise = error $ "wtf: offset x" ++ show offsetX ++ " y" ++ show offsetY ++ ", prev offset x" ++ show (hX - tX) ++ " y" ++ show (hY - tY) + +-- for debugging +renderSeenMap :: [(Int, Int)] -> String +renderSeenMap positions = intercalate "\n" $ map (\y -> map (\x -> if (x, y) `elem` positions then '#' else '.') [0..maxX]) (reverse [0..maxY]) + where maxX = maximum $ map fst positions + maxY = maximum $ map snd positions + +main = interact $ + show + . length . run + . unrollInstructions . parseInstructions \ No newline at end of file