Day17.hs

{-# LANGUAGE TypeApplications #-}

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

module AOC.Challenge.Day17 (
    day17a
  , day17b
  ) where

import           AOC.Common          (Point, Dir(..), dirPoint', cardinalNeighbs, parseAsciiMap)
import           AOC.Common.Intcode  (Memory, parseMem, IErr, stepForever, mRegLens)
import           AOC.Solver          ((:~>)(..))
import           AOC.Util            (eitherToMaybe)
import           Control.Applicative (empty)
import           Control.DeepSeq     (NFData)
import           Control.Lens        (set)
import           Control.Monad       (guard, (<=<))
import           Data.Char           (chr, ord)
import           Data.Conduino       (feedPipe)
import           Data.Foldable       (asum)
import           Data.List           (group, unfoldr, inits, stripPrefix, intercalate)
import           Data.List.Split     (chunksOf, splitOn)
import           Data.Maybe          (mapMaybe, listToMaybe)
import           Data.Set            (Set)
import           GHC.Generics        (Generic)
import           Safe                (lastMay)
import qualified Data.Map            as M
import qualified Data.Set            as S

data AState = AS { asPos :: Point
                 , asDir :: Dir
                 }
  deriving (Show, Eq, Ord, Generic)
instance NFData AState

parseMap :: Memory -> Maybe (Set Point, Maybe AState)
parseMap m = do
    (os, _) <- eitherToMaybe $ feedPipe [] (stepForever @IErr m)
    let mp    = parseAsciiMap parseTile (map chr os)
        scaff = M.keysSet mp
        sOut  = do
          (p, d) <- listToMaybe . M.toList . M.mapMaybe id $ mp
          pure (AS p d)
    pure (scaff, sOut)
  where
    parseTile = \case
      '#' -> Just Nothing
      '^' -> Just (Just North)
      '>' -> Just (Just East)
      'v' -> Just (Just South)
      '<' -> Just (Just West)
      _   -> Nothing


day17a :: Set Point :~> Int
day17a = MkSol
    { sParse = fmap fst . parseMap <=< parseMem
    , sShow  = show
    , sSolve = Just . sum . S.map product . findNeighbs
    }
  where
    findNeighbs scaff = S.filter allScaff scaff
      where
        allScaff = all (`S.member` scaff) . cardinalNeighbs

day17b :: (Set Point, AState, Memory) :~> (String, Memory)
day17b = MkSol
    { sParse = \str -> do
        m <- set (mRegLens 0) 2 <$> parseMem str
        (scaff, as0) <- sequenceA =<< parseMap m
        pure (scaff, as0, m)
    , sShow  = \(map ord -> inp, m) -> foldMap show $ do
        output <- fst <$> eitherToMaybe (feedPipe inp (stepForever @IErr m))
        lastMay output
    , sSolve = \(scaff, as0, m) -> do
        let path  = findPath scaff as0
        (a,b,c) <- findProgs path
        let mainProg = chomp [(a,"A"),(b,"B"),(c,"C")] path
            inp      = unlines . map (intercalate ",") $
              [ mainProg
              , showPC <$> a
              , showPC <$> b
              , showPC <$> c
              , ["n"]
              ]
        pure (inp, m)
    }


findProgs :: Eq a => [a] -> Maybe ([a], [a], [a])
findProgs p0 = listToMaybe $ do
    a <- validPrefix p0

    let withoutA = neSplitOn a p0
    b <- case withoutA of
        []        -> empty
        bs : _    -> validPrefix bs

    let withoutB = neSplitOn b =<< withoutA
    c <- case withoutB of
        []        -> empty
        cs : _    -> validPrefix cs

    let withoutC = neSplitOn c =<< withoutB
    guard $ null withoutC

    pure (a, b, c)
  where
    validPrefix = take 4 . filter (not . null) . inits
    neSplitOn x = filter (not . null) . splitOn x

chomp :: Eq a => [([a], b)] -> [a] -> [b]
chomp progs = unfoldr go
  where
    go xs = asum
      [ (r,) <$> stripPrefix prog xs
      | (prog, r) <- progs
      ]


type PathComp = Either Int Int

showPC :: PathComp -> String
showPC = \case
    Left  x -> "L," ++ show x
    Right x -> "R," ++ show x

findPath :: Set Point -> AState -> [PathComp]
findPath scaff = mapMaybe process . chunksOf 2 . group . unfoldr go
  where
    process = \case
      [Just turnRight :_, steps]
        | turnRight -> Just $ Right (length steps)
        | otherwise -> Just $ Left  (length steps)
      _             -> Nothing
    go AS{..}
        | forward   `S.member` scaff = Just (Nothing   , AS forward asDir          )
        | turnLeft  `S.member` scaff = Just (Just False, AS asPos   (asDir <> West))
        | turnRight `S.member` scaff = Just (Just True , AS asPos   (asDir <> East))
        | otherwise                  = Nothing
      where
        forward   = asPos + dirPoint' asDir
        turnLeft  = asPos + dirPoint' (asDir <> West)
        turnRight = asPos + dirPoint' (asDir <> East)