Haskell
A bit of a mess, I probably shouldn’t have used RWS …
import Control.Monad.RWS
import Control.Parallel.Strategies
import Data.Array
import qualified Data.ByteString.Char8 as BS
import Data.Foldable (Foldable (maximum))
import Data.Set
import Relude
data Cell = Empty | VertSplitter | HorizSplitter | Slash | Backslash deriving (Show, Eq)
type Pos = (Int, Int)
type Grid = Array Pos Cell
data Direction = N | S | E | W deriving (Show, Eq, Ord)
data BeamHead = BeamHead
{ pos :: Pos,
dir :: Direction
}
deriving (Show, Eq, Ord)
type Simulation = RWS Grid (Set Pos) (Set BeamHead)
next :: BeamHead -> BeamHead
next (BeamHead p d) = BeamHead (next' d p) d
where
next' :: Direction -> Pos -> Pos
next' direction = case direction of
N -> first pred
S -> first succ
E -> second succ
W -> second pred
advance :: BeamHead -> Simulation [BeamHead]
advance bh@(BeamHead position direction) = do
grid <- ask
seen <- get
if inRange (bounds grid) position && bh `notMember` seen
then do
tell $ singleton position
modify $ insert bh
pure . fmap next $ case (grid ! position, direction) of
(Empty, _) -> [bh]
(VertSplitter, N) -> [bh]
(VertSplitter, S) -> [bh]
(HorizSplitter, E) -> [bh]
(HorizSplitter, W) -> [bh]
(VertSplitter, _) -> [bh {dir = N}, bh {dir = S}]
(HorizSplitter, _) -> [bh {dir = E}, bh {dir = W}]
(Slash, N) -> [bh {dir = E}]
(Slash, S) -> [bh {dir = W}]
(Slash, E) -> [bh {dir = N}]
(Slash, W) -> [bh {dir = S}]
(Backslash, N) -> [bh {dir = W}]
(Backslash, S) -> [bh {dir = E}]
(Backslash, E) -> [bh {dir = S}]
(Backslash, W) -> [bh {dir = N}]
else pure []
simulate :: [BeamHead] -> Simulation ()
simulate heads = do
heads' <- foldMapM advance heads
unless (Relude.null heads') $ simulate heads'
runSimulation :: BeamHead -> Grid -> Int
runSimulation origin g = size . snd . evalRWS (simulate [origin]) g $ mempty
part1, part2 :: Grid -> Int
part1 = runSimulation $ BeamHead (0, 0) E
part2 g = maximum $ parMap rpar (`runSimulation` g) possibleInitials
where
((y0, x0), (y1, x1)) = bounds g
possibleInitials =
join
[ [BeamHead (y0, x) S | x <- [x0 .. x1]],
[BeamHead (y1, x) N | x <- [x0 .. x1]],
[BeamHead (y, x0) E | y <- [y0 .. y1]],
[BeamHead (y, x1) W | y <- [y0 .. y1]]
]
parse :: ByteString -> Maybe Grid
parse input = do
let ls = BS.lines input
h = length ls
w <- BS.length <$> viaNonEmpty head ls
mat <- traverse toCell . BS.unpack $ BS.concat ls
pure $ listArray ((0, 0), (h - 1, w - 1)) mat
where
toCell '.' = Just Empty
toCell '|' = Just VertSplitter
toCell '-' = Just HorizSplitter
toCell '/' = Just Slash
toCell '\\' = Just Backslash
toCell _ = Nothing
Haskell
import Data.Array.Unboxed import qualified Data.ByteString.Char8 as BS import Data.Char (digitToInt) import Data.Heap hiding (filter) import qualified Data.Heap as H import Relude type Pos = (Int, Int) type Grid = UArray Pos Int data Dir = U | D | L | R deriving (Eq, Ord, Show, Enum, Bounded, Ix) parse :: ByteString -> Maybe Grid parse input = do let l = fmap (fmap digitToInt . BS.unpack) . BS.lines $ input h = length l w <- fmap length . viaNonEmpty head $ l pure . listArray ((0, 0), (w - 1, h - 1)) . concat $ l move :: Dir -> Pos -> Pos move U = first pred move D = first succ move L = second pred move R = second succ nextDir :: Dir -> [Dir] nextDir U = [L, R] nextDir D = [L, R] nextDir L = [U, D] nextDir R = [U, D] -- position, previous direction, accumulated loss type S = (Int, Pos, Dir) doMove :: Grid -> Dir -> S -> Maybe S doMove g d (c, p, _) = do let p' = move d p guard $ inRange (bounds g) p' pure (c + g ! p', p', d) doMoveN :: Grid -> Dir -> Int -> S -> Maybe S doMoveN g d n = foldl' (>=>) pure . replicate n $ doMove g d doMoves :: Grid -> [Int] -> S -> Dir -> [S] doMoves g r s d = mapMaybe (flip (doMoveN g d) s) r allMoves :: Grid -> [Int] -> S -> [S] allMoves g r s@(_, _, prev) = nextDir prev >>= doMoves g r s solve' :: Grid -> [Int] -> UArray (Pos, Dir) Int -> Pos -> MinHeap S -> Maybe Int solve' g r distances target h = do ((acc, pos, dir), h') <- H.view h if pos == target then pure acc else do let moves = allMoves g r (acc, pos, dir) moves' = filter (\(acc, p, d) -> acc < distances ! (p, d)) moves distances' = distances // fmap (\(acc, p, d) -> ((p, d), acc)) moves' h'' = foldl' (flip H.insert) h' moves' solve' g r distances' target h'' solve :: Grid -> [Int] -> Maybe Int solve g r = solve' g r (emptyGrid ((lo, minBound), (hi, maxBound))) hi (H.singleton (0, (0, 0), U)) where (lo, hi) = bounds g emptyGrid = flip listArray (repeat maxBound) part1, part2 :: Grid -> Maybe Int part1 = (`solve` [1 .. 3]) part2 = (`solve` [4 .. 10])