source code
{-# LANGUAGE ImportQualifiedPost, TypeApplications #-}
-- SPDX-License-Identifier: ISC
-- Copyright (c) 2021 Paolo Martini <mrtnpaolo@protonmail.com>
module Main (main) where
import Data.Char (digitToInt)
import Data.List qualified as L
import Data.Set qualified as S
import Data.Map.Strict qualified as M'
import Data.List (foldl')
import Data.Map.Strict qualified as M' (toAscList,fromListWith)
import Data.Ix
import GHC.Arr
import Data.Map (Map)
import Data.Map qualified as M
import Data.Foldable (toList)
main =
do inp <- getInput parse 11
print (part2 inp)
where
parse = M'.fromList . withCoords digitToInt . lines
normalize = M'.map (\x -> if x > 9 then 0 else x)
step m = (flashes,normalize final)
where
m' = M'.map succ m
flashing = M'.keysSet (M'.filter (> 9) m')
(flashes,final) = extend S.empty flashing m'
extend seen flashing m
| S.null flashing = (S.size seen,m)
| otherwise = extend seen' flashing' m'
where
seen' = S.union seen flashing
m' = L.foldl' increaseAdjacents m (S.toList flashing)
flashing' = S.difference (M'.keysSet (M'.filter (> 9) m')) seen'
increaseAdjacents m c = L.foldl' (\m c -> M'.adjust succ c m) m (neighbors c)
part2 m = i
where
flashes = L.unfoldr (Just . step) m
Just i = L.elemIndex (M'.size m) (0 : flashes)
-- Utilities
getInput :: (String -> a) -> Int -> IO a
getInput parse day = parse <$> getContents
count :: (a -> Bool) -> [a] -> Int
count p xs = foldl' f 0 xs
where
f n x | p x = n+1 | otherwise = n
freqs :: (Ord a) => [a] -> [(a,Int)]
freqs xs = combine [ (x,1) | x <- xs ]
where
combine = M'.toAscList . M'.fromListWith (+)
-- -----------------
-- Coord
-- | Row-major coordinates
data Coord = C !Int !Int
deriving (Read, Show, Eq, Ord)
origin, north, east, south, west :: Coord
origin = C 0 0
north = C (-1) 0
east = C 0 1
south = C 1 0
west = C 0 (-1)
coordRow, coordCol :: Coord -> Int
coordRow (C row _) = row
coordCol (C _ col) = col
invert :: Coord -> Coord
invert (C y x) = C x y
above, right, below, left :: Coord -> Coord
above (C y x) = C (y-1) x
right (C y x) = C y (x+1)
below (C y x) = C (y+1) x
left (C y x) = C y (x-1)
turnLeft, turnRight, turnAround :: Coord -> Coord
turnLeft (C y x) = C (-x) y
turnRight (C y x) = C x (-y)
turnAround (C y x) = C (-y) (-x)
cardinal :: Coord -> [Coord]
cardinal c = c `seq`
[above c, right c, below c, left c]
neighbors :: Coord -> [Coord]
neighbors c = c `seq`
[ above c, left c, right c, below c
, above (left c), above (right c)
, below (left c), below (right c) ]
bookreading :: Coord -> [Coord]
bookreading c = c `seq`
[ above (left c), above c, above (right c)
, left c , c , right c
, below (left c), below c, below (right c) ]
manhattan :: Coord -> Coord -> Int
manhattan (C y x) (C v u) = abs (y-v) + abs (x-u)
addCoord :: Coord -> Coord -> Coord
addCoord (C y x) (C v u) = C (y+v) (x+u)
scaleCoord :: Int -> Coord -> Coord
scaleCoord n (C y x) = C (n*y) (n*x)
instance Ix Coord where
unsafeIndex (C ym xm,C _yM xM) (C y x) =
(y - ym) * (xM - xm + 1) + (x - xm)
inRange (C ym xm,C yM xM) (C y x) =
ym <= y && y <= yM && xm <= x && x <= xM
range (C ym xm,C yM xM) =
[ C y x | y <- [ym,ym+1..yM], x <- [xm,xm+1..xM] ]
boundingBox :: Foldable t => t Coord -> Maybe (Coord,Coord)
boundingBox t =
case toList t of
[] -> Nothing
C y x : cs -> Just $ go x y x y cs
where
go xm ym xM yM [] = (C ym xm,C yM xM)
go xm ym xM yM (C y x : cs) =
go (min xm x) (min ym y) (max xM x) (max yM y) cs
drawCoords :: Map Coord Char -> String
drawCoords pixels =
unlines [ [ pixel (C y x) | x <- [xm..xM]] | y <- [ym..yM] ]
where
pixel c = M.findWithDefault ' ' c pixels
Just (C ym xm,C yM xM) = boundingBox (M.keys pixels)
showCoords :: Foldable t => t Coord -> String
showCoords t = drawCoords $ M.fromList [ (c,'#') | c <- toList t ]
withCoords :: (Char -> a) -> [String] -> [(Coord,a)]
withCoords f rows = concat $
[ [ (C y x, f c) | (x,c) <- zip [0..] xs ] | (y,xs) <- zip [0..] rows ]