Day13.hs

-- |
-- Module      : AOC2018.Day13
-- Copyright   : (c) Justin Le 2018
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- Day 13.  See "AOC.Solver" for the types used in this module!
module AOC2018.Day13 (
  day13a,
  day13b,
) where

import AOC.Common.Point (Point, ScanPoint (..), parseAsciiMap)
import AOC.Solver ((:~>) (..))
import Control.Lens (makeLenses, over, (^.))
import Data.Bifunctor (second)
import Data.Functor.Foldable (hylo)
import Data.Map (Map)
import qualified Data.Map as M
import Linear (V2 (..))

data Turn
  = -- | a forward-slash mirror @/@
    TurnNW
  | -- | a backwards-slash mirror @\\@
    TurnNE
  | -- | a four-way intersection
    TurnInter
  deriving stock (Eq, Show, Ord)

data Dir = DN | DE | DS | DW
  deriving stock (Eq, Show, Ord, Enum, Bounded)

data Cart = C
  { _cDir :: Dir
  , _cTurns :: Int
  }
  deriving stock (Eq, Show)

makeLenses ''Cart

type World = Map Point Turn
type Carts = Map ScanPoint Cart

-- | Step a single cart through the world.
stepCart :: World -> ScanPoint -> Cart -> (ScanPoint, Cart)
stepCart w (SP p) c = (SP p', maybe id turner (M.lookup p' w) c)
  where
    p' =
      p + case c ^. cDir of
        DN -> V2 0 (-1)
        DE -> V2 1 0
        DS -> V2 0 1
        DW -> V2 (-1) 0
    turner = \case
      TurnNW -> over cDir $ \case DN -> DE; DE -> DN; DS -> DW; DW -> DS
      TurnNE -> over cDir $ \case DN -> DW; DW -> DN; DS -> DE; DE -> DS
      TurnInter -> over cTurns (+ 1) . over cDir (turnWith (c ^. cTurns))
    turnWith i = case i `mod` 3 of
      0 -> turnLeft
      1 -> id
      _ -> turnLeft . turnLeft . turnLeft
    turnLeft DN = DW
    turnLeft DE = DN
    turnLeft DS = DE
    turnLeft DW = DS

-- | One of the ways a single step of the simulation can go.
data CartLog a
  = -- | A crash, at a given point
    CLCrash Point a
  | -- | No crashes, just a normal timestep
    CLTick a
  | -- | Only one car left, at a given point
    CLDone Point
  deriving stock (Show, Functor)

-- | Given a (waiting, done) queue, emit a 'CartLog' event with an updated
-- (waiting, done) queue.
stepCarts ::
  World ->
  (Carts, Carts) ->
  CartLog (Carts, Carts)
stepCarts w (waiting, done) = case M.minViewWithKey waiting of
  Nothing -> case M.minViewWithKey done of
    Just ((SP lastPos, _), M.null -> True) -> CLDone lastPos
    _ -> CLTick (done, M.empty)
  Just (uncurry (stepCart w) -> (p, c), waiting') ->
    case M.lookup p (waiting' <> done) of
      Nothing -> CLTick (waiting', M.insert p c done)
      Just _ -> CLCrash (_getSP p) (M.delete p waiting', M.delete p done)

-- | Given a folding function, simulate on events emitted by 'stepCarts'.
simulateWith ::
  (CartLog a -> a) ->
  World ->
  Carts ->
  a
simulateWith f w c = (f `hylo` stepCarts w) (c, M.empty)

day13a :: (World, Carts) :~> Point
day13a =
  MkSol
    { sParse = Just . parseWorld
    , sShow = \(V2 x y) -> show x ++ "," ++ show y
    , sSolve = uncurry (simulateWith firstCrash)
    }
  where
    firstCrash (CLCrash p _) = Just p
    firstCrash (CLTick p) = p
    firstCrash (CLDone _) = Nothing

day13b :: (World, Carts) :~> Point
day13b =
  MkSol
    { sParse = Just . parseWorld
    , sShow = \(V2 x y) -> show x ++ "," ++ show y
    , sSolve = Just . uncurry (simulateWith lastPoint)
    }
  where
    lastPoint (CLCrash _ p) = p
    lastPoint (CLTick p) = p
    lastPoint (CLDone p) = p

parseWorld :: String -> (World, Carts)
parseWorld =
  second (M.mapKeys SP)
    . M.mapEither (second (`C` 0))
    . parseAsciiMap go
  where
    go = \case
      '/' -> Just . Left $ TurnNW
      '\\' -> Just . Left $ TurnNE
      '+' -> Just . Left $ TurnInter
      'v' -> Just . Right $ DS
      '^' -> Just . Right $ DN
      '>' -> Just . Right $ DE
      '<' -> Just . Right $ DW
      _ -> Nothing