AoC/2019/day17/day17.hs

{-# LANGUAGE LambdaCase #-}

module Main where

import Control.Arrow ((&&&))
import Data.List
import Data.List.Split
import Data.List.Utils
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as S
import Helpers
import Intcode
import Linear.V2
import System.Console.ANSI
import System.IO
  ( BufferMode(NoBuffering)
  , hReady
  , hSetBuffering
  , hSetEcho
  , stdin
  )

type ScreenBuffer = M.Map (V2 Int) Integer

main :: IO ()
main = do
  program <- readIntcode <$> readFile "input"
  let tm = defaultTM (Nothing) program
  let run x = runGameloop $ pure (tm, M.empty, True)
  (_, buf, _) <- run 0
  let cmd = getCMD buf
  print cmd

takeRepl s n a = replace (take n ((funTake . funTail) a)) [s] a
  where
    funTail = dropWhile (`elem` ["a", "b"])
    funTake = takeWhile (`notElem` ["a", "b"])

tryPartition (x, y, z) = takeRepl "c" z . takeRepl "b" y . takeRepl "a" x

part2 seq =
  catMaybes
    [ if ((== 3) . length . S.fromList . tryPartition (x, y, z)) seq
      then Just (x, y, z)
      else Nothing
    | x <- [1 .. 10]
    , y <- [1 .. 10]
    , z <- [1 .. 10]
    ]

runGameloop ::
     IO (TuringMachine, ScreenBuffer, Bool)
  -> IO (TuringMachine, ScreenBuffer, Bool)
runGameloop io = do
  (tm, buf, mode) <- io
  let tmNew = execSteps tm
  print $ output tmNew
  let bufNew = updateScreenBuffer buf (0, 0) $ reverse $ output tmNew
  putStrLn $ drawBoard bufNew
  putStrLn $ "Highscore: " ++ getHighscore bufNew
  putStrLn $ "Blocks left: " ++ countBlocks bufNew
  case state tmNew of
    AwaitInput -> do
      nextCommand <-
        if mode
          then do
            clearScreen
            getInput
          else pure $ getInputBot (output tmNew)
      runGameloop $
        pure (tmNew {input = Just nextCommand, output = []}, bufNew, mode)
    _ -> pure (tmNew, bufNew, mode)

getInputBot :: [Integer] -> Integer
getInputBot n = negate $ signum paddleBallDiff
  where
    f :: (V2 Int, V2 Int) -> [(V2 Int, Integer)] -> (V2 Int, V2 Int)
    (ball, paddle) = f (V2 0 0, V2 0 0) vals
    vals = M.toList $ updateScreenBuffer M.empty (0, 0) $ reverse n
    paddleBallDiff = fromIntegral $ v2x $ ball - paddle
    f (paddle, ball) [] = (paddle, ball)
    f (paddle, ball) ((coord, obj):xs)
      | obj == 4 = f (paddle, coord) xs
      | obj == 3 = f (coord, ball) xs
      | otherwise = f (paddle, ball) xs

getHighscore :: ScreenBuffer -> String
getHighscore buf = show $ M.findWithDefault 0 (V2 (-1) 0) buf

getInput :: IO Integer
getInput = do
  hSetBuffering stdin NoBuffering
  hSetEcho stdin False
  getKeyNow >>= \case
    "i" -> pure (-1)
    "a" -> pure 0
    "e" -> pure 1
    _ -> getInput

getKeyNow :: IO String
getKeyNow = reverse <$> getKey' ""
  where
    getKey' chars = do
      char <- getChar
      more <- hReady stdin
      (if more
         then getKey'
         else return)
        (char : chars)

updateScreenBuffer :: ScreenBuffer -> (Int, Int) -> [Integer] -> ScreenBuffer
updateScreenBuffer buf _ [] = buf
updateScreenBuffer buf (x, y) (a:as) = updateScreenBuffer bufNew coord as
  where
    bufNew =
      if a /= 10
        then M.insert (V2 x y) a buf
        else buf
    coord =
      if a /= 10
        then (x + 1, y)
        else (0, y + 1)

countBlocks :: ScreenBuffer -> String
countBlocks = show . length . M.filter (== 2)

drawBoard :: ScreenBuffer -> String
drawBoard =
  drawMap
    (M.fromList
       [(35, '#'), (46, '.'), (62, '>'), (60, '<'), (94, '^'), (118, 'v')])

getIntersections :: ScreenBuffer -> ScreenBuffer
getIntersections buf = M.filterWithKey f buf
  where
    f k v = v == 35 && and [buf M.!? (k + u) == Just 35 | u <- unitVecs]

getTurns :: ScreenBuffer -> ScreenBuffer
getTurns buf = M.filterWithKey f buf M.\\ getIntersections buf
  where
    f k v =
      v == 35 &&
      or
        [ buf M.!? (k + u) == Just 35 && buf M.!? (k + perp u) == Just 35
        | u <- unitVecs
        ]

countIntAlign :: ScreenBuffer -> String
countIntAlign m = show $ sum [x * y | (V2 x y, _) <- M.toList m]

toRelPath :: [V2 Int] -> [V2 Int]
toRelPath path = zipWith (-) (tail path) path

toCMD :: V2 Int -> [V2 Int] -> [String]
toCMD _ [] = []
toCMD u (x:xs)
  | crossZ u x < 0 = ("R" ++ (show . abs . sum) x) : toCMD (perp u) xs
  | crossZ u x >= 0 = ("L" ++ (show . abs . sum) x) : toCMD (perp (u * (-1))) xs

getCMD :: ScreenBuffer -> [String]
getCMD buf = toCMD dir (toRelPath path)
  where
    (pos, dir) = roboPos buf
    path = pos : getPath buf [] [pos]

getPath :: ScreenBuffer -> [V2 Int] -> [V2 Int] -> [V2 Int]
getPath _ acc [] = acc
getPath m acc currs =
  let a = nextTurn \\ acc
   in getPath m (acc ++ a) a
  where
    curr = head currs
    candidates =
      M.filterWithKey
        (\k _ -> v2x (k - curr) == 0 || v2y (k - curr) == 0)
        (getTurns m)
    isConnected =
      M.filterWithKey
        (\k _ ->
           and
             [ m M.!? x `elem` [Just 35, Just 94]
             | x <- map (+ curr) $ drawLine (k - curr)
             ])
    nextTurn =
      map fst $
      M.toList $ M.filterWithKey (\k _ -> M.member k m) $ isConnected candidates

roboPos :: ScreenBuffer -> (V2 Int, V2 Int)
roboPos = toTuple . M.toList . M.filter (`elem` [60, 62, 94, 118])
  where
    toTuple [(k, 60)] = (k, V2 (-1) 0)
    toTuple [(k, 62)] = (k, V2 1 0)
    toTuple [(k, 94)] = (k, V2 0 1)
    toTuple [(k, 118)] = (k, V2 0 (-1))