Guillaume.B a écrit 31 commentaires

C'est une bonne idée mais je pense que tu as été chanceux sur les données.

En tout cas, trouver des cuts, même de taille 3, de manière efficace est un problème compliqué.
Voir cet article:
https://drops.dagstuhl.de/storage/00lipics/lipics-vol204-esa2021/LIPIcs.ESA.2021.71/LIPIcs.ESA.2021.71.pdf

Tout d'abord, remarquons que ce problème peut être partiellement résolu à la main en repérant les trois arêtes à supprimer à l'aide d'un outil de visualisation comme GraphViz.

C'est ce que j'ai fait pour le résoudre vite mais ce n'est pas très rigolo. Comme je préférais avoir un programme qui résout tout automatiquement, j'ai cherché un algorithme pour ce problème qui s'avère s'appeler un Minimum (Edge) Cut.
J'ai cherché une librairie en Haskell qui faisait ça mais n'en ayant pas trouvé, j'ai décidé d'implémenter moi même un algorithme.

Je suis tombé sur celui de Stoer et Wagner (qui fonctionne aussi sur un graphe pondéré).

https://en.wikipedia.org/wiki/Stoer%E2%80%93Wagner_algorithm

Ca n'a pas été facile de l'implémenter car la page wikipedia ne montre que les grandes lignes de l'algorithme mais je suis content de mon résultat.

Ca tourne en 2.5s sur l'input alors que la librairie Python networkx tourne en 6s pour le même problème.
Comme le code est un peu long, je ne le poste pas ici mais vous pouvez le trouver à cette adresse:
https://github.com/gbagan/advent-of-code/blob/master/libraries/aoc/AOC/Graph/MinCut.hs

Je me demande si il existe de meilleurs algorithmes quand on sait que le minimum cut est petit (ici 3).

Pour le code du problème à proprement parler, c'est assez court en utilisant une fonction pour le Minimum Cut et une pour trouver les composantes connexes.

type Network = [(Text, [Text])] 

parser :: Parser Network
parser = row `sepEndBy1` eol where
    row = (,) <$> label <* ": " <*> label `sepEndBy1` hspace
    label = Text.pack <$> some lowerChar 

part1 :: Network -> Int
part1 network = product (map length components) where
    graph = foldl' (\g (u, v) -> addEdge u v g) Map.empty
                [(u, v) | (u, nbor) <- network, v <- nbor]
    cutset = minimumCut graph
    graph' = foldl' (\g (u, v) -> removeEdge u v g) graph cutset
    components = connectedComponents graph'

Petite erreur de ma part, ce n'est pas un système d'équations linéaires mais quadratiques.
Mais bon, ça n'empêche pas à Z3 de le résoudre.

