{-# Language QuasiQuotes, NumericUnderscores, ImportQualifiedPost #-}
{-|
Module      : Main
Description : Day 17 solution
Copyright   : (c) Eric Mertens, 2022
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2022/day/17>

This solution looks for cycles when the move index, piece index,
and tower envelope repeat. The tower envelope is the set of rocks that are
reachable from the row above the top of the tower.

>>> :main + ">>><<><>><<<>><>>><<<>>><<<><<<>><>><<>>\n"
3068
1514285714288

-}
module Main where

import Data.Array.Unboxed (Array, (!), listArray, rangeSize, bounds)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set

import Advent (format)
import Advent.Coord (Coord(C), coordRow, east, west, cardinal, coordCol, south)
import Advent.Search (bfsN)

-- | The set of five blocks
--
-- >>> mapM_ (putStrLn . Advent.Coord.drawCoords) pieces
-- ████
-- <BLANKLINE>
-- ·█·
-- █·█
-- ·█·
-- <BLANKLINE>
-- ··█
-- ··█
-- ███
-- <BLANKLINE>
-- █
-- █
-- █
-- █
-- <BLANKLINE>
-- ██
-- ██
-- <BLANKLINE>
pieces :: Array Int (Set Coord)
pieces :: Array Int (Set Coord)
pieces = (Int, Int) -> [Set Coord] -> Array Int (Set Coord)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0,Int
4) [
    [Coord] -> Set Coord
forall a. Ord a => [a] -> Set a
Set.fromList [Int -> Int -> Coord
C Int
0 Int
0, Int -> Int -> Coord
C Int
0 Int
1, Int -> Int -> Coord
C Int
0 Int
2, Int -> Int -> Coord
C Int
0 Int
3],
    [Coord] -> Set Coord
forall a. Ord a => [a] -> Set a
Set.fromList [Int -> Int -> Coord
C (-Int
2) Int
1, Int -> Int -> Coord
C (-Int
1) Int
0, Int -> Int -> Coord
C (-Int
1) Int
2, Int -> Int -> Coord
C Int
0 Int
1],
    [Coord] -> Set Coord
forall a. Ord a => [a] -> Set a
Set.fromList [Int -> Int -> Coord
C Int
0 Int
0, Int -> Int -> Coord
C Int
0 Int
1, Int -> Int -> Coord
C Int
0 Int
2, Int -> Int -> Coord
C (-Int
1) Int
2, Int -> Int -> Coord
C (-Int
2) Int
2],
    [Coord] -> Set Coord
forall a. Ord a => [a] -> Set a
Set.fromList [Int -> Int -> Coord
C Int
0 Int
0, Int -> Int -> Coord
C (-Int
1) Int
0, Int -> Int -> Coord
C (-Int
2) Int
0, Int -> Int -> Coord
C (-Int
3) Int
0],
    [Coord] -> Set Coord
forall a. Ord a => [a] -> Set a
Set.fromList [Int -> Int -> Coord
C (-Int
1) Int
0, Int -> Int -> Coord
C (-Int
1) Int
1, Int -> Int -> Coord
C Int
0 Int
0, Int -> Int -> Coord
C Int
0 Int
1]
  ]

-- | The initial floor
initialStuff :: Set Coord
initialStuff :: Set Coord
initialStuff = [Coord] -> Set Coord
forall a. Ord a => [a] -> Set a
Set.fromList [Int -> Int -> Coord
C Int
0 Int
x | Int
x <- [Int
0..Int
6]]

-- |
-- >>> :main
-- 3137
-- 1564705882327
main :: IO ()
IO ()
main =
 do [Coord]
moves <- (Char -> Coord) -> [Char] -> [Coord]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Coord
dir ([Char] -> [Coord]) -> IO [Char] -> IO [Coord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [format|2022 17 %s%n|]
    let movesArray :: Array Int Coord
movesArray = (Int, Int) -> [Coord] -> Array Int Coord
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0, [Coord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Coord]
movesInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Coord]
moves

    let states :: [(Int, Int, Set Coord)]
