2024 Day Six

DaySix.hs

module DaySix (partTwo, allInterestingWorlds) where

import Data.Maybe (catMaybes, listToMaybe, mapMaybe)
import qualified Data.Set as S
import Control.Parallel.Strategies

type Location = (Int, Int)

data Game = Game (S.Set Obstacle) Location Int Int deriving (Show, Eq, Ord)

newtype Obstacle = Obstacle Location deriving (Ord, Show, Eq)

data Direction = North | South | East | West deriving (Show, Eq, Ord)

data GuardLocation = Off | InLab Location Direction deriving (Show, Eq, Ord)

getObstacles :: Game -> S.Set Obstacle
getObstacles (Game obstacles _ _ _) = obstacles

getStartPoint :: Game -> Location
getStartPoint (Game _ startPoint _ _) = startPoint

turnRight :: Direction -> Direction
turnRight North = East
turnRight East = South
turnRight South = West
turnRight West = North

oneAhead :: Location -> Direction -> Location
oneAhead (row, col) North = (row - 1, col)
oneAhead (row, col) South = (row + 1, col)
oneAhead (row, col) East = (row, col + 1)
oneAhead (row, col) West = (row, col - 1)

isInGame :: Game -> Location -> Bool
isInGame (Game _ _ height width) (row, col) = row >= 0 && row <= (height - 1) && col >= 0 && col <= (width - 1)

move :: Game -> GuardLocation -> GuardLocation
move _ Off = Off
move game (InLab location direction)
  | blocked game (InLab location direction) = move game (InLab location (turnRight direction))
  | not (isInGame game (oneAhead location direction)) = Off
  | otherwise = InLab (oneAhead location direction) direction

blocked :: Game -> GuardLocation -> Bool
blocked game (InLab location direction) = Obstacle (oneAhead location direction) `elem` getObstacles game
blocked _ _ = False


addObstacle :: Game -> Location -> Game
addObstacle (Game obstacles startPoint height width) (targetRow, targetCol) = Game newObstacles startPoint height width
  where newObstacles = S.insert (Obstacle (targetRow, targetCol)) obstacles

parseGame :: [String] -> Game
parseGame description = Game obstacles startLocation height width
  where
    lineParses = zipWith parseLine [0 ..] description
    obstacles = foldl S.union S.empty [lineObstacles | (lineObstacles, _) <- lineParses]
    startLocation = head $ catMaybes [maybeStart | (_, maybeStart) <- lineParses]
    height = length description
    width = length $ head description

parseLine :: Int -> [Char] -> (S.Set Obstacle, Maybe Location)
parseLine currentRow line = (obstacles, startLocation)
  where
    obstacles = S.fromList $ mapMaybe parseChar (zip line [0 ..])
    parseChar ('#', col) = Just (Obstacle (currentRow, col))
    parseChar _ = Nothing
    startLocation = listToMaybe startLocations
    startLocations = [(currentRow, col) | (char, col) <- zip line [0 ..], char == '^']



exploreToEnd :: Game -> S.Set GuardLocation -> GuardLocation -> S.Set GuardLocation
exploreToEnd _ seenSoFar Off = Off `S.insert` seenSoFar
exploreToEnd world seenSoFar current
  | current `elem` seenSoFar = seenSoFar
  | otherwise = exploreToEnd world (S.insert current seenSoFar) (move world current)

hasCycle :: Game -> Bool
hasCycle game = Off `notElem` exploreToEnd game S.empty (InLab (getStartPoint game) North)

getPoint :: GuardLocation -> Maybe Location
getPoint (InLab location _) = Just location
getPoint _ = Nothing


allInterestingWorlds :: Game -> S.Set Game
allInterestingWorlds world = S.fromList $ map (addObstacle world) pointsAlongInitialWalk
  where pointsAlongInitialWalk = catMaybes $ S.toList $ S.map getPoint $ exploreToEnd world S.empty (InLab (getStartPoint world) North)

boolToInt :: Bool -> Int
boolToInt True = 1
boolToInt False = 0

partTwo :: [String] -> IO Int
partTwo inputLines = do
        print scores
        print $ sum scores
        return $ sum scores
  where scores = parMap rdeepseq (boolToInt . hasCycle) $ S.toList $ allInterestingWorlds game
        game = parseGame inputLines