AoC/2019/day17/day17.hs

196 lines
5.2 KiB
Haskell
Raw Normal View History

2019-12-17 22:34:14 +01:00
{-# 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))