Of course.
gentooer
joined 2 years ago
I'm guessing it's more like -5
Haskell
Runs in 115 ms. Today's pretty straight forward. Memoization feels like magic sometimes!
Code
import Control.Monad.Memo
import Data.List
splitX :: Eq a => [a] -> [a] -> [[a]]
splitX xs = go
where
go [] = [[]]
go ys@(y : ys') = case stripPrefix xs ys of
Just ys'' -> [] : go ys''
Nothing -> let (zs : zss) = go ys' in (y : zs) : zss
parse :: String -> ([String], [String])
parse s =
let (patterns : _ : designs) = lines s
in (splitX ", " patterns, takeWhile (not . null) designs)
countPatterns :: (Eq a, Ord a) => [[a]] -> [a] -> Memo [a] Int Int
countPatterns yss = go
where
go [] = return 1
go xs = sum <$> sequence
[memo go xs' | Just xs' <- map (\ys -> stripPrefix ys xs) yss]
main :: IO ()
main = do
(patterns, designs) <- parse <$> getContents
let ns = startEvalMemo $ mapM (countPatterns patterns) designs
print $ length $ filter (> 0) ns
print $ sum ns
Haskell
Not really happy with performance, binary search would speed this up a bunch, takes about 1.3 seconds.
Update: Binary search got it to 960 ms.
Code
import Data.Maybe
import qualified Data.Set as S
type Coord = (Int, Int)
parse :: String -> [Coord]
parse = map (read . ('(' :) . (++ ")")) . takeWhile (not . null) . lines
shortest :: Coord -> [Coord] -> Maybe Int
shortest (x0, y0) corrupted' = go $ S.singleton (x0 - 1, y0 - 1)
where
corrupted = S.fromList corrupted'
inside (x, y)
| x < 0 = False
| y < 0 = False
| x0 <= x = False
| y0 <= y = False
| otherwise = True
grow cs = S.filter inside $ S.unions $ cs :
[ S.mapMonotonic (\(x, y) -> (x + dx, y + dy)) cs
| (dx, dy) <- [(-1, 0), (0, -1), (0, 1), (1, 0)]
]
go visited
| (0, 0) `S.member` visited = Just 0
| otherwise = case grow visited S.\\ corrupted of
visited'
| S.size visited == S.size visited' -> Nothing
| otherwise -> succ <$> go visited'
main :: IO ()
main = do
rs <- parse <$> getContents
let size = (71, 71)
print $ fromJust $ shortest size $ take 1024 rs
putStrLn $ init $ tail $ show $ last $ zipWith const (reverse rs) $
takeWhile (isNothing . shortest size) $ iterate init rs
Faster (binary search)
import Data.Maybe
import qualified Data.Set as S
type Coord = (Int, Int)
parse :: String -> [Coord]
parse = map (read . ('(' :) . (++ ")")) . takeWhile (not . null) . lines
shortest :: Coord -> [Coord] -> Maybe Int
shortest (x0, y0) corrupted' = go $ S.singleton (x0 - 1, y0 - 1)
where
corrupted = S.fromList corrupted'
inside (x, y)
| x < 0 = False
| y < 0 = False
| x0 <= x = False
| y0 <= y = False
| otherwise = True
grow cs = S.filter inside $ S.unions $ cs :
[ S.mapMonotonic (\(x, y) -> (x + dx, y + dy)) cs
| (dx, dy) <- [(-1, 0), (0, -1), (0, 1), (1, 0)]
]
go visited
| (0, 0) `S.member` visited = Just 0
| otherwise = case grow visited S.\\ corrupted of
visited'
| S.size visited == S.size visited' -> Nothing
| otherwise -> succ <$> go visited'
solve2 :: Coord -> [Coord] -> Coord
solve2 r0 corrupted = go 0 $ length corrupted
where
go a z
| succ a == z = corrupted !! a
| otherwise =
let x = (a + z) `div` 2
in case shortest r0 $ take x corrupted of
Nothing -> go a x
Just _ -> go x z
main :: IO ()
main = do
rs <- parse <$> getContents
let size = (71, 71)
print $ fromJust $ shortest size $ take 1024 rs
putStrLn $ init $ tail $ show $ solve2 size rs
Haskell
Runs in 10 ms. I was stuck for most of the day on the bdv and cdv instructions, as I didn't read that the numerator was still register A. Once I got past that, it was pretty straight forward.
Code
import Control.Monad.State.Lazy
import Data.Bits (xor)
import Data.List (isSuffixOf)
import qualified Data.Vector as V
data Instr =
ADV Int | BXL Int | BST Int | JNZ Int | BXC | OUT Int | BDV Int | CDV Int
type Machine = (Int, Int, Int, Int, V.Vector Int)
parse :: String -> Machine
parse s =
let (la : lb : lc : _ : lp : _) = lines s
[a, b, c] = map (read . drop 12) [la, lb, lc]
p = V.fromList $ read $ ('[' :) $ (++ "]") $ drop 9 lp
in (a, b, c, 0, p)
getA, getB, getC, getIP :: State Machine Int
getA = gets $ \(a, _, _, _ , _) -> a
getB = gets $ \(_, b, _, _ , _) -> b
getC = gets $ \(_, _, c, _ , _) -> c
getIP = gets $ \(_, _, _, ip, _) -> ip
setA, setB, setC, setIP :: Int -> State Machine ()
setA a = modify $ \(_, b, c, ip, p) -> (a, b, c, ip, p)
setB b = modify $ \(a, _, c, ip, p) -> (a, b, c, ip, p)
setC c = modify $ \(a, b, _, ip, p) -> (a, b, c, ip, p)
setIP ip = modify $ \(a, b, c, _ , p) -> (a, b, c, ip, p)
incIP :: State Machine ()
incIP = getIP >>= (setIP . succ)
getMem :: State Machine (Maybe Int)
getMem = gets (\(_, _, _, ip, p) -> p V.!? ip) <* incIP
getCombo :: State Machine (Maybe Int)
getCombo = do
n <- getMem
case n of
Just 4 -> Just <$> getA
Just 5 -> Just <$> getB
Just 6 -> Just <$> getC
Just n | n <= 3 -> return $ Just n
_ -> return Nothing
getInstr :: State Machine (Maybe Instr)
getInstr = do
opcode <- getMem
case opcode of
Just 0 -> fmap ADV <$> getCombo
Just 1 -> fmap BXL <$> getMem
Just 2 -> fmap BST <$> getCombo
Just 3 -> fmap JNZ <$> getMem
Just 4 -> fmap (const BXC) <$> getMem
Just 5 -> fmap OUT <$> getCombo
Just 6 -> fmap BDV <$> getCombo
Just 7 -> fmap CDV <$> getCombo
_ -> return Nothing
execInstr :: Instr -> State Machine (Maybe Int)
execInstr (ADV n) = (getA >>= (setA . (`div` (2^n)))) *> return Nothing
execInstr (BDV n) = (getA >>= (setB . (`div` (2^n)))) *> return Nothing
execInstr (CDV n) = (getA >>= (setC . (`div` (2^n)))) *> return Nothing
execInstr (BXL n) = (getB >>= (setB . xor n)) *> return Nothing
execInstr (BST n) = setB (n `mod` 8) *> return Nothing
execInstr (JNZ n) = do
a <- getA
case a of
0 -> return ()
_ -> setIP n
return Nothing
execInstr BXC = ((xor <$> getB <*> getC) >>= setB) *> return Nothing
execInstr (OUT n) = return $ Just $ n `mod` 8
run :: State Machine [Int]
run = do
mInstr <- getInstr
case mInstr of
Nothing -> return []
Just instr -> do
mOut <- execInstr instr
case mOut of
Nothing -> run
Just n -> (n :) <$> run
solve2 :: Machine -> Int
solve2 machine@(_, _, _, _, p') = head [a | x <- [1 .. 7], a <- go [x]]
where
p = V.toList p'
go as =
let a = foldl ((+) . (* 8)) 0 as
in case evalState (setA a *> run) machine of
ns | ns == p -> [a]
| ns `isSuffixOf` p ->
concatMap go [as ++ [a] | a <- [0 .. 7]]
| otherwise -> []
main :: IO ()
main = do
machine@(_, _, _, _, p) <- parse <$> getContents
putStrLn $ init $ tail $ show $ evalState run machine
print $ solve2 machine
Haskell
Runs in 12 ms. I was very happy with my code for part 1, but will sadly have to rewrite it completely for part 2.
Code
import Control.Monad.State.Lazy
import qualified Data.Map.Strict as M
type Coord = (Int, Int)
data Block = Box | Wall
type Grid = M.Map Coord Block
parse :: String -> ((Coord, Grid), [Coord])
parse s =
let robot = head
[ (r, c)
| (r, row) <- zip [0 ..] $ lines s
, (c, '@') <- zip [0 ..] row
]
grid = M.fromAscList
[ ((r, c), val)
| (r, row) <- zip [0 ..] $ lines s
, (c, Just val) <- zip [0 ..] $ map f row
]
in ((robot, grid), go s)
where
f 'O' = Just Box
f '#' = Just Wall
f _ = Nothing
go ('^' : rest) = (-1, 0) : go rest
go ('v' : rest) = ( 1, 0) : go rest
go ('<' : rest) = ( 0, -1) : go rest
go ('>' : rest) = ( 0, 1) : go rest
go (_ : rest) = go rest
go [] = []
add :: Coord -> Coord -> Coord
add (r0, c0) (r1, c1) = (r0 + r1, c0 + c1)
moveBoxes :: Coord -> Coord -> Grid -> Maybe Grid
moveBoxes dr r grid = case grid M.!? r of
Nothing -> Just grid
Just Wall -> Nothing
Just Box ->
M.insert (add r dr) Box . M.delete r <$> moveBoxes dr (add r dr) grid
move :: Coord -> State (Coord, Grid) Bool
move dr = state $ \(r, g) -> case moveBoxes dr (add r dr) g of
Just g' -> (True, (add r dr, g'))
Nothing -> (False, (r, g))
moves :: [Coord] -> State (Coord, Grid) ()
moves = mapM_ move
main :: IO ()
main = do
((robot, grid), movements) <- parse <$> getContents
let (_, grid') = execState (moves movements) (robot, grid)
print $ sum [100 * r + c | ((r, c), Box) <- M.toList grid']
Haskell. For part 2 I just wrote 10000 text files and went through them by hand. I quickly noticed that every 103 seconds, an image started to form, so it didn't take that long to find the tree.
Code
import Data.Maybe
import Text.ParserCombinators.ReadP
import qualified Data.Map.Strict as M
type Coord = (Int, Int)
type Robot = (Coord, Coord)
int :: ReadP Int
int = fmap read $ many1 $ choice $ map char $ '-' : ['0' .. '9']
coord :: ReadP Coord
coord = (,) <$> int <*> (char ',' *> int)
robot :: ReadP Robot
robot = (,) <$> (string "p=" *> coord) <*> (string " v=" *> coord)
robots :: ReadP [Robot]
robots = sepBy robot (char '\n')
simulate :: Coord -> Int -> Robot -> Coord
simulate (x0, y0) t ((x, y), (vx, vy)) =
((x + t * vx) `mod` x0, (y + t * vy) `mod` y0)
quadrant :: Coord -> Coord -> Maybe Int
quadrant (x0, y0) (x, y) = case (compare (2*x + 1) x0, compare (2*y + 1) y0) of
(LT, LT) -> Just 0
(LT, GT) -> Just 1
(GT, LT) -> Just 2
(GT, GT) -> Just 3
_ -> Nothing
freqs :: (Foldable t, Ord a) => t a -> M.Map a Int
freqs = foldr (\x -> M.insertWith (+) x 1) M.empty
solve :: Coord -> Int -> [Robot] -> Int
solve grid t = product . freqs . catMaybes . map (quadrant grid . simulate grid t)
showGrid :: Coord -> [Coord] -> String
showGrid (x0, y0) cs = unlines
[ [if (x, y) `M.member` m then '#' else ' ' | x <- [0 .. x0]]
| let m = M.fromList [(c, ()) | c <- cs]
, y <- [0 .. y0]
]
main :: IO ()
main = do
rs <- fst . last . readP_to_S robots <$> getContents
let g = (101, 103)
print $ solve g 100 rs
sequence_
[ writeFile ("tree_" ++ show t) $ showGrid g $ map (simulate g t) rs
| t <- [0 .. 10000]
]
Haskell, 14 ms. The hardest part was the parser today. I somehow thought that the buttons could have negative values in X or Y too, so it's a bit overcomplicated.
import Text.ParserCombinators.ReadP
int, signedInt :: ReadP Int
int = read <$> (many1 $ choice $ map char ['0' .. '9'])
signedInt = ($) <$> choice [id <$ char '+', negate <$ char '-'] <*> int
machine :: ReadP ((Int, Int), (Int, Int), (Int, Int))
machine = do
string "Button A: X"
xa <- signedInt
string ", Y"
ya <- signedInt
string "\nButton B: X"
xb <- signedInt
string ", Y"
yb <- signedInt
string "\nPrize: X="
x0 <- int
string ", Y="
y0 <- int
return ((xa, ya), (xb, yb), (x0, y0))
machines :: ReadP [((Int, Int), (Int, Int), (Int, Int))]
machines = sepBy machine (string "\n\n")
calc :: ((Int, Int), (Int, Int), (Int, Int)) -> Maybe (Int, Int)
calc ((ax, ay), (bx, by), (x0, y0)) = case
( (x0 * by - y0 * bx) `divMod` (ax * by - ay * bx)
, (x0 * ay - y0 * ax) `divMod` (bx * ay - by * ax)
) of
((a, 0), (b, 0)) -> Just (a, b)
_ -> Nothing
enlarge :: (a, b, (Int, Int)) -> (a, b, (Int, Int))
enlarge (u, v, (x0, y0)) = (u, v, (10000000000000 + x0, 10000000000000 + y0))
solve :: [((Int, Int), (Int, Int), (Int, Int))] -> Int
solve ts = sum
[ 3 * a + b
| Just (a, b) <- map calc ts
]
main :: IO ()
main = do
ts <- fst . last . readP_to_S machines <$> getContents
mapM_ (print . solve) [ts, map enlarge ts]
In case you're wondering what the hell is meant by "organic iron", it's normal inorganic iron sulphides.
You're right, I had it backwards. Hydrostatic equilibrium makes it that the combined force vector of gravity and the centrifugal force is perpendicular to the planet surface everywhere.
view more: next ›
Is this upscaled with AI? It's full of very weird image artifacts.