-- |
-- Module      : AOC.Challenge.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 AOC.Challenge.Day13 (
    day13a
  , day13b
  ) where

import           AOC.Common            (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           Linear                (V2(..))
import qualified Data.Map              as M

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

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

data Cart = C { _cDir   :: Dir
              , _cTurns :: Int
              }
  deriving (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 = CLCrash Point a      -- ^ A crash, at a given point
               | CLTick        a      -- ^ No crashes, just a normal timestep
               | CLDone  Point        -- ^ Only one car left, at a given point
  deriving (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