Day 17 was a lot of fiddly detail, so I decided to use a new-to-me Haskell feature, pattern synonyms, to help out. They made the fiddly bits slightly less fiddly.

Data structures

This follows a similar pattern to other grid-based puzzles. Each type of thing in the map is an Element and the grid is an Array of Elements. The head of a beam of light is characterised by both its position and direction. The set of energised cells needs to know both the location and direction of the beam, as beams can cross each other without interference.

data Element = 
  Empty | SlashMirror | BackslashMirror | 
  HorizontalSplitter | VerticalSplitter
  deriving (Show, Eq, Enum)

type Position = V2 Int -- r, c
type Grid = Array Position Element

data BeamHead = BeamHead { beamPos :: Position, beamDirection :: Position } 
  deriving (Show, Eq, Ord)

type Energised = S.Set BeamHead

This is where the pattern synonyms came in. There's lot of fiddling around with directions, and changes of direction, and representing all that with different values of row and column changes, and it's all prone to silly mistakes. I can reduce the scope for mistakes with patterns for the four directions.

pattern U, D, L, R :: Position
pattern U = V2 (-1) 0
pattern D = V2 1 0
pattern L = V2 0 (-1)
pattern R = V2 0 1

These patterns are bidirectional, so they can be used in pattern matching and as the parameters of functions. Essentially, every time the compiler sees a D, it replaces it with V2 1 0. These patterns get used throughout the code that propagates a beam.

Reading a grid is walking over the data and converting the characters to Elements.

mkGrid :: String -> Grid
mkGrid text = grid
  where rows = lines text
        r = length rows - 1
        c = (length $ head rows) - 1
        grid = listArray ((V2 0 0), (V2 r c)) $ fmap readElement $ concat rows

readElement :: Char -> Element
readElement '/' = SlashMirror
readElement '\\' = BackslashMirror
readElement '|' = VerticalSplitter
readElement '-' = HorizontalSplitter
readElement _ = Empty

Propagation

There can be several beams travelling through the grid. Mirrors change direction, splitters may add an extra beam. Beams are removed when they move outside the bounds of the grid or a beam starts following an prior beam (indicating a loop). propagate handles a list of beams, and propagateElem handles one beam interacting with one Element.

propagate maintains a list of active beams. It takes the first beam, works out where it could go, and ensures those new locations are in bounds. If the first beam moves into a loop, it's just discarded. It returns the set of energised locations.

propagate :: Grid -> Energised -> [BeamHead] -> Energised
propagate _ energised [] = energised
propagate grid energised (bh:bhs) 
  | S.member bh energised = propagate grid energised bhs
  | otherwise = propagate grid energised' (bhs ++ nexts')
  where this = grid ! (beamPos bh)
        nexts = propagateElem this bh
        nexts' = filter ((inRange (bounds grid)) . beamPos) nexts
        energised' = S.insert bh energised

propagateElem handles all the element logic, and this is where the pattern synonyms come in. They didn't stop me making silly mistakes, but they made those mistakes much easier to spot and correct!

propagateElem :: Element -> BeamHead -> [BeamHead]
propagateElem Empty (BeamHead pos dir) = [BeamHead (pos ^+^ dir) dir]
propagateElem SlashMirror (BeamHead pos L) = [BeamHead (pos ^+^ D) D]
propagateElem SlashMirror (BeamHead pos R) = [BeamHead (pos ^+^ U) U]
propagateElem SlashMirror (BeamHead pos U) = [BeamHead (pos ^+^ R) R]
propagateElem SlashMirror (BeamHead pos D) = [BeamHead (pos ^+^ L) L]
propagateElem BackslashMirror (BeamHead pos L) = [BeamHead (pos ^+^ U) U]
propagateElem BackslashMirror (BeamHead pos R) = [BeamHead (pos ^+^ D) D]
propagateElem BackslashMirror (BeamHead pos U) = [BeamHead (pos ^+^ L) L]
propagateElem BackslashMirror (BeamHead pos D) = [BeamHead (pos ^+^ R) R]
propagateElem HorizontalSplitter (BeamHead pos L) = [BeamHead (pos ^+^ L) L]
propagateElem HorizontalSplitter (BeamHead pos R) = [BeamHead (pos ^+^ R) R]
propagateElem HorizontalSplitter (BeamHead pos _) = 
  [BeamHead (pos ^+^ L) L, BeamHead (pos ^+^ R) R]
propagateElem VerticalSplitter (BeamHead pos U) = [BeamHead (pos ^+^ U) U]
propagateElem VerticalSplitter (BeamHead pos D) = [BeamHead (pos ^+^ D) D]
propagateElem VerticalSplitter (BeamHead pos _) = 
  [BeamHead (pos ^+^ U) U, BeamHead (pos ^+^ D) D]

This might be shorter if I used arithmetic on some of the cases, but it would certainly be less readable.

Solutions

Given that I can propagate a beam around a grid, I can count the number of energised cells.

countEnergised :: Grid -> BeamHead -> Int
countEnergised grid bh = S.size $ S.map beamPos $ propagate grid S.empty [bh]

For part 2, I need to find the possible start positions.

getEdges :: Grid -> [BeamHead]
getEdges grid = [BeamHead (V2 0 c) D | c <- [0..maxC]] ++
                [BeamHead (V2 r 0) R | r <- [0..maxR]] ++
                [BeamHead (V2 r maxC) L | r <- [0..maxR]] ++
                [BeamHead (V2 maxR c) U | c <- [0..maxC]]
  where (V2 maxR maxC) = snd $ bounds grid

That allows the problems to be solved.

part1, part2 :: Grid -> Int
part1 grid = countEnergised grid (BeamHead (V2 0 0) R)
part2 grid = maximum $ fmap (countEnergised grid) $ getEdges grid

Code

You can get the code from my locally-hosted Git repo, or from Gitlab.