{-# LANGUAGE TypeApplications #-}
module AOC.Challenge.Day23 (
day23a
, day23b
) where
import AOC.Common (Point)
import AOC.Common.Intcode (Memory, parseMem, VM, stepForever, VMErr)
import AOC.Solver ((:~>)(..))
import AOC.Util (firstJust)
import Control.Lens (view, (%%~), at)
import Control.Monad (guard, ap)
import Data.Conduino (feedPipe, squeezePipe)
import Data.Function ((&))
import Data.List.Split (chunksOf)
import Data.Map (Map)
import Data.Sequence (Seq(..))
import Data.Traversable (for)
import Data.Witherable (forMaybe, mapMaybe, catMaybes)
import Linear.V2 (V2(..), _y)
import qualified Data.Map as M
import qualified Data.Sequence as Seq
data Network = MM
{ nPipes :: !(Map Int (Int -> VM (Either VMErr) Memory))
, nQueue :: !(Seq (Int, Point))
, nNAT :: !(Maybe Point)
}
initNetwork :: Memory -> Network
initNetwork m = MM
{ nPipes = M.fromList (catMaybes pipes')
, nQueue = parseOuts outList
, nNAT = Nothing
}
where
(outList, pipes') = for [0..49] $ \i ->
case feedPipe [i] (stepForever @VMErr m) of
Left _ -> ([], Nothing)
Right (os, r) -> case r of
Left n -> (os, Just (i, n))
Right _ -> (os, Nothing )
stepNetwork :: Network -> Network
stepNetwork mm@MM{..} = case nQueue of
Empty -> case nNAT of
Just a -> mm { nQueue = Seq.singleton (0, a) }
Nothing ->
let (outList, pipes') = forMaybe nPipes $ \n ->
case squeezePipe (n (-1)) of
Left _ -> ([], Nothing)
Right (os, r) -> case r of
Left n' -> (os, Just n')
Right _ -> (os, Nothing)
in mm { nPipes = pipes', nQueue = parseOuts outList }
(i, p@(V2 x y)) :<| ps
| i == 255 -> mm { nNAT = Just p, nQueue = ps }
| otherwise ->
let (outList, pipes') = nPipes & at i %%~ \case
Nothing -> ([], Nothing)
Just n -> case feedPipe [y] (n x) of
Left _ -> ([], Nothing)
Right (os, r) -> case r of
Left n' -> (os, Just n')
Right _ -> (os, Nothing)
queue' = ps <> parseOuts outList
in MM pipes' queue' nNAT
parseOuts :: [a] -> Seq (a, V2 a)
parseOuts = Seq.fromList . mapMaybe splitOut . chunksOf 3
where
splitOut [i,x,y] = Just (i, V2 x y)
splitOut _ = Nothing
day23a :: Memory :~> Int
day23a = MkSol
{ sParse = parseMem
, sShow = show
, sSolve = firstJust (firstJust find255 . nQueue)
. iterate stepNetwork
. initNetwork
}
where
find255 (255, V2 _ y) = Just y
find255 _ = Nothing
day23b :: Memory :~> Int
day23b = MkSol
{ sParse = parseMem
, sShow = show
, sSolve = firstJust (\(x,y) -> x <$ guard (x == y))
. (zip`ap`tail)
. mapMaybe natted
. iterate stepNetwork
. initNetwork
}
where
natted MM{..} = do
guard $ Seq.null nQueue
view _y <$> nNAT