Day23.hs

{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : AOC.Challenge.Day23
-- License     : BSD3
--
-- Stability   : experimental
-- Portability : non-portable
--
-- Day 23.  See "AOC.Solver" for the types used in this module!

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))       -- ^ use one big global queue
    , 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