Pasted

{-# language RecordWildCards #-}
 
import Control.Arrow ((&&&))
import Data.List (foldl')
import Data.Maybe (listToMaybe)
 
data Action = North | South | East | West | TurnLeft | TurnRight | Forward deriving (Eq, Show)
 
data Instruction = MkInstruction { action :: Action, value :: Int } deriving (Eq, Show)
 
parseLine :: String -> Maybe Instruction
parseLine [] = Nothing
parseLine (d:n) = MkInstruction <$> charAction d <*> fmap fst (listToMaybe $ reads n)
 
charAction :: Char -> Maybe Action
charAction 'N' = pure North
charAction 'S' = pure South
charAction 'E' = pure East
charAction 'W' = pure West
charAction 'L' = pure TurnLeft
charAction 'R' = pure TurnRight
charAction 'F' = pure Forward
charAction _ = Nothing
 
data Ship =
  MkShip
  { xPos :: Int
  , yPos :: Int
  , xDir :: Int
  , yDir :: Int
  } deriving (Eq, Show)
 
initShip :: Ship
initShip = MkShip{ xPos = 0, yPos = 0, xDir = 1, yDir = 0 }
 
applyShipInstruction :: Instruction -> Ship -> Ship
applyShipInstruction MkInstruction{ action = North, value = delta } s = s{ yPos = yPos s + delta }
applyShipInstruction MkInstruction{ action = South, value = delta } s = s{ yPos = yPos s - delta }
applyShipInstruction MkInstruction{ action = East, value = delta } s = s{ xPos = xPos s + delta }
applyShipInstruction MkInstruction{ action = West, value = delta } s = s{ xPos = xPos s - delta }
applyShipInstruction MkInstruction{ action = TurnLeft, value = degrees } s =
  foldr ($) s $ replicate (degrees `quot` 90) oneLeft
 where oneLeft ss = ss{ xDir = negate $ yDir ss, yDir = xDir ss }
applyShipInstruction MkInstruction{ action = TurnRight, value = degrees } s =
  foldr ($) s $ replicate (degrees `quot` 90) oneRight
 where oneRight ss = ss{ xDir = yDir ss, yDir = negate $ xDir ss }
applyShipInstruction MkInstruction{ action = Forward, value = scale } s =
  s{ xPos = xPos s + scale * xDir s, yPos = yPos s + scale * yDir s }
 
shipManhattan :: Ship -> Int
shipManhattan MkShip{..} = abs xPos + abs yPos
 
part1 :: [Instruction] -> Int
part1 = shipManhattan . foldl' (flip applyShipInstruction) initShip
 
initWaypoint :: Waypoint
initWaypoint = MkWaypoint { xWay = 10, yWay = 1 }
 
data Waypoint = MkWaypoint { xWay :: Int, yWay :: Int } deriving (Eq, Show)
 
applyWaypointedInstruction :: Instruction -> (Ship, Waypoint) -> (Ship, Waypoint)
applyWaypointedInstruction MkInstruction{ action = North, value = delta } (s, w) =
  (s, w{ yWay = yWay w + delta })
applyWaypointedInstruction MkInstruction{ action = South, value = delta } (s, w) =
  (s, w{ yWay = yWay w - delta })
applyWaypointedInstruction MkInstruction{ action = East, value = delta } (s, w) =
  (s, w{ xWay = xWay w + delta })
applyWaypointedInstruction MkInstruction{ action = West, value = delta } (s, w) =
  (s, w{ xWay = xWay w - delta })
applyWaypointedInstruction MkInstruction{ action = TurnLeft, value = degrees } (s, w) =
  (s, foldr ($) w $ replicate (degrees `quot` 90) oneLeft)
 where oneLeft ww = ww{ xWay = negate $ yWay ww, yWay = xWay ww }
applyWaypointedInstruction MkInstruction{ action = TurnRight, value = degrees } (s, w) =
  (s, foldr ($) w $ replicate (degrees `quot` 90) oneRight)
 where oneRight ww = ww{ xWay = yWay ww, yWay = negate $ xWay ww }
applyWaypointedInstruction MkInstruction{ action = Forward, value = scale } (s, w) =
  (s{ xPos = xPos s + scale * xWay w, yPos = yPos s + scale * yWay w}, w)
 
part2 :: [Instruction] -> Int
part2 = shipManhattan . fst . foldl' (flip applyWaypointedInstruction) (initShip, initWaypoint)
 
interactive :: Show a => (String -> a) -> IO ()
interactive f = getContents >>= print . f
 
main :: IO ()
main = interactive (fmap (part1 &&& part2) . traverse parseLine . lines)