Advent of Code 2020 — Week 4

: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
import Control.Monad (guard)
:{
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

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)
:}
parse = fst . head . P.readP_to_S foodP
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
  then Map.map head 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

:{
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

import Data.List (sortOn)
:{
dest picks left@(current:rest) = head
  . 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
import Control.Monad (forM_)
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
  a <- MV.unsafeRead cups 1
  b <- MV.unsafeRead cups a
  return $ a * b
play n current = do
  a <- MV.unsafeRead cups current
  b <- MV.unsafeRead cups a
  c <- MV.unsafeRead cups b
  let d = dest current [a,b,c]
  dnext <- MV.unsafeRead cups d
  cnext <- MV.unsafeRead cups 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

:set -XLambdaCase
import qualified Text.ParserCombinators.ReadP as P
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
:}
parse = fst . head . P.readP_to_S (P.many1 parser <* P.eof)
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

: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