
gentooer
gentooer@programming.dev
Joined
2 posts • 321 comments
Is this upscaled with AI? It’s full of very weird image artifacts.
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']