Abhinav's Notes

# Advent of Code 2020 — Week 4

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 4 (Dec 20–25):

## Day 20

Solution:

``````:set -XLambdaCase
import qualified Data.Array.BitArray as BA
c2b = \case { '#' -> True; _ -> False }
b2c = \case { True -> '•'; False -> ' ' }
data Tile = Tile { tId :: Int, tSize :: Int, tArr :: BA.BitArray (Int, Int) }
import Data.List (intercalate, intersperse, delete)
import Data.Function (on)
:{
instance Show Tile where
show (Tile _ size tile) = intercalate "\n" [
intersperse ' ' [b2c \$ tile BA.! (i, j) | j <- [0..size-1]] | i <- [0..size-1]]
instance Eq Tile where
(==) = (==) `on` tId
readTile id ti = let size = length ti
in Tile id size . BA.listArray ((0,0), (size-1, size-1)) . map c2b . concat \$ ti
:}
:{
transform f (Tile id size tile) =
Tile id size \$ BA.ixmap (BA.bounds tile) (f size) tile
transforms = [ id
, transform \$ \s (x, y) -> (s-1-x, y)
, transform \$ \s (x, y) -> (x, s-1-y)
, transform \$ \s (x, y) -> (s-1-x, s-1-y)
, transform \$ \_ (x, y) -> (y, x)
, transform \$ \s (x, y) -> (s-1-y, x)
, transform \$ \s (x, y) -> (y, s-1-x)
, transform \$ \s (x, y) -> (s-1-y, s-1-x)
]
:}
import qualified Data.Map.Strict as Map
import Data.List.Split (splitOn)
:{
tiles <- map ((\(x:xs) -> readTile (read . take 4 . drop 5 \$ x) xs) . lines)
. init . splitOn "\n\n" <\$> readFile "/tmp/input20" :: IO [Tile]
:}
gridSize = floor . sqrt . fromIntegral . length \$ tiles
tileSize = tSize \$ head tiles

topBorder (Tile _ size tile) = [tile BA.! (0,j) | j <- [0..size-1]]
bottomBorder (Tile _ size tile) = [tile BA.! (size-1,j) | j <- [0..size-1]]
leftBorder (Tile _ size tile) = [tile BA.! (i,0) | i <- [0..size-1]]
rightBorder (Tile _ size tile) = [tile BA.! (i,size-1) | i <- [0..size-1]]
matchLeftBorder leftTile tile = rightBorder leftTile == leftBorder tile
matchTopBorder topTile tile = bottomBorder topTile == topBorder tile
:{
solve :: [Tile] -> Map.Map (Int, Int) Tile
solve tiles = head \$ solve' 0 Map.empty tiles
where
solve' _ grid [] = return grid
solve' count grid tiles = do
let (row, col) = count `divMod` gridSize
leftTile = grid Map.! (row, col-1)
topTile = grid Map.! (row-1, col)
tile <- tiles
tTile <- map (\$ tile) transforms
guard \$ case (row, col) of
(0, 0) -> True
(0, _) -> matchLeftBorder leftTile tTile
(_, 0) -> matchTopBorder topTile tTile
_  ->  matchLeftBorder leftTile tTile && matchTopBorder topTile tTile
solve' (count + 1) (Map.insert (row, col) tTile grid) (delete tile tiles)
:}
grid = solve tiles
:{
part1 = product . map (tId . (grid Map.!)) \$
[(0, 0), (0, gridSize-1), (gridSize-1, 0), (gridSize-1, gridSize-1)]
:}

