gentooer
joined 1 year ago
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.
This. Planets are in hydrostatic equilibrium, meaning that the combined acceleration by gravity and the centrifugal "force" is equal all over the world (except for local differences due to mountains and dense crust).
The Russian ΠΉ (e.g. the last letter in the name Sergei) is a semivowel, the only one in the Russian alphabet.
view more: next βΊ
Naked Capitalism is a known mouthpiece for Russian propaganda (example).