 Abhinav's Notes

# Advent of Code 2020 — Week 2

I’m solving the Advent of Code 2020 in the Haskell REPL (GHCi). You can copy the code and paste it in GHCi to play with it. Here are my solutions for week 2 (Dec 6–12):

## Day 6

Solution:

``````import Data.List.Split (splitOn)
import Data.List (nub)
sum \$ map (length . nub . concat) answers -- part 1
import Data.List (intersect)
sum \$ map (length . foldl1 intersect) answers -- part 2
``````

## Day 7

Solution:

``````-- First, a parser framework from (almost) scratch:
:set -XGeneralizedNewtypeDeriving
:set -XLambdaCase
import Control.Applicative (Alternative(..), optional)
:{
newtype Parser i o = Parser { runParser_ :: StateT i (MaybeT Identity) o }
runParser input =
fmap fst . runIdentity . runMaybeT . flip runStateT input . runParser_
satisfy :: (a -> Bool) -> Parser [a] a
satisfy pr = get >>= \case { (c:cs) | pr c -> put cs >> return c; _ -> empty }
lookahead :: Parser [a] (Maybe a)
lookahead = get >>= \case { [] -> return Nothing; (c:_) -> return (Just c) }
consume :: Parser [a] ()
consume = modify tail
:}
char c = satisfy (== c)
string = \case { "" -> pure ""; (c:cs) -> (:) <\$> char c <*> string cs }
import Data.Char (digitToInt, isDigit, isAlpha)
digit = digitToInt <\$> satisfy isDigit
num = foldl1 (\n d -> n * 10 + d) <\$> some digit
space = char ' '
word = some \$ satisfy isAlpha
separatedBy v s = (:) <\$> v <*> many (s *> v) <|> pure []

-- Next, use the parser framework to parse the input:
color = (++) <\$> (word <* space) <*> word
bags = string " bag" <* optional (char 's')
container = color <* bags <* string " contain "
:{
contained = string "no other bags" *> pure []
<|> ((,) <\$> num <*> (space *> color <* bags)) `separatedBy` string ", "
:}
rule = (,) <\$> container <*> contained <* char '.'
rules = rule `separatedBy` char '\n'
Just bagRules <- flip runParser rules <\$> readFile "/tmp/input7"

-- Finally, solve the problem:
import Data.Graph.Wrapper (fromListSimple, transpose, reachableVertices)
colorDeps = transpose . fromListSimple \$ map (fmap \$ map snd) bagRules
length (reachableVertices colorDeps "shinygold") - 1 -- part 1
import Data.Maybe (fromMaybe)
:{
bagCount color =
let colors = fromMaybe [] \$ lookup color bagRules
in sum (map fst colors) + sum (map (\(c, col) -> c * bagCount col) colors)
:}
bagCount "shinygold" -- part 2
``````

## Day 8

Solution:

``````-- First, copy-paste the parser framework from day 7
-- Next, parse the input:
:{
argument = (\s n -> case s of { '-' -> negate n; '+' -> n } )
<\$> (char '+' <|> char '-') <*> num
:}
data Instruction = Acc | Jmp | Nop deriving (Show)
import Data.Functor ((\$>))
instruction = string "acc" \$> Acc <|> string "nop" \$> Nop <|> string "jmp" \$> Jmp
program = ((,) <\$> (instruction <* space) <*> argument) `separatedBy` char '\n'

-- Finally, solve it using an interpreter:
Just input <- flip runParser program <\$> readFile "/tmp/input8"
import qualified Data.Set as Set
:{
interpret seen acc pc = if Set.member pc seen then acc else
let (ins, arg) = input !! pc
seen' = Set.insert pc seen
in case ins of
Nop -> interpret seen' acc (pc + 1)
Acc -> interpret seen' (acc + arg) (pc + 1)
Jmp -> interpret seen' acc (pc + arg)
:}
interpret Set.empty 0 0 -- part 1
:{
interpret' seen acc pc moded
| length input == pc = Right acc
| Set.member pc seen = Left acc
| otherwise = let
(ins, arg) = input !! pc
seen' = Set.insert pc seen
interpretNop = interpret' seen' acc (pc + 1)
interpretJmp = interpret' seen' acc (pc + arg)
in case ins of
Acc -> interpret' seen' (acc + arg) (pc + 1) moded
Nop | moded -> interpretNop True
Nop -> either (const \$ interpretJmp True) Right \$ interpretNop False
Jmp | moded -> interpretJmp True
Jmp -> either (const \$ interpretNop True) Right \$ interpretJmp False
:}
interpret' Set.empty 0 0 False -- part 2
``````