:{
removeBorder (Tile id size tile) =
[((x-1,y-1), b) | ((x,y), b) <- BA.assocs tile
, x /= 0, y /= 0, x /= size - 1, y /= size - 1]
:}
newTileSize = tileSize - 2
imageSize = gridSize * newTileSize
:{
removeBorderAndReindex ((x,y), tile) =
map (\((x',y'), b) -> ((x * newTileSize + x', y * newTileSize + y'), b))
\$ removeBorder tile
image = Tile 0 imageSize . BA.array ((0,0),(imageSize - 1, imageSize - 1))
\$ concatMap removeBorderAndReindex
\$ Map.assocs grid
:}
:{
monster = [ "                  # "
, "#    ##    ##    ###"
, " #  #  #  #  #  #   " ]
:}
monWidth = length monster
monLength = length \$ head monster
:{
cutouts (Tile _ size tile) = [
[tile BA.! (i + si, j + sj) | i <- [0..monWidth-1], j <- [0..monLength-1]]
| si <- [0 .. size - monWidth - 2], sj <- [0 .. size - monLength - 2]]
:}
monsterSig = map c2b \$ concat monster
matchMonsterSig = (== monsterSig) . zipWith (&&) monsterSig
:{
(imageWithMonster, monsterCount) = head . filter ((> 1) . snd)
. map (\transform -> let tImage = transform image
in (tImage, length . filter matchMonsterSig . cutouts \$ tImage))
\$ transforms
:}
monsterBodySize = length \$ filter id monsterSig
part2 = BA.popCount (tArr imageWithMonster) - monsterBodySize * monsterCount
``````

## Day 21

Solution:

``````import qualified Text.ParserCombinators.ReadP as P
import Data.Char (isAlpha)
import qualified Data.Map.Strict as Map
import Data.List (intersect, nub)
data Food = Food { fIngs :: [String], fAlrs :: [String] } deriving (Show)
word = P.many1 (P.satisfy isAlpha)
:{
foodP = Food
<\$> (word `P.sepBy` P.char ' ')
<*> (P.string " (contains "
*> (word `P.sepBy` P.string ", ")
<* P.char ')' <* P.eof)
:}
foods <- map parse . lines <\$> readFile "/tmp/input21"
:{
alrToIngsMap = foldl
(\m (Food ings alrs) ->
foldl (\m' alr -> Map.insertWith intersect alr ings m') m alrs)
Map.empty foods
:}
ingsWithAlrs = nub \$ concat \$ Map.elems alrToIngsMap
length \$ filter (`notElem` ingsWithAlrs) \$ concat \$ map fIngs foods -- part 1

import Data.List (sortBy, intercalate, (\\))
import Data.Ord (comparing)
:{
prune possibilities =
if all (== 1) . map length \$ Map.elems possibilities
else let fixedPossibilities =
concat \$ Map.elems \$ Map.filter ((== 1) . length) possibilities
prunedPossibilities = flip Map.map possibilities \$ \ings ->
if length ings == 1 then ings else ings \\ fixedPossibilities
in prune prunedPossibilities
:}
-- part 2
intercalate "," . map snd . sortBy (comparing fst) . Map.assocs \$ prune alrToIngsMap
``````

## Day 22

Solution:

``````:{
playCombat [] p2 = p2
playCombat p1 [] = p1
playCombat (x:xs) (y:ys) = if x > y
then playCombat (xs ++ [x,y]) ys
else playCombat xs (ys ++ [y,x])
:}
import Data.List.Split (splitOn)
:{
[player1, player2] <- map (map read . tail . lines) . splitOn "\n\n"
<\$> readFile "/tmp/input22" :: IO [[Int]]
:}
cards = playCombat player1 player2
sum \$ zipWith (*) (reverse cards) [1..] -- part 1

import qualified Data.Set as Set
:{
playRecCombat _ [] p2 = Right p2
playRecCombat _ p1 [] = Left p1
playRecCombat seen p1@(x:xs) p2@(y:ys)
| Set.member (p1, p2) seen = Left p1
| x <= length xs && y <= length ys =
case playRecCombat Set.empty (take x xs) (take y ys) of
Left _ -> playRecCombat seen' (xs ++ [x,y]) ys
Right _ -> playRecCombat seen' xs (ys ++ [y,x])
| x > y = playRecCombat seen' (xs ++ [x,y]) ys
| otherwise = playRecCombat seen' xs (ys ++ [y,x])
where
seen' = Set.insert (p1, p2) seen
:}
cards = either id id \$ playRecCombat Set.empty player1 player2
sum \$ zipWith (*) (reverse cards) [1..] -- part 2
``````

## Day 23

Solution:

