101 lines
4.4 KiB
Haskell
101 lines
4.4 KiB
Haskell
{-# 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 |