Day 17: Almost working
This commit is contained in:
parent
dedbad960e
commit
1648db9487
|
@ -0,0 +1,50 @@
|
||||||
|
module Helpers
|
||||||
|
( v2x
|
||||||
|
, v2y
|
||||||
|
, drawMap
|
||||||
|
, drawLine
|
||||||
|
, unitVecs
|
||||||
|
) 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
|
||||||
|
|
||||||
|
unitVecs :: [V2 Int]
|
||||||
|
unitVecs = take 4 $ iterate perp (V2 0 1)
|
||||||
|
|
||||||
|
drawLine :: V2 Int -> [V2 Int]
|
||||||
|
drawLine (V2 0 0) = []
|
||||||
|
drawLine (V2 a b)
|
||||||
|
| abs a > abs b = V2 (a - signum a) b : drawLine (V2 (a - signum a) b)
|
||||||
|
| otherwise = V2 a (b - signum b) : drawLine (V2 a (b - signum b))
|
||||||
|
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 $
|
||||||
|
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
|
||||||
|
|
|
@ -0,0 +1,172 @@
|
||||||
|
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 Debug.Trace
|
||||||
|
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 (tapePreprocess t (0,t ! 0)) (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 22000 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
|
|
@ -0,0 +1,195 @@
|
||||||
|
{-# 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))
|
Loading…
Reference in New Issue
Block a user