``````import Data.List (sortOn)
:{
. filter (`notElem` picks)
. tail
. dropWhile (> current)
. cycle
\$ sortOn negate left
play (x:xs) = let
(picks, left) = (take 3 xs, x:drop 3 xs)
d = dest picks left
(a,b) = span (/= d) left
in tail a ++ [d] ++ picks ++ tail b ++ if not (null a) then [head a] else []
:}
input = [3,2,6,5,1,9,4,7,8]
:{
part1 = take (length input - 1)
. drop 1
. dropWhile (/= 1)
. cycle
\$ iterate play input !! 100
:}

input = [3,2,6,5,1,9,4,7,8] ++ [10..1000000] :: [Int]
import qualified Data.Vector.Primitive.Mutable as MV
cups <- MV.new 1000001 :: IO (MV.IOVector Int)
forM_ (zip input \$ tail input ++ [head input]) \$ uncurry (MV.unsafeWrite cups)

import Data.List ((\\))
:{
dest :: Int -> [Int] -> Int
dest current picks
| d < min' = max'
| d `notElem` picks = d
| otherwise = dest d picks
where
d = current - 1
max' = maximum \$ [999997,999998,999999,1000000] \\ picks
min' = minimum \$ [1,2,3,4] \\ picks

play :: Int -> Int -> IO Int
play 0 _ = do
return \$ a * b
play n current = do
let d = dest current [a,b,c]
MV.unsafeWrite cups d a
MV.unsafeWrite cups c dnext
MV.unsafeWrite cups current cnext
play (n - 1) cnext
:}
play 10000000 3 -- part 2
``````

## Day 24

Solution:

``````:set -XLambdaCase
data Dir = E | W | NW | NE | SW | SE deriving Show
import Data.Functor ((\$>))
import Control.Applicative ((<|>))
:{
parser =  P.string "nw" \$> NW
<|> P.string "sw" \$> SW
<|> P.string "ne" \$> NE
<|> P.string "se" \$> SE
<|> P.char 'e' \$> E
<|> P.char 'w' \$> W
:}
tileDirs <- map parse . lines <\$> readFile "/tmp/input24"
:{
interpret :: (Int, Int, Int) -> Dir -> (Int, Int, Int)
interpret (x, y, z) = \case
E -> (x+1,y+1,z)
W -> (x-1,y-1,z)
NE -> (x,y+1,z+1)
SW -> (x,y-1,z-1)
NW -> (x-1,y,z+1)
SE -> (x+1,y,z-1)
:}
tileCos = map (foldl interpret (0,0,0)) tileDirs
import qualified Data.Map.Strict as M
flipCounts = foldl (\m c -> M.insertWith (+) c 1 m) M.empty tileCos
length \$ M.filter odd \$ flipCounts -- part 1

data Color = White | Black deriving (Show, Eq, Ord)
start = M.map (\x -> if odd x then Black else White) flipCounts
neighbours point = map (interpret point) [E, W, NW, NE, SW, SE]
import Data.Maybe (fromMaybe)
tileColor tile = fromMaybe White . M.lookup tile
import qualified Data.Set as S
:{
day tiles = M.fromSet step
\$ foldl (\s -> S.union s . S.fromList . neighbours) (M.keysSet tiles)
\$ M.keys tiles
where
step tile = let
neighbourColors = map (`tileColor` tiles) \$ neighbours tile
blackNeighbourCount = length \$ filter (== Black) neighbourColors
in case tileColor tile tiles of
White | blackNeighbourCount == 2 -> Black
Black | blackNeighbourCount == 0 || blackNeighbourCount > 2 -> White
color -> color
:}
length \$ M.filter (== Black) \$ iterate day start !! 100 -- part 2
``````

## Day 25

Solution:

``````:set -XLambdaCase
:set -XStrict
transform s v = \case { 0 -> v; n -> transform s ((v * s) `mod` 20201227) \$ n - 1 }
findLoopSize t n v = if v == t then n else findLoopSize t (n+1) \$ v * 7 `mod` 20201227
input = [11562782, 18108497]
transform (input !! 1) 1 \$ findLoopSize (input !! 0) 0 1 -- part 1
``````

And, that’s a wrap!