Advent of Code 2020 — Week 3

import Data.List.Split (splitOn)
input <- lines <$> readFile "/tmp/input13"
startT = read (input !! 0) :: Int
busIds =  map read . filter (/= "x") . splitOn "," $ input !! 1 :: [Int]
:{
(t, busId) =
  head [ (x, busId) | x <- [startT..], busId <- busIds, x `mod` busId == 0 ]
:}
(t - startT) * busId -- part 1
import Data.Maybe (catMaybes)
:{
busIds@((_,jump):_) = catMaybes
  . zipWith (\i x -> if x == "x" then Nothing else Just $ (i, read x)) [0..]
  . splitOn ","
  $ input !! 1 :: [(Int, Int)]
:}
:{
step (jump, t) (inc, bid) =
  ( jump * bid
  , head [ t' | i <- [1..], let t' = t + jump * i, (t' + inc) `mod` bid == 0 ] )
:}
snd $ foldl step (jump, 0) $ tail busIds -- part 2

-- First, copy-paste the parser framework from day 7
-- Next, parse the input:
data Ins = SetMask String | SetMem Int Int deriving (Show)
mask = SetMask <$> (string "mask = " *> some (char 'X' <|> char '1' <|> char '0'))
mem = SetMem <$> (string "mem[" *> num) <*> (string "] = " *> num)
program = (mask <|> mem) `separatedBy` char '\n'
Just prog <- flip runParser program <$> readFile "/tmp/input14"

-- Next, solve the problem:
import qualified Data.IntMap.Strict as M
import Data.Bits (setBit, clearBit, testBit)
SetMask startMask = head prog
:{
run1 (mask, mem) = \case
  SetMask mask' -> (mask', mem)
  SetMem index value -> (mask, M.insert index (applyMask value) mem)
  where
    applyMask value = foldl overrideBits value bitsToSet
    bitsToSet = filter ((/= 'X') . snd) . zip [0..] $ reverse mask
    overrideBits x (i, b) = if b == '0' then clearBit x i else setBit x i
:}
runProg run = sum . M.elems . snd . foldl run (startMask, M.empty) $ tail prog
runProg run1 -- part 1

:{
float = \case { 'X' -> ['1', '0']; x -> [x] }
expand [x] = [[x'] | x' <- float x]
expand (x:xs) = [(x':xs') | xs' <- expand xs, x' <- float x]

run2 (mask, mem) = \case
  SetMask mask' -> (mask', mem)
  SetMem index value ->
    (mask, foldl (\m i -> M.insert i value m) mem $ applyMask index)
  where
    applyMask = map fromBitString
      . expand
      . zipWith (\m b -> if m == '0' then b else m) mask
      . toBitString
    toBitString x = map (\i -> if testBit x i then '1' else '0') [35,34..0]
    fromBitString = foldl (\x (i, b) -> if b == '1' then setBit x i else x) 0
      . zip [0..]
      . reverse
:}
runProg run2 -- part 2

:set -XLambdaCase
:set -XStrict
import qualified Data.Vector.Unboxed.Mutable as V
import Control.Monad (forM_)
:{
play lastSaid (now:rest) n lastSaidTime =
  if n == now
  then return lastSaid
  else do
    lt <- V.read lastSaidTime lastSaid
    V.write lastSaidTime lastSaid (now - 1)
    if lt == -1
      then play 0 rest n lastSaidTime
      else play (now - 1 - lt) rest n lastSaidTime
:}
input = [8,13,1,0,18,9]
start = length input + 1
lastSaidTime <- V.replicate 2020 (-1) :: IO (V.IOVector Int)
forM_ (zip input [1..]) $ \(x, i) -> V.write lastSaidTime x i
play (last input) [start..] 2021 lastSaidTime >>= print -- part1

lastSaidTime <- V.replicate 30000000 (-1) :: IO (V.IOVector Int)
forM_ (zip input [1..]) $ \(x, i) -> V.write lastSaidTime x i
play (last input) [start..] 30000001 lastSaidTime >>= print -- part2

-- First, copy-paste the parser framework from day 7
-- Next, parse the input:
import Data.List.Split (splitOn)
input <- splitOn "\n\n" <$> readFile "/tmp/input16"
fieldValP = (,) <$> (num <* char '-') <*> num
fieldValsP = fieldValP `separatedBy` string " or "
fieldNameP = word `separatedBy` space
:{
fieldSpecP = (\name val -> (concat name, val))
  <$> (fieldNameP <* string ": ") <*> fieldValsP
:}
fieldSpecsP = fieldSpecP `separatedBy` char '\n'
Just fieldSpecs = runParser (input !! 0) fieldSpecsP
myTicket = map read . splitOn "," . (!! 1). lines $ input !! 1 :: [Int]
nearbyTickets = map (map read . splitOn ",") . tail . lines $ (input !! 2) :: [[Int]]

-- Next, solve the problem:
:{
invalidFields = filter $ \val ->
  not $ any (\(_, ranges) -> any (\(x, y) -> val >= x && val <= y) ranges) fieldSpecs
:}
sum $ concatMap invalidFields nearbyTickets -- part 1

validNearbyTickets = filter (null . invalidFields) nearbyTickets
import Data.List (transpose, nub, isPrefixOf)
:{
fieldPossibilities = zip [0..]
  . map (\vals -> nub . map fst $ filter (allValsInRange vals) fieldSpecs)
  $ transpose validNearbyTickets
  where
    allValsInRange vals (name, ranges) =
      all (\val -> any (\(x, y) -> val >= x && val <= y) ranges) vals
prune possibilities =
  if sum (map (length . snd) possibilities) == length possibilities
  then map (fmap head) possibilities
  else let fixedPossibilities = filter ((== 1) . length . snd) possibilities
           prunedPossibilities = flip map possibilities $ \(id, fns) ->
             if id `elem` map fst fixedPossibilities
             then (id, fns)
             else (id, filter (`notElem` concatMap snd fixedPossibilities) fns)
       in prune prunedPossibilities
part2 = product
  . map ((myTicket !!) . fst)
  . filter (("departure" `isPrefixOf`) . snd)
  $ prune fieldPossibilities
:}

-- run with  +RTS -H8g -A64m -n4m -s -qg0 -N
module Main where

import Control.Comonad (Comonad(..))
import Data.List (foldl')

data Z a = Z [a] a [a]

zLeft, zRight :: Z a -> Z a
zLeft ~(Z (x:xs) f r) = Z xs x (f:r)
zRight ~(Z l f (x:xs)) = Z (f:l) x xs

iterate1 :: (a -> a) -> a -> [a]
iterate1 f = tail . iterate f

instance Functor Z where
  fmap f (Z l a r) = Z (fmap f l) (f a) (fmap f r)

instance Comonad Z where
  extract (Z _ f _) = f
  duplicate z = Z (iterate1 zLeft z) z (iterate1 zRight z)

newtype Z2 a = Z2 (Z (Z a))

z2Up, z2Down, z2Left, z2Right :: Z2 a -> Z2 a
z2Up (Z2 z) = Z2 (zLeft z)
z2Down (Z2 z) = Z2 (zRight z)
z2Left (Z2 z) = Z2 (fmap zLeft z)
z2Right (Z2 z) = Z2 (fmap zRight z)

instance Functor Z2 where
  fmap f (Z2 z) = Z2 (fmap (fmap f) z)

instance Comonad Z2 where
  extract (Z2 z) = extract . extract $ z
  duplicate = Z2 . fmap horizontal . vertical
    where
      horizontal z = Z (iterate1 z2Left z) z (iterate1 z2Right z)
      vertical z = Z (iterate1 z2Up z) z (iterate1 z2Down z)

newtype Z3 a = Z3 (Z (Z2 a))

z3Backward, z3Forward, z3Up, z3Down, z3Left, z3Right :: Z3 a -> Z3 a
z3Backward (Z3 z) = Z3 (zLeft z)
z3Forward (Z3 z) = Z3 (zRight z)
z3Up (Z3 z) = Z3 (fmap z2Up z)
z3Down (Z3 z) = Z3 (fmap z2Down z)
z3Left (Z3 z) = Z3 (fmap z2Left z)
z3Right (Z3 z) = Z3 (fmap z2Right z)

instance Functor Z3 where
  fmap f (Z3 z) = Z3 (fmap (fmap f) z)

instance Comonad Z3 where
  extract (Z3 z) = extract . extract $ z
  duplicate = Z3 . fmap (Z2 . fmap horizontal . vertical) . depthical
    where
    horizontal z = Z (iterate1 z3Left z) z (iterate1 z3Right z)
    vertical z = Z (iterate1 z3Up z) z (iterate1 z3Down z)
    depthical z = Z (iterate1 z3Backward z) z (iterate1 z3Forward z)

data State = Active | Inactive deriving (Show, Eq)

readInput :: [String] -> [[State]]
readInput = map (map (\x -> case x of {'.'  -> Inactive; ~'#' -> Active}))

inactiveLine :: Z State
inactiveLine = Z (repeat Inactive) Inactive (repeat Inactive)

inactivePlain :: Z2 State
inactivePlain = Z2 $ Z (repeat inactiveLine) inactiveLine (repeat inactiveLine)

inputTo3dGrid :: [[State]] -> Z3 State
inputTo3dGrid input = let
    zs = map (\(x:xs) -> Z (repeat Inactive) x (xs ++ repeat Inactive)) input
    z2 = Z2 $ Z (repeat inactiveLine) (head zs) (tail zs ++ repeat inactiveLine)
  in Z3 $ Z (repeat inactivePlain) z2 (repeat inactivePlain)

mkMove :: (a -> a) -> (a -> a) -> Int -> a -> a
mkMove awayMove closeMove n
  | n == 0 = id
  | n < 0 = applyNTimes (abs n) awayMove
  | otherwise = applyNTimes n closeMove
  where
    applyNTimes n' f = foldr (.) id (replicate n' f)

to3dMove :: (Int, Int, Int) -> (Z3 a -> Z3 a)
to3dMove (x, y, z) =
  mkMove z3Left z3Right x
  . mkMove z3Up z3Down y
  . mkMove z3Backward z3Forward z

scanPoint :: Comonad w => w State -> Int
scanPoint grid = case extract grid of { Active -> 1; Inactive -> 0 }

scan :: Int -> (w a -> Int) -> (w a -> w a) -> w a -> Int
scan n lowerDimScanner move grid = fst $
  foldl' (\(activeCount, g) _ -> (lowerDimScanner g + activeCount, move g))
    (0, grid) [0..n-1]

scanVolume :: Int -> Z3 State -> Int
scanVolume n = scan n (scan n (scan n scanPoint z3Right) z3Down) z3Forward

neighbours3d :: (Int, Int) -> Z3 State -> Int
neighbours3d (start, end) =
  scanVolume (end - start + 1) . to3dMove (start, start, start)

type ActiveCount w = w State -> Int
type Rule w = w State -> State

mkRule :: Comonad w => ActiveCount w -> Rule w
mkRule activeCount grid =
  let focus = extract grid
      activeNs = activeCount grid - if focus == Active then 1 else 0
  in case focus of
    Active -> if activeNs `elem` [2, 3] then Active else Inactive
    Inactive -> if activeNs == 3 then Active else Inactive

simulate :: Comonad w => Int -> (w a -> a) -> w a -> w a
simulate cycles rule = (!! cycles) . iterate (extend rule)

finalActiveCount :: Comonad w => Int -> Rule w -> ActiveCount w -> w State -> Int
finalActiveCount cycles rule activeCount = activeCount . simulate cycles rule

newtype Z4 a = Z4 (Z (Z3 a))

z4Outward, z4Inward, z4Backward, z4Forward, z4Up, z4Down, z4Left, z4Right ::
  Z4 a -> Z4 a
z4Outward (Z4 z) = Z4 (zLeft z)
z4Inward (Z4 z) = Z4 (zRight z)
z4Backward (Z4 z) = Z4 (fmap z3Backward z)
z4Forward (Z4 z) = Z4 (fmap z3Forward z)
z4Up (Z4 z) = Z4 (fmap z3Up z)
z4Down (Z4 z) = Z4 (fmap z3Down z)
z4Left (Z4 z) = Z4 (fmap z3Left z)
z4Right (Z4 z) = Z4 (fmap z3Right z)

instance Functor Z4 where
  fmap f (Z4 z) = Z4 (fmap (fmap f) z)

instance Comonad Z4 where
  extract (Z4 z) = extract . extract $ z
  duplicate =
    Z4 . fmap (Z3 . fmap (Z2 . fmap horizontal . vertical) . depthical) . enclosical
    where
      horizontal z = Z (iterate1 z4Left z) z (iterate1 z4Right z)
      vertical z = Z (iterate1 z4Up z) z (iterate1 z4Down z)
      depthical z = Z (iterate1 z4Backward z) z (iterate1 z4Forward z)
      enclosical z = Z (iterate1 z4Outward z) z (iterate1 z4Inward z)

inputTo4dGrid :: [[State]] -> Z4 State
inputTo4dGrid input = let
    z3 = inputTo3dGrid input
    inactiveVolume =
      Z3 $ Z (repeat inactivePlain) inactivePlain (repeat inactivePlain)
  in Z4 $ Z (repeat inactiveVolume) z3 (repeat inactiveVolume)

to4dMove :: (Int, Int, Int, Int) -> (Z4 a -> Z4 a)
to4dMove (x, y, z, w) = mkMove z4Left z4Right x
  . mkMove z4Up z4Down y
  . mkMove z4Backward z4Forward z
  . mkMove z4Outward z4Inward w

scanHyperVolume :: Int -> Z4 State -> Int
scanHyperVolume n =
  scan n(scan n (scan n (scan n scanPoint z4Right) z4Down) z4Forward) z4Inward

neighbours4d :: (Int, Int) -> Z4 State -> Int
neighbours4d (start, end) =
  scanHyperVolume (end - start + 1) . to4dMove (start, start, start, start)

main :: IO ()
main = do
  let input = [ "..##.#.#"
              , ".#####.."
              , "#.....##"
              , "##.##.#."
              , "..#...#."
              , ".#..##.."
              , ".#...#.#"
              , "#..##.##"
              ]
      initialGridSize = length $ head input
      states = readInput input
      cycles = 6
      neighbours3d1 = neighbours3d (-1, 1)
      neighbours3dFinal = neighbours3d (-cycles, initialGridSize + cycles)
      neighbours4d1 = neighbours4d (-1, 1)
      neighbours4dFinal = neighbours4d (-cycles, initialGridSize + cycles)

  print
    $ finalActiveCount cycles (mkRule neighbours3d1) neighbours3dFinal
    $ inputTo3dGrid states
  print
    $ finalActiveCount cycles (mkRule neighbours4d1) neighbours4dFinal
    $ inputTo4dGrid states

-- First, copy-paste the parser framework from day 7
-- Next, write a tokenizer for the input:
import Data.Functor (($>))
data Token = Num Int | Plus | Mult | LeftParen | RightParen | Eof deriving (Show, Eq)
:{
tokenizer' = lookahead >>= \case
  Nothing -> pure Eof
  Just c -> case c of
    '(' -> consume $> LeftParen
    ')' -> consume $> RightParen
    '+' -> consume $> Plus
    '*' -> consume $> Mult
    _ -> Num <$> num
tokenizer = do
  t <- many space *> tokenizer' <* many space
  case t of
    Eof -> return [Eof]
    _   -> (t:) <$> tokenizer
tokenize = flip runParser tokenizer
:}

-- Next, write a parser for the tokens:
data Expr = Literal Int | Binary Expr Token Expr | Grouping Expr deriving (Show)
import Data.Function (fix)
:{
binary ops parser = parser >>= loop
  where
    loop e = lookahead >>= \case
      Just op | op `elem` ops -> consume >> parser >>= loop . (Binary e op)
      _ -> return e
primary expr = lookahead >>= \case
  Just (Num n) -> consume >> return (Literal n)
  Just LeftParen -> grouping expr
grouping expr = consume *> expr <* consume
expr1 = fix $ binary [Plus, Mult] . primary
:}

-- Next, write an interpreter for the expression:
:{
interpret = \case
  Literal n -> n
  Grouping e -> interpret e
  Binary e1 Plus e2 -> interpret e1 + interpret e2
  Binary e1 Mult e2 -> interpret e1 * interpret e2
:}
import Control.Monad ((>=>))
evaluate parser = tokenize >=> flip runParser parser >=> return . interpret
input <- lines <$> readFile "/tmp/input18"
inputSum expr = fmap sum . traverse (evaluate expr) $ input
inputSum expr1 -- part 1

-- Write a new parser for the input:
expr2 = fix $ binary [Mult] . binary [Plus] . primary
inputSum expr2 -- part 2

import qualified Text.ParserCombinators.ReadP as P
import Data.Char (isDigit, isAlpha)
import Control.Applicative ((<|>))
import Data.List (foldl1)
import Data.Maybe (fromJust)
data R = R :>: R | R :|: R | C Char | I Int deriving (Show)
ruleId = read <$> P.many1 (P.satisfy isDigit) :: P.ReadP Int
char = C <$> (P.char '"' *> P.satisfy isAlpha <* P.char '"')
id = I <$> ruleId
after = foldl1 (:>:) <$> id `P.sepBy` P.char ' '
or = (:|:) <$> after <*> (P.string " | " *> after)
rule = (,) <$> (ruleId <* P.string ": ") <*> ((or <|> after <|> id <|> char) <* P.eof)
parse parser = fst . head . P.readP_to_S parser
import Data.List.Split (splitOn)
[ruls, msgs] <- splitOn "\n\n" <$> readFile "/tmp/input19"
rules = map (parse rule) . lines $ ruls
:{
mkParser rules r = case r of
  C c -> P.char c
  I id -> mkParser rules . fromJust $ lookup id rules
  r1 :>: r2 -> mkParser rules r1 >> mkParser rules r2
  r1 :|: r2 -> mkParser rules r1 <|> mkParser rules r2

match rules inp = case P.readP_to_S (mkParser rules (I 0) <* P.eof) inp of
  [(_, "")] -> True
  _ -> False
:}
length $ filter (match rules) $ lines msgs -- part 1

newRules = ["8: 42 | 42 8", "11: 42 31 | 42 11 31"]
rules' = map (parse rule) newRules ++ rules
length $ filter (match rules') $ lines msgs -- part 2