From 58509b8d56db009c1ab512830eb8681d831d2c2b Mon Sep 17 00:00:00 2001 From: shu Date: Sun, 15 Dec 2019 14:17:53 +0100 Subject: [PATCH] Day 15 Part 1 --- 2019/day15/Helpers.hs | 41 ++++++++++ 2019/day15/Intcode.hs | 171 ++++++++++++++++++++++++++++++++++++++++++ 2019/day15/day15.hs | 113 ++++++++++++++++++++++++++++ 2019/day15/input | 1 + 4 files changed, 326 insertions(+) create mode 100644 2019/day15/Helpers.hs create mode 100644 2019/day15/Intcode.hs create mode 100644 2019/day15/day15.hs create mode 100644 2019/day15/input diff --git a/2019/day15/Helpers.hs b/2019/day15/Helpers.hs new file mode 100644 index 0000000..21aba82 --- /dev/null +++ b/2019/day15/Helpers.hs @@ -0,0 +1,41 @@ +module Helpers + ( v2x + , v2y + , drawMap + ) where + +import Data.List +import Data.List.Split +import qualified Data.Map as M +import Linear.V2 + +v2x :: V2 a -> a +v2x (V2 x _) = x + +v2y :: V2 a -> a +v2y (V2 _ y) = y + +getBounds :: M.Map (V2 Int) Integer -> (Int, Int, Int, Int) +getBounds m = (getMinX, getMinY, getMaxX, getMaxY) + where + getMaxX = getFromMap maximum v2x + getMaxY = getFromMap maximum v2y + getMinX = getFromMap minimum v2x + getMinY = getFromMap minimum v2y + getFromMap f1 f2 = M.foldrWithKey (\k _ result -> f1 [f2 k, result]) 0 m + +drawMap :: M.Map Integer Char -> M.Map (V2 Int) Integer -> String +drawMap dict m = + intercalate "\n" $ + transpose $ + reverse $ map reverse $ + chunksOf + (abs (abs y1 - abs y2) + 1) + [ let c = M.findWithDefault (-99) (V2 x y) m + in M.findWithDefault ' ' c dict + | x <- [x1 .. x2] + , y <- [y1 .. y2] + ] + where + (x1, y1, x2, y2) = getBounds m + diff --git a/2019/day15/Intcode.hs b/2019/day15/Intcode.hs new file mode 100644 index 0000000..80f1850 --- /dev/null +++ b/2019/day15/Intcode.hs @@ -0,0 +1,171 @@ +module Intcode + ( TuringMachine(TM, tape, pointer, pointerOffset, output, input, + state) + , step + , defaultTM + , TMOutState(Continue, AwaitInput, Halt) + , execSteps + , readIntcode + ) where + +import Control.DeepSeq as DeepSeq +import Data.Char +import Data.List as L +import Data.List.Split +import Data.Maybe +import Data.Vector as V hiding + ( (++) + , concatMap + , elem + , head + , last + , length + , map + , reverse + , splitAt + ) +import qualified Data.Vector as V ((++), last) + +data TMOutState + = Continue + | AwaitInput + | Halt + deriving (Enum, Eq, Show) + +data Mode + = Position + | Immediate + | Relative + deriving (Enum, Eq, Show) + +data TuringMachine = + TM + { tape :: Vector Integer + , pointer :: Integer + , pointerOffset :: Integer + , output :: [Integer] + , input :: Maybe Integer + , state :: TMOutState + } + deriving (Show) + +readIntcode :: String -> V.Vector Integer +readIntcode = V.fromList . concatMap (map read . splitOn ",") . lines + +defaultTM :: Maybe (Int, Integer) -> Vector Integer -> TuringMachine +defaultTM replacement t = + TM + { tape = maybe t (tapePreprocess t) replacement + , pointer = 0 + , pointerOffset = 0 + , output = [] + , input = Nothing + , state = Continue + } + +tapePreprocess :: Vector Integer -> (Int, Integer) -> Vector Integer +tapePreprocess t (target, repl) = + flip (//) [(target, repl)] $ (V.++) t $ V.replicate 500 0 + +opLength :: Integer -> Integer +opLength x + | n `elem` "1278" = 4 + | n `elem` "56" = 3 + | n `elem` "349" = 2 + | otherwise = 1 + where + n = last $ show x + +parseModes :: String -> [Mode] +parseModes m = L.replicate (3 - length l) Position ++ l + where + l = map (toEnum . digitToInt) m + +paramChange :: + [Mode] -> Integer -> Vector Integer -> Vector Integer -> Vector Integer +paramChange m rbase opvec t = imap f (V.tail opvec) + where + f i a = + case m !! i of + Immediate -> a + Position -> t ! fromInteger a + Relative -> t ! fromInteger (a + rbase) + +getOpModes :: Vector Integer -> (String, [Mode]) +getOpModes opvec = (op_dedup, parsed_modes) + where + (op, modes) = splitAt 2 $ reverse $ show $ opvec ! 0 + parsed_modes = reverse $ parseModes $ reverse modes + op_dedup = + if last op == '0' + then [head op] + else op + +step :: TuringMachine -> TuringMachine +step tm = + case op of + "1" -> tmBinop (+) + "2" -> tmBinop (*) + "3" -> + if isJust (input tm) + then (getNewTM (fromJust $ input tm)) {input = Nothing} + else tm {state = AwaitInput} + "4" -> tmn {output = V.last params : output tm} + "5" -> + tm + { pointer = + if params ! 0 /= 0 + then params ! 1 + else pNew + } + "6" -> + tm + { pointer = + if params ! 0 == 0 + then params ! 1 + else pNew + } + "7" -> + tmBinop + (\x y -> + if x < y + then 1 + else 0) + "8" -> + tmBinop + (\x y -> + if x == y + then 1 + else 0) + "9" -> tmn {pointerOffset = pointerOffset tm + (params ! 0)} + "99" -> tm {state = Halt} + _ -> error "Illegal Opcode." + where + pNew = pointer tm + opLength (tape tm ! fromInteger (pointer tm)) + tmn = tm {pointer = pNew} + opvec = + slice + (fromInteger (pointer tm)) + (fromInteger (pNew - pointer tm)) + (tape tm) + (op, m) = getOpModes opvec + params = paramChange m (pointerOffset tm) opvec (tape tm) + tmBinop x = getNewTM ((params ! 0) `x` (params ! 1)) + {-without the following DeepSeq call, thunks build up eternally and + the vectors won’t be garbage collected: >4GB RAM usage, god knows + how much with larger tapes (my laptop crashed), now it’s a cozy ~20mB-} + getNewTM x = + tmn {tape = DeepSeq.force (tape tm // [(target, x)]), state = Continue} + target = + fromInteger $ + case m !! (length params - 1) of + Relative -> V.last opvec + pointerOffset tm + _ -> V.last opvec + +execSteps :: TuringMachine -> TuringMachine +execSteps tm = + case state tmNew of + Continue -> execSteps tmNew + _ -> tmNew + where + tmNew = step tm diff --git a/2019/day15/day15.hs b/2019/day15/day15.hs new file mode 100644 index 0000000..5f14035 --- /dev/null +++ b/2019/day15/day15.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Data.List.Split +import qualified Data.Map.Strict as M +import Helpers +import Intcode +import Linear.V2 +import System.Console.ANSI +import System.IO + ( BufferMode(NoBuffering) + , hReady + , hSetBuffering + , hSetEcho + , stdin + ) +import Debug.Trace +import System.Random + +type ScreenBuffer = M.Map (V2 Int) Integer + +main :: IO () +main = do + program <- readIntcode <$> readFile "input" + mode <- queryMode + let tm = defaultTM Nothing program + let run x = runGameloop $ pure (tm {state = AwaitInput}, M.empty, V2 0 20, mode) + (_, buf, _, _) <- run 0 + putStrLn "Done." + +queryMode :: IO Bool +queryMode = do + putStrLn "Do you want to play the game yourself? [y/n]" + getLine >>= \case + "y" -> pure True + "n" -> pure False + _ -> do print "Illegal input." + queryMode + +runGameloop :: + IO (TuringMachine, ScreenBuffer, V2 Int, Bool) + -> IO (TuringMachine, ScreenBuffer, V2 Int, Bool) +runGameloop io = do + (tm, buf, oldPos, mode) <- io + case state tm of + AwaitInput -> do + nextCommand <- + if mode + then do + clearScreen + getInput + else getInputBot + let newPosTry = oldPos + case nextCommand of + 1 -> V2 0 1 + 2 -> V2 0 (-1) + 3 -> V2 1 0 + 4 -> V2 (-1) 0 + let tmNew = execSteps tm{input = Just nextCommand} + let tmNewOut = head $ output tmNew + let newPos = case tmNewOut of + 0 -> oldPos + _ -> newPosTry + print tmNewOut + let bufNew = if tmNewOut == 0 then M.insert newPosTry 0 buf else buf + let bufNew2 = if newPos /= oldPos then updatePath bufNew oldPos newPos else bufNew + let bufNew3 = if tmNewOut == 2 then M.insert newPos 2 bufNew2 else bufNew2 + putStrLn $ drawBoard (M.insert newPos 3 bufNew3) + print $ countSteps bufNew2 + runGameloop $ + pure (tmNew {input = Just nextCommand, output = []}, bufNew3, newPos, mode) + _ -> pure (tm, buf, oldPos, mode) + +updatePath :: ScreenBuffer -> V2 Int -> V2 Int -> ScreenBuffer +updatePath buf oldPos newPos = if M.member newPos buf then M.delete oldPos buf else M.insert newPos 1 buf + +countSteps :: ScreenBuffer -> Int +countSteps = M.size . M.filter (==1) + +getInputBot :: IO Integer +getInputBot = do + randomRIO (1,4) + +getInput :: IO Integer +getInput = do + hSetBuffering stdin NoBuffering + hSetEcho stdin False + getKeyNow >>= \case + "l" -> pure 1 + "a" -> pure 2 + "i" -> pure 3 + "e" -> pure 4 + _ -> 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 -> [Integer] -> ScreenBuffer +updateScreenBuffer buf xs = foldl pttrans buf $ chunksOf 3 xs + where + pttrans board [x, y, n] = + M.insert (V2 (fromIntegral x) (fromIntegral y)) n board + +drawBoard :: ScreenBuffer -> String +drawBoard = drawMap (M.fromList [(0, '█'), (2, '⌂'), (3, 'I'), (1, '•')]) diff --git a/2019/day15/input b/2019/day15/input new file mode 100644 index 0000000..361d6d7 --- /dev/null +++ b/2019/day15/input @@ -0,0 +1 @@ +3,1033,1008,1033,1,1032,1005,1032,31,1008,1033,2,1032,1005,1032,58,1008,1033,3,1032,1005,1032,81,1008,1033,4,1032,1005,1032,104,99,1001,1034,0,1039,102,1,1036,1041,1001,1035,-1,1040,1008,1038,0,1043,102,-1,1043,1032,1,1037,1032,1042,1106,0,124,1001,1034,0,1039,1002,1036,1,1041,1001,1035,1,1040,1008,1038,0,1043,1,1037,1038,1042,1105,1,124,1001,1034,-1,1039,1008,1036,0,1041,1001,1035,0,1040,101,0,1038,1043,1002,1037,1,1042,1105,1,124,1001,1034,1,1039,1008,1036,0,1041,1001,1035,0,1040,101,0,1038,1043,102,1,1037,1042,1006,1039,217,1006,1040,217,1008,1039,40,1032,1005,1032,217,1008,1040,40,1032,1005,1032,217,1008,1039,9,1032,1006,1032,165,1008,1040,39,1032,1006,1032,165,1102,2,1,1044,1105,1,224,2,1041,1043,1032,1006,1032,179,1102,1,1,1044,1106,0,224,1,1041,1043,1032,1006,1032,217,1,1042,1043,1032,1001,1032,-1,1032,1002,1032,39,1032,1,1032,1039,1032,101,-1,1032,1032,101,252,1032,211,1007,0,72,1044,1105,1,224,1102,1,0,1044,1105,1,224,1006,1044,247,102,1,1039,1034,1002,1040,1,1035,1002,1041,1,1036,1002,1043,1,1038,1001,1042,0,1037,4,1044,1106,0,0,43,44,92,18,58,24,84,34,94,19,51,95,1,54,20,78,88,51,71,20,92,96,11,50,22,21,3,96,74,15,26,56,99,18,80,56,99,50,12,71,93,48,25,99,83,45,4,68,98,82,26,95,97,98,6,3,79,32,98,34,9,80,74,24,95,75,12,26,80,54,10,71,94,79,40,38,99,57,58,78,31,97,40,85,38,83,87,27,85,29,42,99,69,29,80,94,56,88,21,17,84,87,78,54,27,85,31,77,30,82,83,52,30,90,49,93,69,58,74,42,86,40,85,79,23,98,14,11,79,26,86,33,82,83,17,84,53,65,97,10,68,99,48,76,83,44,98,18,82,11,3,81,84,1,42,82,73,99,35,83,42,24,97,31,78,41,82,75,11,86,86,3,99,11,15,84,53,79,93,53,62,82,64,98,56,76,69,74,5,83,97,63,4,81,32,10,33,94,93,87,70,31,76,68,22,7,7,96,96,57,41,95,11,96,85,83,85,50,27,82,89,56,20,95,96,93,91,92,40,68,78,84,7,52,42,55,37,75,58,80,28,80,10,92,54,89,52,55,78,75,71,65,82,30,50,81,99,39,68,74,30,87,58,31,74,10,1,85,66,93,85,9,88,74,74,24,86,1,91,12,76,65,85,82,93,95,32,98,67,16,80,79,42,79,33,93,45,91,99,73,48,84,96,35,95,14,99,55,61,84,53,63,54,54,89,88,85,25,97,96,88,51,73,29,79,31,94,32,74,92,48,63,28,92,9,52,91,26,78,75,22,39,1,99,20,86,91,9,73,84,23,27,59,36,83,29,52,88,39,2,90,41,46,83,2,3,96,55,28,89,89,33,90,21,22,82,7,87,17,75,83,98,33,73,73,2,31,88,10,56,49,78,78,42,88,91,21,83,21,83,27,82,21,85,35,91,98,70,45,91,87,90,95,15,11,77,53,49,55,92,21,9,91,95,46,61,63,82,11,77,47,98,20,90,25,64,81,20,80,93,41,5,91,91,55,95,57,76,97,75,9,99,52,73,55,95,89,28,98,57,99,66,34,81,87,39,85,56,8,16,74,85,18,24,99,76,58,89,46,53,86,98,89,65,81,51,77,18,12,64,83,18,96,36,33,73,70,85,89,52,82,82,37,38,85,83,28,58,98,69,10,86,86,2,32,83,87,85,29,88,32,98,11,88,29,74,64,89,91,6,41,89,45,91,79,87,34,76,7,21,89,40,97,74,28,62,58,3,92,66,92,78,87,67,22,41,54,81,69,24,97,65,30,87,88,61,55,96,85,40,98,53,80,32,66,88,3,47,98,77,56,30,15,92,77,20,56,80,79,52,25,77,23,87,74,76,34,77,75,1,5,82,27,93,50,82,82,2,6,52,19,78,93,15,83,48,92,82,60,90,98,99,57,69,16,87,52,26,79,82,49,51,85,30,62,73,92,40,86,88,37,14,76,71,79,43,84,82,8,98,38,1,80,85,76,54,17,74,17,7,96,10,43,26,88,97,6,70,94,96,23,3,74,23,80,17,26,81,39,89,91,10,94,26,13,92,5,43,95,70,87,51,36,86,74,57,88,42,88,84,57,10,77,10,36,99,96,62,89,40,86,98,24,93,43,79,17,26,32,84,24,94,56,85,94,43,75,82,65,80,63,6,75,70,81,99,73,58,34,93,23,76,70,89,42,86,48,80,66,88,83,81,61,80,62,86,74,85,40,84,81,93,45,74,30,73,24,84,83,88,41,77,69,89,2,95,47,84,80,85,0,0,21,21,1,10,1,0,0,0,0,0,0