Day24.hs

module Javran.AdventOfCode.Y2022.Day24 (

) where

import Control.Monad
import Data.Function
import Data.Ix
import qualified Data.Map.Strict as M
import qualified Data.PSQueue as PQ
import Data.Semigroup
import qualified Data.Vector.Unboxed as VU
import Data.Word
import Javran.AdventOfCode.GridSystem.RowThenCol.Uldr
import Javran.AdventOfCode.Prelude
import Text.ParserCombinators.ReadP hiding (count, get, many)

data Day24 deriving (Generic)

{-
  Cell representations, using Word8 to allow unboxed representation.

  - Use Enum of Dirs, but `+ 0b1000` so we don't assign 0 to mean a non-empty cell.
  - maxBound for walls.

 -}
bU, bD, bL, bR :: Word8
[bU, bD, bL, bR] = fmap (fromIntegral . (+ 0b1000) . fromEnum) [U, D, L, R]

{-
  Input parser.

  Slightly in favor of strict parsing, so that start and goal location
  can be easily determined.

  Returns dimensions (rows, cols), in which `rows` and `cols` only count
  spaces surrounded by walls, which are mapped to ((0,0), (rows-1, cols-1)).

  Start location is (-1,0) and goal location (row, cols-1) are therefore
  considered "out-of-bound" for the vector container.

 -}
valleyP :: ReadP (VU.Vector Word8, (Int, Int))
valleyP = do
  let cellP =
        (0 <$ charP '.')
          <++ (bU <$ charP '^')
          <++ (bD <$ charP 'v')
          <++ (bL <$ charP '<')
          <++ (bR <$ charP '>')
  cols <- length <$> (strP "#." *> munch1 (== '#') <* charP '\n')

  fix
    ( \go k rows -> do
        let finalLineP = do
              replicateM (cols - 1) (charP '#') *> strP ".#"
              pure (VU.fromList $ concat $ k [], (rows, cols))
            valleyLineP = do
              xs <- replicateM cols cellP <* strP "#\n"
              go (k . (xs :)) (rows + 1)
        charP '#' *> (finalLineP <++ valleyLineP)
    )
    id
    (0 :: Int)

aStar ::
  Int ->
  (Int -> Coord -> Bool) ->
  Coord ->
  PQ.PSQ (Coord, Int) (Arg Int Int) ->
  M.Map (Coord, Int) Int ->
  Int
aStar common canAccess goal = fix \go q0 dists -> case PQ.minView q0 of
  Nothing -> error "queue exhausted"
  Just ((cur, _) PQ.:-> (Arg _fScore distU), q1) ->
    if cur == goal
      then distU
      else
        let nexts = do
              {-
                Normally we would put `cur` (i.e. waiting) as the last candidate to try.
                Because intuitive moving in some directions could be better than just waiting.
                But since we are using priority queue, the order doesn't really matter,
                so prefer faster list generation.
               -}
              next <- cur : fmap (\d -> applyDir d cur) allDirs
              let mDistV = dists M.!? (next, rem distV' common)
                  distV' = distU + 1
                  fScore' = distV' + manhattan next goal
              guard $ canAccess distV' next && maybe True (distV' <) mDistV
              pure ((next, distV'), distV', Arg fScore' distV')
            q2 = foldr upd q1 nexts
              where
                upd (v, _, prio') = PQ.insert v prio'
            dists' = foldr upd dists nexts
              where
                upd ((next, t'), distV', _) = M.insert (next, rem t' common) distV'
         in go q2 dists'

_pprValley :: (Int, Int) -> (Int -> Coord -> [Word8]) -> Int -> IO ()
_pprValley dims unsafeGetBlizzard t = do
  let (rows, cols) = dims
      bounds = ((0, 0), (rows - 1, cols - 1))
      start = (-1, 0)
      goal = (rows, cols - 1)
      getBliz coord
        | coord == start || coord == goal = []
        | otherwise = unsafeGetBlizzard t coord
      renderCell v
        | v == bU = '^'
        | v == bD = 'v'
        | v == bL = '<'
        | v == bR = '>'
        | v == 0 = '.'
        | v == maxBound = '#'
        | otherwise = unreachable

  forM_ [-1 .. rows] \r -> do
    let render c
          | coord == start || coord == goal = renderCell 0
          | not (inRange bounds coord) = renderCell maxBound
          | otherwise = case bs of
              [] -> '.'
              [v] -> renderCell v
              _ : _ -> head $ show (length bs)
          where
            coord = (r, c)
            bs = getBliz (r, c)
    putStrLn $ fmap render [-1 .. cols]
  putStrLn ""

instance Solution Day24 where
  solutionRun _ SolutionContext {getInputS, answerShow} = do
    (vs, dims) <- consumeOrDie (valleyP <* skipSpaces) <$> getInputS
    {-
      `unsafeXXX` below refers to the fact that it accesses the vector without checking bounds,
      accessing coordinates not inside of wall (which includes start and goal Coords) is undefined behavior.
     -}
    let (rows, cols) = dims
        bounds = ((0, 0), (rows - 1, cols - 1))
        start = (-1, 0)
        goal = (rows, cols - 1)
        unsafeGetCell = (vs VU.!) . index bounds
        unsafeGetBlizzard t (r, c) =
          -- assume coord is always in-bound (note: start and goal are outside)
          [bD | unsafeGetCell (rem (r + rows - rem t rows) rows, c) == bD]
            <> [bU | unsafeGetCell (rem (r + t) rows, c) == bU]
            <> [bL | unsafeGetCell (r, rem (c + rem t cols) cols) == bL]
            <> [bR | unsafeGetCell (r, rem (c + cols - rem t cols) cols) == bR]

    do
      let common =
            {-
              The blizzard pattern repeats itself eventually.
              This helps us cutting down search space, as we are only using current time as part of the state
              so that we can compute blizzard map that that specific time.
             -}
            lcm rows cols
          {-
            Note: already tried storing results of this in a lazy Bool vector,
            but it was a significant slowdown.
            Could try with unboxed Bool but I don't think we are making much difference focusing on this part.
           -}
          canAccess t coord =
            coord == start
              || coord == goal
              || ( inRange bounds coord
                    && vs VU.! index bounds coord /= maxBound
                    && null (unsafeGetBlizzard t coord)
                 )
          solve from to tBase =
            aStar
              common
              canAccess
              to
              (PQ.singleton s0 (Arg (manhattan start goal) tBase))
              (M.singleton s0 0)
            where
              s0 = (from, tBase)
          ans1 = solve start goal 0 -- start to goal, trip 1
          ans2 = solve goal start ans1 -- goal back to start, trip 2
          ans3 = solve start goal ans2 -- start to goal, trip 3

      {-
        I don't have a rigid proof that simply running this search 3 times guarantees
        the optimal solution, but it seems to be the case for the specific inputs that we have.
       -}
      answerShow ans1
      answerShow ans3