## Day 9

Solution:

``````isValid xs x = x `elem` [ a + b | a <- xs, b <- xs, a /= b ]
:{
findInvalid xs
| null xs = Nothing
| length xs <= 25 = Nothing
| isValid as b = findInvalid (tail xs)
| otherwise = Just b
where (as, (b:_)) = splitAt 25 xs
:}
input <- map read . lines <\$> readFile "/tmp/input9" :: IO [Int]
Just part1 = findInvalid input
:{
sliding [] _ = []
sliding xs size
| length xs >= size = take size xs : sliding (drop 1 xs) size
| otherwise = []
:}
ranges xs = concatMap (sliding xs) [2..(length xs)]
:{
. map (\range -> maximum range + minimum range)
. filter ((== part1) . sum)
. ranges
\$ input
:}
``````

## Day 10

Solution:

``````import Data.List (sort)
input <- (0:) . sort . map read . lines <\$> readFile "/tmp/input10" :: IO [Int]
diffs = 3 : zipWith (-) (tail input) input
count n = length . filter (== n)
count 1 diffs * count 3 diffs -- part 1
sliding xs = if null xs then [] else take 4 xs : sliding (drop 1 xs)
edges = map (\(x:xs) -> (x, [y | y <- xs, y <= x + 3])) \$ sliding input
import Data.Maybe (fromMaybe, fromJust)
import Data.Function (fix)
memoize f = flip lookup (map f input)
:{
arrCount = fix (memoize . go)
where
go f x = if x == goal then (goal, 1)
else (x, sum . map (fromJust . f) . fromMaybe [] \$ lookup x edges)
goal = last input
:}
arrCount 0 -- part 2
``````

## Day 11

Solution:

``````:set -XDeriveFunctor
:set -XLambdaCase
import qualified Data.Sequence as S
import Data.Sequence (Seq(..), (|>), (<|), (><))

-- First, data types for list zipper and celluar automata universe
data Z a = Z (S.Seq a) a (S.Seq a) deriving (Show, Eq, Functor)
newtype Univ a = Univ (Z (Z a)) deriving (Show, Eq, Functor)

-- next, function to move around the universe
zLeft z@(Z l f r) = case l of { S.Empty -> z; xs :|> x -> Z xs x (f <| r) }
zRight z@(Z l f r) = case r of { S.Empty -> z; x :<| xs -> Z (l |> f) x xs }
up (Univ z) = Univ \$ zLeft z
down (Univ z) = Univ \$ zRight z
left (Univ z) = Univ \$ fmap zLeft z
right (Univ z) = Univ \$ fmap zRight z

-- next, functions to measure the universe
zPos (Z l _ _) = S.length l
zLength (Z a _ b) = S.length a + S.length b + 1
uPos (Univ (Z a f _)) = (S.length a, zPos f)
uRowCount (Univ z) = zLength z
uColCount (Univ (Z _ z _)) = zLength z

-- next, functions to convert to and from the universe
:{
toUniv rows =
let (first :<| rest) = fmap (\(cell :<| cells) -> Z S.empty cell cells) rows
in Univ \$ Z S.empty first rest
fromUniv (Univ (Z l f r)) = (fmap toSeq l |> toSeq f) >< fmap toSeq r
where
toSeq (Z l f r) = (l |> f) >< r
:}

-- next, Comonad instances of the list zipper and the universe
:{
extract (Z _ f _) = f
duplicate z = Z l z r
where
l = S.reverse \$ S.iterateN (zPos z) zLeft \$ zLeft z
r = S.iterateN (zLength z - zPos z - 1) zRight \$ zRight z
extract (Univ u) = extract \$ extract u
duplicate u@(Univ univ) = Univ \$ Z l f r
where
uf = extract univ
f = Z fl u fr
fl = S.reverse \$ S.iterateN (zPos uf) left (left u)
fr = S.iterateN (zLength uf - zPos uf - 1) right (right u)
l = S.reverse \$ S.iterateN (zPos univ) (fmap up) (fmap up f)
r = S.iterateN (zLength univ - zPos univ - 1) (fmap down) (fmap down f)
:}