states = ((Int, Int, Set Coord) -> (Int, Int, Set Coord))
-> (Int, Int, Set Coord) -> [(Int, Int, Set Coord)]
forall a. (a -> a) -> a -> [a]
iterate (Array Int Coord -> (Int, Int, Set Coord) -> (Int, Int, Set Coord)
place Array Int Coord
movesArray) (Int
0, Int
0, Set Coord
initialStuff)
    let heightAt :: Int -> Int
heightAt Int
i = case [(Int, Int, Set Coord)]
states [(Int, Int, Set Coord)] -> Int -> (Int, Int, Set Coord)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i of (Int
_,Int
_,Set Coord
stuff) -> Set Coord -> Int
height Set Coord
stuff

    -- part 1
    Int -> IO ()
forall a. Show a => a -> IO ()
print (Int -> Int
heightAt Int
2022)

    -- part 2
    let (Int
cyc1,Int
cyc2) = [(Int, Int, Set Coord)] -> (Int, Int)
forall a. Ord a => [a] -> (Int, Int)
findCycle [(Int
i,Int
j,Set Coord -> Set Coord
normalize Set Coord
stuff) | (Int
i,Int
j,Set Coord
stuff) <- [(Int, Int, Set Coord)]
states]
    let cycLen :: Int
cycLen = Int
cyc2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
cyc1

    let (Int
cycCnt, Int
overflow) = (Int
1_000_000_000_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
cyc1) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
cycLen
    let cycHeight :: Int
cycHeight = Int -> Int
heightAt Int
cyc2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
heightAt Int
cyc1
    Int -> IO ()
forall a. Show a => a -> IO ()
print (Int -> Int
heightAt (Int
cyc2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
overflow) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cycHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
cycCntInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))

-- | Height of a tower
height :: Set Coord -> Int
height :: Set Coord -> Int
height Set Coord
stuff = - Coord -> Int
coordRow (Set Coord -> Coord
forall a. Ord a => Set a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum Set Coord
stuff)

-- | Renumber a tower so that it's top starts at 0
normalize :: Set Coord -> Set Coord
normalize :: Set Coord -> Set Coord
normalize Set Coord
stuff = Set Coord -> Coord -> Set Coord
translate Set Coord
stuff (Int -> Int -> Coord
C (Set Coord -> Int
height Set Coord
stuff) Int
0)

-- | Returns two indexes showing where a cycle starts and ends
findCycle :: Ord a => [a] -> (Int,Int)
findCycle :: forall a. Ord a => [a] -> (Int, Int)
findCycle = Map a Int -> Int -> [a] -> (Int, Int)
forall {k} {b}. (Ord k, Num b) => Map k b -> b -> [k] -> (b, b)
go Map a Int
forall k a. Map k a
Map.empty Int
0
  where
    go :: Map k b -> b -> [k] -> (b, b)
go Map k b
_ b
_ [] = [Char] -> (b, b)
forall a. HasCallStack => [Char] -> a
error [Char]
"no cycle"
    go Map k b
seen b
i (k
x:[k]
xs) =
      case k -> Map k b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
x Map k b
seen of
        Maybe b
Nothing -> Map k b -> b -> [k] -> (b, b)
go (k -> b -> Map k b -> Map k b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
x b
i Map k b
seen)(b
ib -> b -> b
forall a. Num a => a -> a -> a
+b
1) [k]
xs
        Just b
j -> (b
j,b
i)

-- | Map the input characters to jet vectors
dir :: Char -> Coord
dir :: Char -> Coord
dir Char
'>' = Coord
east
dir Char
'<' = Coord
west
dir  Char
_  = [Char] -> Coord
forall a. HasCallStack => [Char] -> a
error [Char]
"bad dir"

-- | Predicate for coordinates that are inside the tower walls
inWalls :: Coord -> Bool
inWalls :: Coord -> Bool
inWalls (C Int
_ Int
x) = Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6

-- | Translate a piece around by a vector
translate :: Set Coord -> Coord -> Set Coord
translate :: Set Coord -> Coord -> Set Coord
translate Set Coord
p Coord
c = (Coord -> Coord) -> Set Coord -> Set Coord
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic (Coord
cCoord -> Coord -> Coord
forall a. Num a => a -> a -> a
+) Set Coord
p

