module AOC.Challenge.Day11 (
day11a
, day11b
) where
import AOC.Common (Dir(..), dirPoint, Point)
import AOC.Common.Intcode (Memory, parseMem, stepForeverAndDie, untilHalt)
import AOC.Common.OCR (parseLetters)
import AOC.Solver ((:~>)(..))
import Control.DeepSeq (NFData)
import Control.Monad (forever)
import Control.Monad.State (MonadState, gets, execState, modify)
import Data.Conduino (Pipe, (.|), runPipe, awaitSurely)
import Data.Functor ((<&>))
import Data.Map (Map)
import Data.Void (Void)
import GHC.Generics (Generic)
import qualified Data.Conduino.Combinators as C
import qualified Data.Map as M
data Hull = Hull
{ hDir :: Dir
, hPos :: Point
, hMap :: Map Point Color
}
deriving (Eq, Ord, Show, Generic)
instance NFData Hull
data Color = Black | White
deriving (Eq, Ord, Enum, Show, Generic)
instance NFData Color
emptyHull :: Hull
emptyHull = Hull North 0 M.empty
singletonHull :: Color -> Hull
singletonHull c = Hull North 0 (M.singleton 0 c)
sensor
:: MonadState Hull m
=> Pipe () Int u m Void
sensor = C.repeatM . gets $ \(Hull _ p h) ->
case M.lookup p h of
Just White -> 1
_ -> 0
painterMover
:: MonadState Hull m
=> Pipe Int Void Void m Void
painterMover = forever $ do
color <- awaitSurely <&> \case
0 -> Black
1 -> White
_ -> undefined
turn <- awaitSurely <&> \case
0 -> West
1 -> East
_ -> undefined
modify $ \(Hull d p h) -> Hull
{ hDir = d <> turn
, hPos = p + dirPoint (d <> turn)
, hMap = M.insert p color h
}
fullPipe
:: MonadState Hull m
=> Memory
-> Pipe () Void u m ()
fullPipe m = untilHalt $ sensor
.| stepForeverAndDie m
.| painterMover
day11a :: Memory :~> Int
day11a = MkSol
{ sParse = parseMem
, sShow = show
, sSolve = \m -> Just . M.size . hMap
$ execState (runPipe (fullPipe m)) emptyHull
}
day11b :: Memory :~> Map Point Color
day11b = MkSol
{ sParse = parseMem
, sShow = parseLetters . M.keysSet . M.filter (== White)
, sSolve = \m -> Just . hMap
$ execState (runPipe (fullPipe m)) (singletonHull White)
}