Day24.hs

{-|
Module:         Day24
Description:    <https://adventofcode.com/2022/day/24 Day 24: Blizzard Basin>
-}
{-# LANGUAGE NondecreasingIndentation, ViewPatterns #-}
module Day24 (day24a, day24b) where

import qualified Data.Heap as Heap (FstMinPolicy, insert, singleton, view)
import Data.List (foldl')
import qualified Data.Set as Set (insert, notMember, singleton)
import Data.Text (Text)
import qualified Data.Text as T (index, length, lines)
import Data.Tuple (swap)
import Data.Vector (Vector)
import qualified Data.Vector as V ((!), fromList, last, length)

search :: Vector Text -> (Int, Int) -> (Int, Int) -> Int -> Maybe Int
search lines start end@(endX, endY) startTime = go (Set.singleton (start, startTime)) $
    Heap.singleton @Heap.FstMinPolicy (0, (start, startTime)) where
    isFree (x, y) time
      | y < 0 || y >= V.length lines || x < 1 || x > T.length line - 2 = False
      | y == 0 || y == V.length lines - 1 = T.index line x == '.'
      | T.index line ((x - 1 + time) `mod` (T.length line - 2) + 1) == '<' = False
      | T.index line ((x - 1 - time) `mod` (T.length line - 2) + 1) == '>' = False
      | T.index (lines V.! ((y - 1 + time) `mod` (V.length lines - 2) + 1)) x == '^' = False
      | T.index (lines V.! ((y - 1 - time) `mod` (V.length lines - 2) + 1)) x == 'v' = False
      | otherwise = True
      where line = lines V.! y
    go seen (Heap.view -> Just ((_, (pos@(x, y), time)), heap))
      | pos == end = Just time
      | otherwise = go seen' heap' where
        choices = filter (\state@(pos, time) -> isFree pos time && Set.notMember state seen) $
            (, time + 1) <$> [(x - 1, y), (x, y - 1), (x, y), (x, y + 1), (x + 1, y)]
        seen' = foldl' (flip Set.insert) seen choices
        heap' = foldl' (flip Heap.insert) heap
            [(time + abs (x - endX) + abs (y - endY), choice) | choice@((x, y), time) <- choices]
    go _ _ = Nothing

day24a :: Text -> Maybe Int
day24a input = search lines (1, 0) (T.length (V.last lines) - 2, V.length lines - 1) 0 where
    lines = V.fromList $ T.lines input

day24b :: Text -> Maybe Int
day24b input = search lines start end 0 >>= search lines end start >>= search lines start end where
    lines = V.fromList $ T.lines input
    start = (1, 0)
    end = (T.length (V.last lines) - 2, V.length lines - 1)