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

Abused ParserCombinators for the first part. For the second, I took quite a while to figure out dynamic programming in Haskell.

module Day12 where

import Data.Array
import Data.Char (isDigit)
import Data.List ((!!))
import Relude hiding (get, many)
import Relude.Unsafe (read)
import Text.ParserCombinators.ReadP

type Spring = (String, [Int])

type Problem = [Spring]

parseStatus :: ReadP Char
parseStatus = choice $ char <$> ".#?"

parseSpring :: ReadP Spring
parseSpring = do
  status <- many1 parseStatus <* char ' '
  listFailed <- (read <$> munch1 isDigit) `sepBy` char ','
  return (status, listFailed)

parseProblem :: ReadP Problem
parseProblem = parseSpring `sepBy` char '\n'

parse :: ByteString -> Maybe Problem
parse = fmap fst . viaNonEmpty last . readP_to_S parseProblem . decodeUtf8

good :: ReadP ()
good = choice [char '.', char '?'] $> ()

bad :: ReadP ()
bad = choice [char '#', char '?'] $> ()

buildParser :: [Int] -> ReadP ()
buildParser l = do
  _ <- many good
  sequenceA_ $ intersperse (many1 good) [count x bad | x <- l]
  _ <- many good <* eof

  return ()

combinations :: Spring -> Int
combinations (s, l) = length $ readP_to_S (buildParser l) s

part1, part2 :: Problem -> Int
part1 = sum . fmap combinations
part2 = sum . fmap (combinations' . toSpring' . bimap (join . intersperse "?" . replicate 5) (join . replicate 5))

run1, run2 :: FilePath -> IO Int
run1 f = readFileBS f >>= maybe (fail "parse error") (return . part1) . parse
run2 f = readFileBS f >>= maybe (fail "parse error") (return . part2) . parse

data Status = Good | Bad | Unknown deriving (Eq, Show)

type Spring' = ([Status], [Int])

type Problem' = [Spring']

toSpring' :: Spring -> Spring'
toSpring' (s, l) = (fmap toStatus s, l)
  where
    toStatus :: Char -> Status
    toStatus '.' = Good
    toStatus '#' = Bad
    toStatus '?' = Unknown
    toStatus _ = error "impossible"

isGood, isBad :: Status -> Bool
isGood Bad = False
isGood _ = True
isBad Good = False
isBad _ = True

combinations' :: Spring' -> Int
combinations' (s, l) = t ! (0, 0)
  where
    n = length s
    m = length l

    t = listArray ((0, 0), (n, m)) [f i j | i <- [0 .. n], j <- [0 .. m]]

    f :: Int -> Int -> Int
    f n' m'
      | n' >= n = if m' >= m then 1 else 0
      | v == Unknown = tGood + tBad
      | v == Good = tGood
      | v == Bad = tBad
      | otherwise = error "impossible"
      where
        v = s !! n'
        x = l !! m'

        ss = drop n' s

        (bads, rest) = splitAt x ss
        badsDelimited = maybe True isGood (viaNonEmpty head rest)
        off = if null rest then 0 else 1

        tGood = t ! (n' + 1, m')

        tBad =
          if m' + 1 <= m && length bads == x && all isBad bads && badsDelimited
            then t ! (n' + x + off, m' + 1)
            else 0