-- next, model the seats
data Seat = Empty | Occupied | Floor deriving (Eq)
instance Show Seat where show = \case { Empty -> "L"; Occupied -> "#"; Floor -> "." }
toSeat = \case { 'L' -> Empty; '.' -> Floor; '#' -> Occupied }

-- next, read and measure the input
:{
input <- S.fromList
. map (S.fromList . map toSeat)
. lines
:}
inputRowCount = S.length input
inputColCount = let (row :<| _) = input in S.length row
validIndex (x, y) = and [x >= 0, y >= 0, x < inputRowCount, y < inputColCount]

-- next, rules for finding neighbours and occupying seats for part 1
:{
neighbours1 grid (x, y) = [
grid `S.index` (x + i) `S.index` (y + j)
| i <- [-1, 0, 1], j <- [-1, 0, 1]
, validIndex (x + i, y + j)
, (x + i, y + j) /= (x, y)
]
rule1 univ = let
ns = neighbours1 (fromUniv univ) \$ uPos univ
f = extract univ
occupied = [() | n <- ns, n == Occupied]
in case f of
Empty | null occupied -> Occupied
Occupied | length occupied >= 4 -> Empty
_ -> f
:}

-- next, run the automata till it settles and count the occupied seats
fix f x = let x' = f x in if x == x' then x else fix f x'
:{
finallyOccupiedSeatCount rule = sum
. fmap (S.length . S.filter (== Occupied))
. fromUniv
. fix (extend rule)
\$ toUniv input
:}

-- finally, count of occupied seats for part 1.
finallyOccupiedSeatCount rule1

-- Next, rules for finding neighbours and occupying seats for part 2
inputDiaCount = ceiling \$ sqrt 2 * fromIntegral (min inputRowCount inputColCount)
:{
neighbours2 grid (x, y) =
map (map (\(x', y') -> grid `S.index` x' `S.index` y')) indices
where
indices = map (filter validIndex) [
[(i, y) | i <- [x-1, x-2 .. 0]]
, [(i, y) | i <- [x+1 .. inputRowCount-1]]
, [(x, j) | j <- [y-1, y-2 .. 0]]
, [(x, j) | j <- [y+1 .. inputColCount-1]]
, [(x+i, y+i) | i <- [1.. inputDiaCount]]
, [(x+i, y-i) | i <- [1.. inputDiaCount]]
, [(x-i, y-i) | i <- [1.. inputDiaCount]]
, [(x-i, y+i) | i <- [1.. inputDiaCount]]
]
rule2 univ = let
nss = neighbours2 (fromUniv univ) \$ uPos univ
f = extract univ
occupied = [() | ns <- nss, take 1 (dropWhile (== Floor) ns) == [Occupied]]
in case f of
Empty | null occupied -> Occupied
Occupied | length occupied >= 5 -> Empty
_ -> f
:}

-- and, count of occupied seats for part 2
finallyOccupiedSeatCount rule2
``````

## Day 12

Solution:

``````:set -XLambdaCase
:{
input <- map (\(x:xs) -> (x, read xs))
. lines <\$> readFile "/tmp/input12" :: IO [(Char, Double)]
:}
radian deg = deg / 180 * pi
:{
run1 ((x, y), deg) = \case
('N', del) -> ((x, y + del), deg)
('S', del) -> ((x, y - del), deg)
('E', del) -> ((x + del, y), deg)
('W', del) -> ((x - del, y), deg)
('L', del) -> ((x, y), (deg + del))
('R', del) -> ((x, y), (deg - del))
('F', del) -> ((x + del * cos (radian deg), y + del * sin (radian deg)), deg)
:}
let ((x, y), _) = foldl run1 ((0, 0), 0) input in abs x + abs y -- part 1

:{
run2 (pos@(x, y), wp@(wx, wy)) = \case
('N', del) -> (pos, (wx, wy + del))
('S', del) -> (pos, (wx, wy - del))
('E', del) -> (pos, (wx + del, wy))
('W', del) -> (pos, (wx - del, wy))
('L', del) -> (pos, rotate (radian del))
('R', del) -> (pos, rotate (- (radian del)))
('F', del) -> ((x + wx * del, y + wy * del), wp)
where
rotate del = (wx * cos del - wy * sin del, wy * cos del + wx * sin del)
:}
let ((x, y), _) = foldl run2 ((0, 0), (10, 1)) input in abs x + abs y -- part 2
``````