{-# LANGUAGE TypeApplications         #-}

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

module AOC.Challenge.Day19 (
    day19a
  , day19b
  ) where

import           AOC.Common          (Point, countTrue)
import           AOC.Common.Intcode  (Memory, IErr, parseMem, stepForever, untilHalt)
import           AOC.Common.Search   (binaryMinSearch, binaryFindMin)
import           AOC.Solver          ((:~>)(..))
import           AOC.Util            (firstJust)
import           Control.Applicative (empty)
import           Control.Lens        (view)
import           Control.Monad       (guard, join)
import           Data.Conduino       (runPipe, (.|), yield, await)
import           Data.List           (find)
import           Data.Map            (Map)
import           Data.Maybe          (fromJust)
import           Linear.V2           (V2(..), _x, _y)
import qualified Data.Map            as M
import qualified Data.Set            as S

day19a :: Memory :~> Int
day19a = MkSol
    { sParse = parseMem
    , sShow  = show
    , sSolve = \m -> Just $ countTrue (checkBeam m) (V2 <$> [0..49] <*> [0..49])
    }

checkBeam :: Memory -> Point -> Bool
checkBeam m (V2 x y) = (== 1) . fromJust . join $
    runPipe $ (yield x *> yield y *> empty)
           .| untilHalt (stepForever @IErr m)
           .| await

data Ranges = R
    { xMins :: !(Map Int (Maybe Int))
    , xMaxs :: !(Map Int (Maybe Int))
    , yMins :: !(Map Int (Maybe Int))
    , yMaxs :: !(Map Int (Maybe Int))
    }

mkRanges :: Memory -> Ranges
mkRanges m = R{..}
  where
    cache   = M.fromSet (checkBeam m) (S.fromList $ V2 <$> [0..1500] <*> [0..1500])
    rangeRange = S.fromAscList [0..1250]
    xMins = flip M.fromSet rangeRange $ \y ->
      case M.lookup (y - 1) xMins of
        Just (Just xm) -> view _x <$> find (cache M.!) ((`V2` y) . (+ xm) <$> [0..10])
        _              -> view _x <$> find (cache M.!) ((`V2` y)          <$> [0..10])
    xMaxs = flip M.fromSet rangeRange $ \y ->
      case M.lookup y xMins of
        Just (Just xm) -> subtract 1 <$> binaryMinSearch (not . (cache M.!) . (`V2` y)) xm (xm + 250)
        _              -> Nothing
    yMins = flip M.fromSet rangeRange $ \x ->
      case M.lookup (x - 1) yMins of
        Just (Just ym) -> view _y <$> find (cache M.!) (V2 x . (+ ym) <$> [0..10])
        _              -> view _y <$> find (cache M.!) (V2 x          <$> [0..10])
    yMaxs = flip M.fromSet rangeRange $ \x ->
      case M.lookup x yMins of
        Just (Just ym) -> subtract 1 <$> binaryMinSearch (not . (cache M.!) . V2 x) ym (ym + 250)
        _              -> Nothing

day19b :: Memory :~> (Int, Int)
day19b = MkSol
    { sParse = parseMem
    , sShow  = \(x,y) -> show $ x * 10000 + y
    , sSolve = \m -> do
        let R{..}   = mkRanges m
            goodY y = do
                guard $ (xmax - xmin + 1) >= 100
                binaryFindMin goodX xmin (xmax - 100 + 1)
              where
                Just xmin = xMins M.! y
                Just xmax = xMaxs M.! y
                goodX x = do
                  let Just ymin = yMins M.! x
                      Just ymax = yMaxs M.! x
                  guard $ y >= ymin
                  guard $ (ymax - y + 1) >= 100
                  pure (x, y)
        (_,y) <- binaryFindMin goodY 500 1500
                -- this has a hole, how weird
                -- works for 825, 828, 829, 830...
                -- so it will get a false match on 828
        -- check a couple lower ys to be safe
        firstJust goodY [y-4 .. y]
    }