-- | Remove all blocks that aren't reachable from the top of the board
clean :: Set Coord -> Set Coord
clean :: Set Coord -> Set Coord
clean Set Coord
stuff = (Coord -> Bool) -> Set Coord -> Set Coord
forall a. (a -> Bool) -> Set a -> Set a
Set.filter Coord -> Bool
alive Set Coord
stuff
  where
    ymin :: Int
ymin = Coord -> Int
coordRow (Set Coord -> Coord
forall a. Ord a => Set a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum Set Coord
stuff)
    step :: Coord -> [Coord]
step Coord
c = [Coord
n | Coord
n <- Coord -> [Coord]
cardinal Coord
c, Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Coord -> Int
coordCol Coord
n, Coord -> Int
coordCol Coord
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6, Coord -> Int
coordRow Coord
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
ymin, Coord -> Set Coord -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember Coord
n Set Coord
stuff]
    air :: [Coord]
air = (Coord -> [Coord]) -> [Coord] -> [Coord]
forall a. Ord a => (a -> [a]) -> [a] -> [a]
bfsN Coord -> [Coord]
step [Int -> Int -> Coord
C Int
ymin Int
x | Int
x <- [Int
0..Int
6], Coord -> Set Coord -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (Int -> Int -> Coord
C Int
ymin Int
x) Set Coord
stuff]
    alive :: Coord -> Bool
alive Coord
x = (Coord -> Bool) -> [Coord] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Coord -> [Coord] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Coord]
air) (Coord -> [Coord]
cardinal Coord
x) Bool -> Bool -> Bool
|| Coord -> Int
coordRow Coord
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ymin

-- | Piece the next piece on the top of the tower returning the updated
-- piece index, jet index, and tower contents. The tower is pruned to
-- exclude all rocks that are not reachable from the top of the tower.
place ::
  Array Int Coord      {- ^ jet vectors                   -} ->
  (Int, Int, Set Coord) {- ^ piece index, jet index, rocks -} ->
  (Int, Int, Set Coord) {- ^ piece index, jet index, rocks -}
place :: Array Int Coord -> (Int, Int, Set Coord) -> (Int, Int, Set Coord)
place Array Int Coord
jets (Int
i,Int
j,Set Coord
stuff) =
    case Int -> Set Coord -> (Set Coord, Int)
drive Int
j Set Coord
start of
      (Set Coord
stuck, Int
j') -> (Int
i', Int
j', Set Coord -> Set Coord
clean (Set Coord -> Set Coord -> Set Coord
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Coord
stuff Set Coord
stuck))
    where
      i' :: Int
i' = (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod`Int
5
      start :: Set Coord
start = Set Coord -> Coord -> Set Coord
translate (Array Int (Set Coord)
pieces Array Int (Set Coord) -> Int -> Set Coord
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
i) (Int -> Int -> Coord
C (-Set Coord -> Int
height Set Coord
stuffInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
4) Int
2)

      isCrashed :: Set Coord -> Bool
isCrashed Set Coord
piece = Bool -> Bool
not ((Coord -> Bool) -> Set Coord -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Coord -> Bool
inWalls Set Coord
piece Bool -> Bool -> Bool
&& Set Coord -> Set Coord -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set Coord
stuff Set Coord
piece)

      drive :: Int -> Set Coord -> (Set Coord, Int)
drive Int
dj Set Coord
p1
        | Set Coord -> Set Coord -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set Coord
stuff Set Coord
p4 = Int -> Set Coord -> (Set Coord, Int)
drive Int
dj' Set Coord
p4
        | Bool
otherwise             = (Set Coord
p3, Int
dj')
        where
            dj' :: Int
dj' = (Int
djInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int, Int) -> Int
forall a. Ix a => (a, a) -> Int
rangeSize (Array Int Coord -> (Int, Int)
forall i. Ix i => Array i Coord -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Int Coord
jets)
            p2 :: Set Coord
p2 = Set Coord -> Coord -> Set Coord
translate Set Coord
p1 (Array Int Coord
jets Array Int Coord -> Int -> Coord
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
dj)
            p3 :: Set Coord
p3 | Set Coord -> Bool
isCrashed Set Coord
p2 = Set Coord
p1
               | Bool
otherwise    = Set Coord
p2
            p4 :: Set Coord
p4 = Set Coord -> Coord -> Set Coord
translate Set Coord
p3 Coord
south