gentooer

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

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

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

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

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']

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]
        ]