Comme annoncé, j'ai écrit des petites fonctions utilitaires pour Z3.
Ca donne ça. C'est plus lisible qu'avant (si on a un peu l'habitude de la syntaxe d'Haskell.

script :: [Hailstone] -> Z3 (Maybe [Integer])
script hailstones = do
    px <- mkFreshRealVar "px"
    py <- mkFreshRealVar "py"
    pz <- mkFreshRealVar "pz"
    vx <- mkFreshRealVar "vy"
    vy <- mkFreshRealVar "vy"
    vz <- mkFreshRealVar "vz"
    forM_ (zip [(0::Int)..] hailstones) \(i, Hailstone (V3 pxi pyi pzi) (V3 vxi vyi vzi)) -> do
        ti <- mkFreshRealVar ("t" <> show i)
        assert =<< px +& ti *& vx ==& pxi +& ti *& vxi
        assert =<< py +& ti *& vy ==& pyi +& ti *& vyi
        assert =<< pz +& ti *& vz ==& pzi +& ti *& vzi
    getIntResults [px,py,pz]

Pour la première partie, il faut déterminer le point d'intersection entre deux droites données par chacune par un point et un vecteur.
Je n'avais pas trop envie de me prendre la tête à calculer ça alors j'ai regardé sur Wikipedia. J'ai bien fait parce que la formule n'est pas évidente.

https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection

Pour la partie 2:
étant données n grelons de positions initiales px_i, py_i pz_i et de vitesse vx_i, vy_i vz_i, il faut trouver un grelon de position initial px, py, pz et de vitesse vx, vy, vz qui rentre en collision avec tous les autres.

C'est à dire que pour tout i dans [1..n], il existe un temps t_i tel que
- px + vx * t_i = px_i + vx_i * t_i
- py + vy * t_i = py_i + vy_i * t_i
- pz + vz * t_i = pz_i + vz_i * t_i

Ca revient donc à résoudre un système d'équations linéaires (avec une matrice sparse).
Comme je n'avais pas envie de réimplémenter ça, j'ai utilisé Z3. Et là, c'est vraiment une purge, le binding Z3 n'est pas terrible, il est beaucoup trop verbeux.
Je vais essayer d'écrire quelques helpers pour simplifier ça si j'ai le temps.
Ou alors, utiliser une autre librairie.

Voici le code:

type Position = V3 Integer
type Velocity = V3 Integer
data Hailstone = Hailstone !Position !Velocity

parser :: Parser [Hailstone]
parser = hailstone `sepEndBy1` eol where
    hailstone = Hailstone <$> v3 <* " @ " <*> v3
    v3 = do 
        x <- hspace *> signedDecimal 
        y <- ", " *> hspace *> signedDecimal 
        z <- "," *> hspace *> signedDecimal
        pure $ V3 x y z

cross :: Hailstone -> Hailstone -> Maybe (V2 Rational)
cross (Hailstone (V3 px1 py1 _) (V3 vx1 vy1 _)) (Hailstone (V3 px2 py2 _) (V3 vx2 vy2 _)) =
    if d == 0
        then Nothing
        else Just $! V2 x y
    where
    px3 = px1 + vx1
    px4 = px2 + vx2
    py3 = py1 + vy1
    py4 = py2 + vy2
    q1 = fromIntegral $ (px2 * py4 - py2 * px4) * vx1 - (px1 * py3 - py1 * px3) * vx2
    q2 = fromIntegral $ (px2 * py4 - py2 * px4) * vy1 - (px1 * py3 - py1 * px3) * vy2
    d = fromIntegral $ vx1 * vy2 - vy1 * vx2
    x = q1 / d
    y = q2 / d

crossesInsideTestArea :: Int -> Int -> Hailstone -> Hailstone -> Bool
crossesInsideTestArea  start end h1@(Hailstone (V3 px1 _ _) (V3 vx1 _ _)) 
                                 h2@(Hailstone (V3 px2 _ _) (V3 vx2 _ _)) =
    fromMaybe False do
        V2 x y <- cross h1 h2
        guard $ fromIntegral vx1 * (x - fromIntegral px1) >= 0
        guard $ fromIntegral vx2 * (x - fromIntegral px2) >= 0
        let start' = fromIntegral start
        let end' = fromIntegral end
        pure $ x >= start' && y >= start' && x <= end' && y <= end'

part1 :: [Hailstone] -> Int
part1 = count id . pairwise (crossesInsideTestArea 200_000_000_000_000 400_000_000_000_000)

script :: [Hailstone] -> Z3 (Maybe [Integer])
script hailstones = do
    _0 <- mkRealNum (0 :: Int)
    px <- mkFreshRealVar "px"
    py <- mkFreshRealVar "py"
    pz <- mkFreshRealVar "pz"
    vx <- mkFreshRealVar "vy"
    vy <- mkFreshRealVar "vy"
    vz <- mkFreshRealVar "vz"
    forM_ (zip [(0::Int)..] hailstones) \(i, Hailstone (V3 pxi pyi pzi) (V3 vxi vyi vzi)) -> do
        ti <- mkFreshRealVar ("t" <> show i)
        _vxi <- mkRealNum (-vxi)
        _vyi <- mkRealNum (-vyi)
        _vzi <- mkRealNum (-vzi)
        s1 <- mkAdd =<< sequence [pure px, mkMul [ti, vx], mkRealNum (-pxi), mkMul [ti, _vxi]]
        s2 <- mkAdd =<< sequence [pure py, mkMul [ti, vy], mkRealNum (-pyi), mkMul [ti, _vyi]]
        s3 <- mkAdd =<< sequence [pure pz, mkMul [ti, vz], mkRealNum (-pzi), mkMul [ti, _vzi]]
        assert =<< mkEq s1 _0
        assert =<< mkEq s2 _0
        assert =<< mkEq s3 _0
    fmap snd $ withModel $ \m ->
        catMaybes <$> mapM (evalInt m) [px,py,pz]

part2 :: [Hailstone] -> Maybe Integer
part2 hailstones =
    unsafePerformIO do
        sol <- evalZ3 (script hailstones)
        pure $ sum <$> sol

solve :: Text -> IO ()
solve = aoc parser part1 part2

100 ms pour la partie 1, 4s pour la partie 2.

J'ai trouvé le problème assez simple aujourd'hui. En tout cas plus simple que les jours précédents. Dommage que je me sois levé tard.

Tout d'abord, remarquons que le problème qu'on essaie de résoudre (Longest Path) est NP-difficile. Ce qui ne veut pas dire qu'on ne va réussir car il n'y a pas tellement de choix et donc de backtrack à faire.

La première partie est du backtracking classique. Dans la deuxième partie, l'espace d'exploration augmente considérablement. Mais on se rend qu'il y a de longs couloirs, c'est à dire une suite de sommets de degré 2.

On va dans compresser la grille de cette manière:
on dit qu'une tuile est intéressante si c'est la tuile de départ, d'arrivée ou si c'est une jonction, c'est à dire un sommet de degré au moins 3.
Et pour chaque tuile intéressante, on va chercher dans chaque direction la prochaine tuile intéssante ainsi que la distance qui les sépare.
On va appliquer notre algo de backtracking sur cette instance.

Voici le code:
comme d'habitude, on va essayer d'être le plus générique possible et on va définir une fonction longestPath qui prend en entrée un sommet de départ, un sommet d'arrivée et une fonction de voisinages. Elle s'applique donc à n'importe quelle strucutre et pas seulement aux grilles. On va la mettre dans ma librairie de fonctions de recherche dans un graphe.

longestPath :: Hashable a => (a -> [(a, Int)]) -> a -> a -> Int
longestPath neighbors start dest = go Set.empty 0 start where
    go visited len pos 
        | pos == dest = len
        | otherwise = maximumDef 0 [ go (Set.insert pos visited) (len+len') next
                                   | (next, len') <- neighbors pos
                                   , not $ next `Set.member` visited
                                   ]

Ensuite, vient le code du problème à proprement parler.
Tout d'abord les types utilisés et le parsing. Rien de bien compliqué.

data Tile = Path | Forest | North | South | West | East deriving (Eq)
type Grid = Matrix B Tile

parser :: Parser Grid
parser = fromLists' Seq <$> some tile `sepEndBy1` eol where
    tile = choice [Path <$ ".", Forest <$ "#", North <$ "^", South <$ "v", West <$ "<", East <$ ">"]

Ensuite, on définit une fonction de voisnage pour la partie 1.

neighbors1 :: Grid -> V2 Int -> [(V2 Int, Int)]
neighbors1 grid p = case grid ! toIx2 p of
    Path -> [ (p', 1)
            | p' <- adjacent p
            , let tile = grid !? toIx2 p'
            , tile /= Nothing && tile /= Just Forest
            ]
    North -> [(p - V2 1 0, 1)]
    South -> [(p + V2 1 0, 1)]
    West -> [(p - V2 0 1, 1)]
    East -> [(p + V2 0 1, 1)]
    _ -> error "neighbors: cannot happen"

part1 :: Grid -> Int
part1 grid = longestPath neighbors start dest where
    neighbors = neighbors1 grid
    Sz2 h w = size grid
    start = V2 0 1
    dest = V2 (h-1) (w-2)

Pour la partie 2, on définit une fonction de voisinage qui ne prend pas en compte les pentes.

neighbors2 :: Grid -> V2 Int -> [V2 Int]
neighbors2 grid p = [ p' 
                    | p' <- adjacent p
                    , let tile = grid !? toIx2 p'
                    , tile /= Nothing && tile /= Just Forest
                    ]

et on définit la fonction de compression de grille.

compressGrid :: Grid -> V2 Int -> V2 Int -> Matrix B [(V2 Int, Int)]
compressGrid grid start end = makeArray Seq (Sz2 h w) \(Ix2 r c) ->
        let pos = V2 r c
            neighbors = neighbors2 grid pos
        in
        if pos == start || pos == dest || length neighbors > 2 then
            [followPath next pos 1 | next <- neighbors]
        else
            []
    where
    followPath pos pred len =
        case neighbors2 grid pos of
            [next1, next2] | next1 == pred -> followPath next2 pos (len+1)
                           | otherwise     -> followPath next1 pos (len+1)
            _ -> (pos, len)

    Sz2 h w = size grid

part2 :: Grid -> Int
part2 grid = longestPath neighbors start dest where
    compressed = compressGrid grid start end
    neighbors p = compressed ! toIx2 p
    Sz2 h w = size grid
    start = V2 0 1
    dest = V2 (h-1) (w-2)

Je viens de me rendre compte que support et supported pouvaient être des tableaux plutôt que des dictionnaires. Avec quelques autres trucs, je descend à 10ms pour la partie 2.

5ms pour la partie 1 et 15ms pour la partie 2.

Le problème d'aujourd'hui n'est pas très dur conceptuellement mais j'ai un peu galéré à cause de bugs. Heureusement que l'exemple est là pour nous aider contrairement à hier et avant-hier.

Tout d'abord, on va trier les briques selon la coordonnée z. Ca rend les choses plus à traiter.
On va ensuite simuler la chute de chaque pièce par ordre d'apparition, ce qui ne pose pas de problème grâce au tri que l'on vient de faire.

On va ensuite calculer support et supported.
support est un dictionnaire qui, à une brique i, associe les index des pièces qui la supportent.
De même supported est un dictionnaire qui, à une brique i, associe les index des pièces supportées par elle.

On dira qu'une brique est stable si elle est supportée par au moins deux autres pièces.

Du coup, une pièce peut être désintégrée si les pièces supportées par elle sont toutes stables.

Pour la partie 2, il s'agit pour chaque pièce de faire un parcours en profondeur (en largeur marche aussi) pour simuler la cascade entrainée par la désintégration d'une pièce.
Une pièce chute si les pièces qui la supportent sont soi la pièce qui est désintégrée soit vont chuter.

J'avais écrit une fonction DFS générique qui m'a déjà servie dans plusieurs exemples.
Cette fonction prenait comme paramètre un sommet de départ et une fonction qui a un sommet associe son voisinage, c'est à dire ses sommets successeurs.

Problème: on a besoin ici de connaitre les sommets déjà parcourus (qui correspondent aux briques qui vont être désintégrées) pour calculer le voisinage.

J'ai donc écrit une fonction BFS générique mais qui prend en compte ce paramètre: la fonction de voisinage prend en paramètre un sommet ainsi que l'ensemble des sommets déjà visités.

Voici le code:

data Brick = Brick { _begin :: !(V3 Int), _end :: !(V3 Int) } deriving (Show)
type Cube = V3 Int
type Space = HashMap (V2 Int) Int

parser :: Parser [Brick]
parser = brick `sepEndBy1` eol where
    brick = Brick <$> coord <* "~" <*> coord
    coord = V3 <$> decimal <* "," <*> decimal <* "," <*> decimal

sortBricks :: [Brick] -> [Brick]
sortBricks = sortOn (view _z . _begin) 
            . map (\(Brick p1 p2) -> Brick (min p1 p2) (max p1 p2))

cubesOf :: Brick -> [Cube]
cubesOf (Brick (V3 x1 y1 z1) (V3 x2 y2 z2)) = V3 <$> [x1..x2] <*> [y1..y2] <*> [z1,z2]

fallOne :: (Space, Brick) -> (Space, Brick)
fallOne (space, brick) = (space', brick') where
    cubes = cubesOf brick
    height = maximum [HMap.findWithDefault 0 (V2 x y) space | (V3 x y _) <- cubes]
    Brick start@(V3 _ _ z) end = brick
    brick' = Brick (start - V3 0 0 (z - height))  (end - V3 0 0 (z - height)) 
    space' = foldl' go space (cubesOf brick')
    go spc (V3 x y z') = HMap.insert (V2 x y) (z'+1) spc

fall :: [Brick] -> [Brick]
fall = go HMap.empty where
    go _ [] = []
    go space (brick:bricks) = brick' : go space' bricks where
        (space', brick') = fallOne (space, brick) 

cubeOwners :: [Brick] -> HashMap (V3 Int) Int
cubeOwners = foldl' go HMap.empty . zip [0..] where
    go owners (i, brick) = foldl' 
                            (\owners' cube -> HMap.insert cube i owners')
                            owners
                            (cubesOf brick)

precomp :: [Brick] -> ([Brick], IntMap [Int], IntMap [Int])
precomp bricks = (bricks', support, supported) where
    bricks' = fall (sortBricks bricks)
    owners = cubeOwners bricks'
    supportOf i brick =
        if view _z (_begin brick) == 0
            then [-1]
            else ordNub .catMaybes $ 
                [  j
                | cube <- cubesOf brick
                , let j = owners HMap.!? (cube - V3 0 0 1)
                , j /= Just i
                ]
    support = Map.fromList [(i, supportOf i brick) | (i, brick) <- zip [0..] bricks']
    supportedBy i brick =
        ordNub . catMaybes $ [ j 
                             | cube <- cubesOf brick
                             , let j = owners HMap.!? (cube + V3 0 0 1)
                             , Just i /= j
                             ]
    supported = Map.fromList [(i, supportedBy i brick) | (i, brick) <- zip [0..] bricks']

part1 :: ([Brick], IntMap [Int], IntMap [Int]) -> Int
part1 (bricks, support, supported) = length disintegrated where
    isStable i = length (support Map.! i) >= 2
    canBeDisintegrated i = all isStable (supported Map.! i)
    disintegrated = [i | (i, _) <- zip [0..] bricks, canBeDisintegrated i]

dfs :: Hashable a => (a -> HashSet a -> [a]) -> a -> HashSet a
dfs nborFunc start = go HSet.empty [start] where
    go visited [] = visited
    go visited (v:queue)
        | v `HSet.member` visited = go visited queue
        | otherwise =
            let visited' = HSet.insert v visited
                nbors = nborFunc v visited' 
            in go visited' (nbors ++ queue)

part2 :: ([Brick], IntMap [Int], IntMap [Int]) -> Int
part2 (bricks, support, supported) = res where
    nborFunc v disintegrated =
        [ next 
        | next <- supported Map.! v
        , all (`HSet.member` disintegrated) (support Map.! next)
        ]
    res = sum [HSet.size (dfs nborFunc i) - 1 | (i, _) <- zip [0..] bricks]

solve :: Text -> IO ()
solve = aoc' parser (Just . precomp) part1 part2

300ms pour la partie 2.

Pour la partie 1, il faut remarquer vu que la parité de la distance au point de départ change à chaque déplacement. La distance entre le point de départ et un sommet accessible après 64 mouvements est donc toujours pair.

Du coup, les sommets à trouver sont ceux situés exactement à distance n où n est pair et n <= 64.
Un simple parcours en largeur fait l'affaire.

Pour la partie 2, ça se complique.
Mais on repère que l'instance est assez particulière:
- la grille de départ est carrée;
- le point de départ se trouve au centre;
- la ligne horizontale, la ligne verticale ainsi que les diagonales autour du centre sont vides.

Notons f(n) le nombre de points accessibles après n mouvements et notons M la taille (verticale et horizontale) de la grille.
On peut donc se dire qu'il doit y avoir une régularité entre f(n) et f(n+M).

Notons r = 26501365 mod M et regardons la suite des u_i = f(r + iM) pour i entier naturel.
Après avoir calculé les 5 ou 6 premières valeurs par ordinateur, on se rend compte que la suite est une séquence quadratique ou dit autrement que la suite des dérivées discrètes secondes est constante. Elle est donc de la forme u_n = a *n^2 + b * n + c.
Il faut donc calculer u_n avec n = 26501365 // M où // désigne la division entière.

Pour calculer u_n, on a besoin que des 3 premiers termes de la suite.
Notons d1 = u1 - u0, d2 = u2 - u1 et d' = d2 - d1 alors
u_n = u0 + n * d1 + n * (n-1) * d' / 2.
Et voilà !

Voici le code un peu commenté.

Tout d'abord le parsing et un précalcul pour transformer l'entrée en matrice et repérer le sommet de départ.

data Tile = Garden | Rock | Start deriving (Eq)
type Grid = Matrix U Bool

parser :: Parser [[Tile]]
parser = some tile `sepEndBy1` eol where
    tile = Garden <$ "." <|> Rock <$ "#" <|> Start <$ "S"

precomp :: [[Tile]] -> Maybe (Grid, V2 Int)
precomp tiles = do
    start <- listToMaybe [V2 i j | (i, j, Start) <- flattenWithIndex tiles]
    let tiles' = map (map (==Rock)) tiles
    let matrix = fromLists' Seq tiles'
    pure (matrix, start)

Pour la partie 1, on définir une fonction nbors qui donne le voisinage d'une tuile.
Comme on ne sort pas de la grille dans la partie 1 et pour factoriser avec la partie 2,
on fait des modulo sur les coordonnées.

nbors :: Grid -> V2 Int -> [V2 Int]
nbors grid = filter (not . (grid !) . toIx2 . mod2) . adjacent where 
    Sz2 h w = size grid
    mod2 (V2 r c) = V2 (r `mod` h) (c `mod` w)

part1 :: (Grid, V2 Int) -> Int
part1 (grid, start) = count even . takeWhile (<=64) . map fst $ bfs (nbors grid) start

Pour la partie 2, on définit d'abord une fonction générique pour calculer le n-ième d'une séquence quadratique.

-- given a quadratic sequence with first terms u0, u1, u0,  compute u_n
quadraticSequence :: Integer -> Integer -> Integer -> Integer -> Integer
quadraticSequence u0 u1 u2 n = u0 + n * d1 + n * (n-1) * d' `div` 2
    where
    d1 = u1 - u0
    d2 = u2 - u1
    d' = d2 - d1

Ensuite, on peut l'appliquer à notre problème en calculant les trois premiers termes de la suite grâce à un parcours en largeur.

part2 :: (Grid, V2 Int) -> Integer
part2 (grid, start) = result where
    nbSteps = 26_501_365
    Sz2 h _ = size grid
    r = nbSteps `mod` h
    bfsTrace = map fst $ bfs (nbors grid) start
    countParity x = fromIntegral . count (\y -> even (y - x)) 
    nbReachable x = countParity x $ takeWhile (<=x) bfsTrace
    u0 = nbReachable r
    u1 = nbReachable (r+h)
    u2 = nbReachable (r+2*h)
    result = quadraticSequence u0 u1 u2 (fromIntegral $ nbSteps `div` h)

En Haskell, on la structure Seq. C'est des structures immuables permettant d'ajouter ou d'enlever un élément en début ou fin en temps constant. Quand je dis enlever ou ajouter, je veux dire créer une nouvelle séquence en se basant sur l'existante mais sans la modifier.
Sous le capot, c'est basé sur les finger trees.

https://en.wikipedia.org/wiki/Finger_tree

Je peux dire que j'ai galéré sur celui là. Tout ça parce que j'ai mal lu l'énoncé.
Je n'avais pas vu qu'il fallait traiter les gestions de pulsations sous forme de file.
Je les traitais sous forme de pile et bizarrement ça m'a quand même donné la bonne réponse pour la première partie.

Pour la deuxième partie, c'est comme pour le jour 8, c'est très compliqué dans le cas général mais facile parce que l'instance a de bonnes propriétés (je n'aime pas trop ce genre de journée).
Tout d'abord, on remarque que rx a un seul prédécesseur qui est de type Conjonction et que celui a 4 prédécesseurs (que je vais appeler a, b, d) chacun de type Conjonction.
Ensuite, si on enlève broadcaster, rx et son prédécesseur, on se retrouve avec 4 composantes connexes et donc les pulsations de chacune vont vivre leur vie indépendamment des autres.

Si, on regarde quand a, b, c ou d envoie une pulsation forte, on remarque que ça forme un cycle sans prépériode et qu'une pulsation forte n'apparait qu'une seule fois durant un cycle.

Il suffit donc de repérer pour a, b, c et d la première fois qu'il y a une pulsation forte et faire le PPCM entre les différentes valeurs trouvées.

Pour le code en Haskell, j'utilise une monade State et des Lens, ce qui me permet de simplifier l'écriture.

data Type = FlipFlop | Conjunction | Broadcaster
data Module = Module !Type [String]
type Network = HashMap String Module

data NState = NState 
    { _ffState :: !(HashMap String Bool)  -- the state of flip flap mdoules
    , _from :: !(HashMap String (HashMap String Bool)) -- last signal sent by predecessor
    , _nbLow :: !Int
    , _nbHigh :: !Int
    , _seen :: !(HashMap String Bool)
    }

makeLenses ''NState

parser :: Parser Network
parser = insertRx . Map.fromList <$> module_ `sepEndBy1` eol where
    module_ = do
        t <- type_
        n <- name <* " -> "
        ns <- name `sepBy1` ", "
        pure (n, Module t ns)
    name = some lowerChar
    type_ = FlipFlop <$ "%" <|> Conjunction <$ "&" <|> pure Broadcaster
    insertRx = Map.insert "rx" (Module Broadcaster [])

sendSignal :: Network -> Seq (String, String, Bool) -> State NState ()
sendSignal network = \case
    Seq.Empty -> pure ()
    ((name, srcName, pulse) :<| queue') -> do
        if pulse then
            nbHigh += 1
        else do
            nbLow += 1
            seen . ix name .= True
        let Module type_ dests = network Map.! name
        case type_ of
            Broadcaster ->
                sendSignal network $ queue' >< Seq.fromList (map (,name, False) dests)
            FlipFlop ->
                if pulse then 
                    sendSignal network queue'
                else do 
                    nstate <- get
                    let state = _ffState nstate Map.! name 
                    ffState . ix name .= not state
                    sendSignal network $ queue' >< Seq.fromList (map (,name, not state) dests)
            Conjunction -> do
                from . ix name . ix srcName .= pulse
                nstate <- get
                let signal' = any not $ Map.elems (_from nstate Map.! name)
                sendSignal network $ queue' >< Seq.fromList (map (,name, signal') dests)

round :: Network -> State NState ()
round network = do
    seen .= Map.map (const False) network
    sendSignal network $ Seq.singleton ("broadcaster", "$dummy", False)

initNState :: Network -> NState
initNState network = NState initFfState initFrom 0 0 initSeen where
    initFfState = Map.map (const False) network
    emptyFrom = Map.map (const Map.empty) network
    edgeList = concat . Map.elems $ Map.mapWithKey go network 
    go u (Module _ vs) = map (u,) vs
    initFrom = foldl' go' emptyFrom edgeList
    go' from_ (u, v) = Map.adjust (Map.insert u False) v from_
    initSeen =  Map.map (const False) network

part1 :: Network -> Int
part1 network = _nbLow finalState * _nbHigh finalState where
    nstate = initNState network
    finalState = flip execState nstate do
        forM_ [(1::Int)..1000] \_ -> round network

part2 :: Network -> Integer
part2 network = foldl' lcm 1 cycles where
    nstate = initNState network
    predRx = head . Map.keys $ _from nstate Map.! "rx"
    predPredRx = Map.keys $ _from nstate Map.! predRx
    nstates = iterate' (execState (round network)) nstate
    cycles = map extractCycle predPredRx
    extractCycle name = head [ idx 
                             | (idx, True) <- zip [0..] 
                                . map ((Map.! name) . _seen) 
                                 $ nstates
                             ]

solve :: Text -> IO ()
solve = aoc parser part1 part2

Je maintiens une liste de pavés.

J'ai une fonction go qui prend comme paramètre une liste de pavés et une liste de tests.
Elle va me renvoyer la liste des pavés qu'il y aura au final.

La fonction go fonctionne ainsi:
Je regarde le prochain test à faire.
Selon le résultat du test, je découpe ma liste de pavés en deux listes: les réussis et les échoués (en ayant éventuellement divisé des pavés).

Pour les réussis, je regarde l'instruction à faire quand le test est réussi et je stocke le résultat suivant dans une variable réussis2
- si l'instruction est "accepter": la liste des réussis.
- si l'instruction est "refuser": la liste vide
- si l'instruction est d'aller à un workflow x, j'appelle récursivement ma fonction go avec comme paramètre
-- la liste des réussis
-- la liste des tests pour le workflow x.

Pour les refusés, j'appelle récursivement ma fonction go avec comme paramètre
-- la liste des refusés
-- la liste des tests privés du premier élément.
et je stocke ça dans échoués2.

Le résultat de la fonction go sera reussis2 concaténé à échoués2.

Ca se fait bien en récursif. Je pense que c'est plus compliqué en itératif.

Par exemple si j'ai un pavé x = [1..200], m = [1..100], a = [1..100], s= [1..100] et que j'ai un test x<96, alors je divise mon pavé en
- un pavé accepté x = [1..95], m = [1..100], a = [1..100], s= [1..100]
- un pavé refusé x = [96..200], m = [1..100], a = [1..100], s= [1..100].

150 microsecondes pour la partie 1 et 600 microsecondes pour la partie 2.

La partie 1 est facile, passons.

J'ai rapidement eu l'idée pour la partie 2 mais j'ai galéré à débugger mon code.
Je ne suis pas très satisfait de mon code, je pense qu'il peut être simplifié.

L'idée est de considérer des ensembles de RatingRange deux à deux disjoints.
Les RatingRange étant des intervalles de valeurs pour chaque évaluation (x, m, a ou s).
On peut voir ça comme un rectangle en 4 dimensions.

On démarre avec un ensemble composé d'un seul RatingRange avec x = [1..4000], m=[1..4000], a=[1..4000] et s=[1..4000]

A chaque test effectué, on va séparer les RatingRange en deux catégories, ceux qui sont acceptés et ceux qui sont refusés. Pour cela, on devra parfois diviser un RatingRange en deux parties.
C'est ce que fait la fonction suivante
haskell
splitRatings :: Test -> [RatingRange] -> ([RatingRange], [RatingRange])

A partir de là, il est relativement facile de simuler les worflow en prenant en entrée des RatingRange et de calculer le nombre total de possibilités de pièces vu que les RatingRange sont deux à deux disjoints.

Voici le code en entier.

import           AOC.Prelude hiding (LT, GT)
import qualified Data.HashMap.Strict as Map
import           Lens.Micro (Lens', set, (^.))
import           Lens.Micro.TH (makeLensesFor)
import           AOC (aoc)
import           AOC.Parser (Parser, sepBy1,sepEndBy1, eol, choice, decimal, lowerChar, some, try)

data Rating a = Rating { _x :: !a, _m :: !a, _a :: !a, _s :: !a} deriving (Foldable)
data Category = X | M | A | S
data Test = LT Category Int | GT Category Int | Otherwise
data Instr = Accept | Reject | Goto String
data Step = Step !Test !Instr
type Workflows = HashMap String [Step]
data Input = Input !Workflows ![Rating Int]
type RatingRange = Rating (Int, Int)

makeLensesFor [("_x", "xL"), ("_m", "mL"), ("_a", "aL"), ("_s", "sL")] ''Rating

parser :: Parser Input
parser = Input . Map.fromList <$> workflows <* eol <*> ratings where
    workflows = workflow `sepEndBy1` eol
    ratings = rating `sepEndBy1` eol
    workflow = (,) <$> some lowerChar <* "{" <*> step `sepBy1` "," <* "}"
    step = try (Step <$> test <* ":" <*> instr) <|> (Step Otherwise <$> instr)
    test = do
        c <- category
        "<" *> (LT c <$> decimal) <|> ">" *> (GT c <$> decimal)
    instr = Accept <$ "A" <|> Reject <$ "R" <|> Goto <$> some lowerChar
    category = choice [X <$ "x", M <$ "m", A <$ "a", S <$ "s"]
    rating = do
        x <- "{x=" *> decimal
        m <- ",m=" *> decimal
        a <- ",a=" *> decimal
        s <- ",s=" *> decimal <* "}"
        pure $ Rating x m a s

catLens :: Category -> (forall a. Lens' (Rating a) a)
catLens = \case
    X -> xL
    M -> mL
    A -> aL
    S -> sL

part1 :: Input -> Int
part1 (Input workflows ratings) = sum . map sum $ filter accepts ratings where
    accepts rating = go "in" where
        go name = case passTests rating steps of
            Accept -> True
            Reject -> False
            Goto name' -> go name'   
            where steps = workflows Map.! name
    passTests _ [] = error "passTests: cannot happen"
    passTests rating ((Step test instr):steps) = case test of
        Otherwise -> instr
        LT cat n | rating ^. catLens cat < n -> instr
        GT cat n | rating ^. catLens cat > n -> instr 
        _  -> passTests rating steps

splitRatings :: Test -> [RatingRange] -> ([RatingRange], [RatingRange])
splitRatings test = partitionEithers . concatMap (splitRating test) where
    splitRating Otherwise rating = [Right rating]
    splitRating (LT cat n) rating =
        let (min_, max_) = rating ^. catLens cat in
        if | min_ >= n -> [Left rating]
           | max_ < n -> [Right rating]
           | otherwise -> [ Right $ set (catLens cat) (min_, n-1) rating
                          , Left $ set (catLens cat) (n, max_) rating
                          ]
    splitRating (GT cat n) rating = 
        let (min_, max_) = rating ^. catLens cat in
        if | max_ <= n -> [Left rating]
           | min_ > n -> [Right rating]
           | otherwise -> [ Right $ set (catLens cat) (n+1, max_) rating
                          , Left $ set (catLens cat) (min_, n) rating
                          ]

part2 :: Input -> Int
part2 (Input workflows _) = sum . map size $ go initRanges (workflows Map.! "in")
    where
    initRanges = [Rating (1, 4000) (1, 4000) (1, 4000) (1, 4000)]
    go _ [] = error "part2: cannot happen"
    go ratings (Step test instr : steps) = ratings' where
        (failed, succeeded) = splitRatings test ratings
        succeeded' = case instr of
            Accept -> succeeded
            Reject -> []
            Goto name -> go succeeded (workflows Map.! name)
        ratings' = if null failed then succeeded' else succeeded' ++ go failed steps

    size (Rating (xmin, xmax) (mmin, mmax) (amin, amax) (smin, smax)) =
        (xmax - xmin + 1) * (mmax - mmin + 1) * (amax - amin + 1) * (smax - smin + 1)

solve :: Text -> IO ()
solve = aoc parser part1 part2

Ce problème ressemble à la partie 2 du jour 10 de cette année.

La première partie peut être aisément fait avec un parcours en largeur/profondeur mais ça devient clairement impossible pour la partie 2.

Remarquons que l'on cherche à trouver le nombre de sommets de coordonnées entières situées à l'intérieur d'un polygone.
On va donc de baser sur le théorème de Pick et la shoelace formula.
La shoelace formula est une formule pour calculer l'aire d'un polygone.
Si les sommets du polygone sont (x1, y1), ..., (xn, yn) alors l'aire du polygone est
|x1 y2 - y1 x2 + ... + x_{n-1} yn - y_{n-1} xn + xn y1 - yn x1| / 2

Le théorème de Pick donne une formule pour calculer le nombre de points intérieurs à un polygone à partir de son aire (qui est calculé par la shoelace formula) et du nombre de points à sa frontière (c'est juste la somme des distances données par les instructions).

La formule est la suivante: A = i + b/2 - 1 où A est l'aire, i le nombre de points à l'intérieur et b le nombre de points à la frontière.

Pour calculer le nombre de "#" total, il faut faire la somme i + b où i = A - b/2 - 1.

Donc, voici le code Haskell

data Direction = Up | Down | Left | Right
data Instr = Instr !Direction !Int

hexToInt :: String -> Int
hexToInt = foldl' (\acc x -> acc * 16 + hexDigitToInt x) 0
   where hexDigitToInt x
          | isDigit x = ord x - ord '0'
          | otherwise = ord x - ord 'a' + 10

parser :: Parser [(Instr, Instr)]
parser = instr `sepEndBy1` eol where
    instr = do
        dir1 <- direction <* " "
        len1 <- decimal <* " (#" 
        len2 <- hexToInt <$> count 5 hexDigitChar
        dir2 <- direction2 <* ")"
        pure (Instr dir1 len1, Instr dir2 len2)

    direction = choice [Up <$ "U", Down <$ "D", Left <$ "L", Right <$ "R"] 
    direction2 = choice [Right <$ "0", Down <$ "1", Left <$ "2", Up <$ "3"] 

trenchPoints :: [Instr] -> [V2 Int]
trenchPoints = scanl' go (V2 0 0) where
    go p (Instr dir len) = p + case dir of
        Left -> V2 0 (-len)
        Right -> V2 0 len
        Up -> V2 (-len) 0
        Down -> V2 len 0

-- return the double of the polygon area
shoelaceFormula :: [V2 Int] -> Int
shoelaceFormula points = abs $ sum (zipWith go points (drop 1 points ++ points))
    where go (V2 x y) (V2 x' y') = x * y' - x' * y

-- via Pick theorem and Shoelace Formula
-- https://en.wikipedia.org/wiki/Pick%27s_theorem
-- https://en.wikipedia.org/wiki/Shoelace_formula
solveFor  :: ((Instr, Instr) -> Instr) -> [(Instr, Instr)] -> Int
solveFor f instrs = boundary + interior  where
    instrs' = map f instrs
    doubleArea = shoelaceFormula (trenchPoints instrs')
    boundary = sum [len | Instr _ len <- instrs']
    interior = (doubleArea - boundary) `div` 2 + 1

solve :: Text -> IO ()
solve = aoc parser (solveFor fst) (solveFor snd)

Moi, je suis arrivé à descendre à 300ms mais je pense pas faire beaucoup mieux.
J'ai tenté des heuristiques pour A* mais rien de concluant.
Enfin, j'en avais une bien mais elle prenait trop de temps à être calculer.

Faudrait que je m'y mettre au Rust, un jour.

Après quelques optimisations
200ms pour la partie 1 et 800ms pour la partie 2.

L'idée est qu'au lieu de dire qu'un noeud du graphe est un couple (position, direction) avec 4 directions possibles, je dis qu'un noeud est un couple (position, booléen)
ou le booléen m'indique si je me déplace horizontalement ou verticalement.
Ca fait 2 fois moins de noeuds dans le graphe. Du coup, logiquement, ça divise le temps d'exécution par deux (et même plus avec quelques autres optimisations).

Le code qui change:

type Grid = Matrix U Int
type Position = V2 Int
type Direction = Bool -- True -> horizontal | False -> vertical

neighbors :: [Int] -> Grid -> (Position, Direction) -> [((Position, Direction), Int)]
neighbors nbSteps grid (pos, dir) =
    [ ((nextPos, not dir), weight)
    | i <- nbSteps
    , let vDir = if dir then V2 0 1 else V2 1 0
    , let nextPos = pos + fmap (*i) vDir
    , isJust (grid !? toIx2 nextPos)
    , let range = if i > 0 then [1..i] else [i..(-1)]
    , let weight = sum [grid ! toIx2 (pos + fmap (*j) vDir) | j <- range]
    ]

solveFor :: [Int] -> Grid -> Maybe Int
solveFor nbSteps grid = dijkstra' (neighbors nbSteps' grid) (`elem` ends) starts where
    nbSteps' = nbSteps ++ map negate nbSteps
    Sz2 h w = A.size grid
    starts = (V2 0 0,) <$> [True, False]
    ends = (V2 (h-1) (w-1),) <$> [True, False]

J'ai oublié dire:
450ms pour la partie et 2s pour la partie 2.
Pas très satisfait mais je pense que c'est améliorable.

Je trouve que ce problème ressemble à celui d'hier.
Il s'agit encore d'un parcours dans un graphe.
Ici, le graphe est pondéré. On va donc utiliser l'algorithme de Dijkstra au lieu d'un simple parcours en profondeur/largeur.
Comme hier, la direction est importante. Les sommets du graphe seront donc les paires (Position, Direction).
Les voisins d'un sommet ne seront pas les positions adjacentes dans la grille mais celle à distance entre 1 et 3 pour la partie 1 et entre 4 et 10 pour la partie 2.
La direction devra également changer à chaque fois.
Le poids des arêtes sera la somme des chiffres indiqués sur chacune des tuiles que l'on a parcouru durant ce déplacement.

Dans mon code, j'utilise la fonction dijkstra' que j'ai également écrite pour des problèmes des années précédentes.
Voici sa signature

dijkstra' :: (Hashable v, Real w) => (v -> [(v, w)]) -> (v -> Bool) -> [v] -> Maybe w

Le type v est celui des sommets et le type w est celui des poids des arêtes.
La fonction prend en entrée
- une fonction de voisinage qui à chaque sommet associe une liste des sommets voisins ainsi que le poids de l'arête entre les deux sommets,
- une fonction de prédicat pour le sommet de fin,
- un ensemble de sommets de départ.
et renvoit la distance entre un des sommets de départs et un des sommets de fin si un chemin existe.

Voici le code (sans les imports)

import           AOC.Prelude
import           Data.Char (digitToInt)
import           Data.Massiv.Array (Matrix, (!), (!?), U, Comp(Seq), Sz(Sz2))
import qualified Data.Massiv.Array as A
import           AOC (aoc)
import           AOC.V2 (V2(..), adjacent, toIx2)
import           AOC.Parser (Parser, sepEndBy1, eol, digitChar, some)
import           AOC.Search (dijkstra')

type Grid = Matrix U Int
type Position = V2 Int
type Direction = V2 Int

directions :: [V2 Int]
directions = adjacent (V2 0 0)

parser :: Parser Grid
parser = A.fromLists' Seq <$> some (digitToInt <$> digitChar) `sepEndBy1` eol

neighbors :: [Int] -> Grid -> (Position, Direction) -> [((Position, Direction), Int)]
neighbors nbSteps grid (pos, dir) =
    [ ((nextPos, nextDir), weight)
    | i <- nbSteps
    , nextDir <- directions
    , nextDir /= dir && nextDir /= -dir
    , let nextPos = pos + fmap (*i) nextDir
    , isJust (grid !? toIx2 nextPos)
    , let weight = sum [grid ! toIx2 (pos + fmap (*j) nextDir) | j <- [1..i]]
    ]

solveFor :: [Int] -> Grid -> Maybe Int
solveFor nbSteps grid = dijkstra' (neighbors nbSteps grid) (`elem` ends) starts where
    Sz2 h w = A.size grid
    starts = [(V2 0 0, V2 1 0), (V2 0 0, V2 0 1)]
    ends = [(V2 (h-1) (w-1), V2 0 1), (V2 (h-1) (w-1), V2 1 0)]

solve :: Text -> IO ()
solve = aoc parser (solveFor [1..3]) (solveFor [4..10])

C'est un problème qui peut se faire un parcours en longueur ou largeur.
Problème: selon la direction du faisceau, les cases à visiter suivantes peuvent être différentes.
Du coup un sommet du graphe que l'on veut parcourir ne sera pas seulement une position dans la grille mais un couple (position, direction).

Je commence par importer mes fonctions nécessaires et définir les types utilisés dans le problème.
Les positions et directions sont des vecteurs de dimension 2.
J'appelerai le couple (Position, Direction) est un Beam.

import           AOC.Prelude
import           Data.List (maximum)
import qualified Data.HashSet as Set
import           Data.Massiv.Array (Matrix, (!), (!?), B, Comp(Seq), Sz(Sz2))
import qualified Data.Massiv.Array as A
import           Control.Parallel.Strategies (parMap, rdeepseq)
import           AOC (aoc)
import           AOC.V2 (V2(..), toIx2)
import           AOC.Parser (Parser, sepEndBy1, eol, choice, some)
import           AOC.Search (reachableFrom)

data Tile = Empty | Horizontal | Vertical | Slash | Antislash
type Position = V2 Int
type Direction = V2 Int
type Beam = (Position, Direction)
type Grid = Matrix B Tile

Ensuite, le parsing, rien de bien intéressant

parser :: Parser Grid 
parser = A.fromLists' Seq <$> some tile `sepEndBy1` eol where
    tile = choice [ Empty <$ "."
                  , Horizontal <$ "-"
                  , Vertical <$ "|"
                  , Slash <$"/"
                  , Antislash <$ "\\"
                  ]

Ensuite, vient le parcours en largeur. Je réutilise une fonction reachableFrom définie pour des problèmes précédents.
Elle prend deux arguments
- une fonction qui étant donné renvoit la liste des sommets voisins
- un sommet de départ
et renvoit l'ensemble des sommets accessibles depuis le sommet de départ.

reachableFrom :: Hashable a => (a -> [a]) -> a -> HashSet a
reachableFrom nborFunc start = go HSet.empty [start] where
    go visited [] = visited
    go visited (v : stack)
        | v `HSet.member` visited = go visited stack
        | otherwise = go (HSet.insert v visited) (nborFunc v ++ stack)

Pour utiliser reachableFrom, je dois calculer, étant donné un beam, les beams suivants.
Je le fais en deux temps en définissant d'abord une fonction nextDirections qui étant donné une direction et une tuile me renvoit les directions suivantes.

nextDirections :: Direction -> Tile -> [Direction]
nextDirections (V2 drow dcol) = \case
    Slash -> [V2 (-dcol) (-drow)]
    Antislash -> [V2 dcol drow]
    Horizontal | drow /= 0 -> [V2 0 (-1), V2 0 1]
    Vertical | dcol /= 0 -> [V2 (-1) 0, V2 1 0]
    _ -> [V2 drow dcol]

A partir de ça, je peux définir ma fonction neighbors nécessaire à `reachableFrom

neighbors :: Grid -> Beam -> [Beam]
neighbors grid (pos, dir) = [ (nextPos, nextDir)
                            | nextDir <- nextDirections dir (grid ! toIx2 pos)
                            , let nextPos = pos + nextDir
                            , isJust (grid !? toIx2 nextPos)
                            ]

Je peux maintenant définir ma fonction energized qui me renvoit le nombre de tuiles énergisées en utilisant les fonctions reachableFrom et neighbors définis plus haut.

energized :: Grid -> Beam -> Int
energized grid start = Set.size $ Set.map fst reachable where
    reachable = reachableFrom (neighbors grid) start

part1 :: Grid -> Int
part1 grid = energized grid (V2 0 0, V2 0 1)

Pour la partie 2, c'est du brute-force sur toutes les positions de départ possibles, j'ai pas trouvé mieux.
Ca se parallélise bien, j'utilise parMap qui est une version parallèle de map.

part2 :: Grid -> Int
part2 grid = maximum $ parMap rdeepseq (energized grid) starts where
    Sz2 h w = A.size grid
    starts = concat $
                [[(V2 r 0, V2 0 1), (V2 r (w-1), V2 0 (-1))] | r <- [0 .. h-1]]
             ++ [[(V2 0 c, V2 1 0), (V2 (h-1) c, V2 (-1) 0)] | c <- [0 .. w-1]]

1400ms sur un seul core et 800ms en multicore pour la partie 2. Pas terrible le parallélisme, j'aurais espéré mieux. Je ne me suis peut-être pas pris comme il fallait.

J'ai réécrit ma fonction tilt de manière plus maligne en m'inspirant de la solution d'une autre personne.

tilt :: Grid -> Grid
tilt = map (go 0) where
    go n = \case
        (Empty:xs) -> go (n+1) xs
        (Round:xs) -> Round : go n xs
        (Cube:xs) -> replicate n Empty ++ Cube : go 0 xs
        _        -> replicate n Empty

Maintenant, le temps d'exécution est passé à 200ms.

Problème très simple aujourd'hui. Aucune subtilité algorithmique ou autre astuce à avoir.
Juste un petit détail, j'ai pensé à utiliser, pour représenter les boites, des hashmaps avec pour clé des strings (les labels) et pour valeur des ints (les longueurs focales).
Petit problème, les HashMap de la librairie containers ne préservent pas l'ordre d'insertion, cet ordre étant nécessaire pour calculer le "focusingPower".
J'ai donc utilisé des HashMaps d'une librairie tierce qui, elles, préservent l'ordre d'insertion.
250 microseconds pour la partie 1 et 600 microseconds pour la partie 2.
Je pense que ce serait plus performant si j'utilisais des structures de données mutables mais ce serait moins joli.

data Operation = Remove | Insert !Int
data Step = Step !String !Operation
type Box = HMap.InsOrdHashMap String Int
type Boxes = IntMap Box

stepToString :: Step -> String
stepToString (Step str Remove) = str ++ "-"
stepToString (Step str (Insert n)) = str ++ "=" ++ show n

parser :: Parser [Step]
parser = step `sepEndBy1` "," where
    step = Step <$> some lowerChar <*> operation
    operation = Remove <$ "-" <|> Insert <$> ("=" *> decimal)

hash :: String -> Int
hash = foldl' go 0 where
    go acc ch = (acc + ord ch) * 17 `mod` 256

part1 :: [Step] -> Int
part1 = sum . map (hash . stepToString)

hashmapStep :: Boxes -> Step -> Boxes
hashmapStep boxes (Step label instr) = case instr of
    Remove -> IntMap.adjust (HMap.delete label) k boxes 
    Insert len -> IntMap.adjust (HMap.insert label len) k boxes
    where k = hash label

focusingPower :: Boxes -> Int
focusingPower boxes = sum [ (i+1) * j * len 
                          | (i, box) <- IntMap.toList boxes
                          , (j, (_, len)) <- zip [1..] (HMap.toList box)
                          ]
part2 :: [Step] -> Int
part2 = focusingPower . foldl' hashmapStep initialBoxes where
    initialBoxes = IntMap.fromList (zip [0..] (replicate 256 HMap.empty))

solve :: Text -> IO ()
solve = aoc parser part1 part2

En se rendant compte qu'un cycle est un enchainement tilt, rotation, tilt, rotation, tilt, rotation, tilt, rotation, on peut écrire le code plus simplement.

part2 :: Grid -> Int
part2 grid = load . transpose $ grids !! y' where 
    (x, y) = findRepetition grids
    y' = x + (1000000000 - x) `mod` (y-x)
    grids = iterate' cycle (transpose grid)
    step = reverse . transpose . tilt
    cycle = step . step . step . step

Et du coup, la fonction tiltInDirection ne sert plus à rien.
On gagne même un peu en temps d'exécution: 400ms.

Je viens de me rendre compte que mon code n'était pas correct tout le temps même s'il marchait bien sur l'input. En effet, il se pourrait que deux configurations identiques apparaissent mais pas dans la même position dans le cycle des directions.

Par exemple, une configuration alors que la prochaine instruction est d'aller vers l'ouest puis la même configuration alors que la prochaine instruction est d'aller au nord.

Du coup, je l'ai corrigé (il y a juste à changer la fonction part2).

Ca ne change pas le temps d'exécution.

part2 :: Grid -> Int
part2 grid = load (grids !! y') where 
    (x, y) = findRepetition grids
    y' = x + (1000000000 - x) `mod` (y-x)
    grids = iterate' cycle grid
    cycle = tiltInDirection East
          . tiltInDirection South
          . tiltInDirection West
          . tiltInDirection North

Problème intéressant, il me rappelle le jour 17 de 2022.
J'ai écrit une fonction tilt qui fait tomber les briques vers l'ouest.
Pour cela, pour chaque ligne, je split la ligne selon # et pour chaque morceau du split, je sépare les O et les "." et je reconcatène tout en mettant les O d'abord et les "." ensuite.

Ensuite j'ai une fonction tiltInDirection qui se ramène à tilt en faisant des rotate et des reverse selon le cas de figure.

Pour la partie 2, je génère une suite infinie cyclique de North, West, South, East
et à partir de celle ci, je génère une liste infinie des différentes configurations après avoir effectué les tilts dans la direction donnée.
Dans cette liste, je cherche les indices x et y de la même configuration (fonction findRepetition) et la configuration qui nous intéresse est celle à l'indice x + (1000000000 - x) mod (y - x).

La partie 2 tourne en 600ms. Pas très satisfait mais ça reste raisonnable.

Voici le code

import           AOC.Prelude hiding (empty)
import           Data.List ((!!))
import           AOC (aoc)
import qualified Data.HashMap.Strict as Map
import           AOC.Parser (Parser, sepEndBy1, eol, some)
import           AOC.Util (flattenWithIndex, splitWhen)

data Rock = Empty | Round | Cube deriving (Eq, Enum)
data Direction = West | East | North | South
type Grid = [[Rock]]

instance Hashable Rock where
    hashWithSalt s rock = s `hashWithSalt` fromEnum rock

parser :: Parser Grid
parser = some rock `sepEndBy1` eol where
    rock = Empty <$ "." <|> Round <$ "O" <|> Cube <$ "#"

-- tilt to West
tilt :: Grid -> Grid
tilt = map perRow where
    perRow = intercalate [Cube] . map go . splitWhen (==Cube)
    go xs = rounded ++ empty where (rounded, empty) = partition (==Round) xs

tiltInDirection :: Direction -> Grid -> Grid
tiltInDirection = \case
    West -> tilt
    East -> map reverse . tilt . map reverse
    North -> transpose . tilt . transpose
    South -> reverse . transpose . tilt . transpose . reverse

-- return the first two indices of the same element in a infinite list of elements
findRepetition :: Hashable a => [a] -> (Int, Int)
findRepetition = go Map.empty . zip [0..] where
    go m ((i, x) : xs) =
        case m Map.!? x of
            Just j -> (j, i)
            Nothing -> go (Map.insert x i m) xs
    go _ [] = error "findRepetition: not an infinite list"

-- compute the laod of a grid
load :: Grid -> Int
load grid = sum . map score $ flattenWithIndex grid where
    score (i, _, Round) = len - i
    score _ = 0
    len = length grid

part1 :: Grid -> Int
part1 = load . tiltInDirection North

part2 :: Grid -> Int
part2 grid = load (grids !! y') where 
    (x, y) = findRepetition grids
    y' = x + (1000000000 - x) `mod` (y-x)
    grids = scanl' (flip tiltInDirection) grid directions
    directions = cycle [North, West, South, East]

solve :: Text -> IO ()
solve = aoc parser part1 part2