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

<https://adventofcode.com/2023/day/14>

>>> :{
:main +
"O....#....
O.OO#....#
.....##...
OO.#O....O
.O.....O#.
O.#..O.#.#
..O..#O..O
.......O..
#....###..
#OO..#....
"
:}
136
64

-}
module Main (main) where

import Advent (getInputLines, times)
import Data.List (transpose)
import Data.Map qualified as Map

-- | Load the input grid and print the answers to both parts.
--
-- >>> :main
-- 109596
-- 96105
main :: IO ()
IO ()
main =
 do input <- [[Char]] -> [[Char]]
forall a. [[a]] -> [[a]]
transpose ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO [[Char]]
getInputLines Int
2023 Int
14

    print (load (map shift input))

    let process       = Int -> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a. Int -> (a -> a) -> a -> a
times Int
4 ([[Char]] -> [[Char]]
forall a. [[a]] -> [[a]]
transpose ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
shift))
        outs          = ([[Char]] -> [[Char]]) -> [[Char]] -> [[[Char]]]
forall a. (a -> a) -> a -> [a]
iterate [[Char]] -> [[Char]]
process [[Char]]
input
        (start, next) = findCycle outs
        i = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
1_000_000_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` (Int
next Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start)
    print (load (outs !! i))

-- | Compute the load on the north support beams
load :: [String] -> Int
load :: [[Char]] -> Int
load = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> ([[Char]] -> [Int]) -> [[Char]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
weight
  where
    weight :: [Char] -> Int
weight [Char]
xs = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
i | (Int
i, Char
'O') <- [Int] -> [Char] -> [(Int, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
n, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 ..] [Char]
xs]
      where
        n :: Int
n = [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
xs

-- | Shift the rocks on a single row to the left
--
-- >>> shift "..OO.O.#O.OO#"
-- "OOO....#OOO.#"
shift :: String -> String
shift :: [Char] -> [Char]
shift = Int -> [Char] -> [Char]
go Int
0
  where
    go :: Int -> [Char] -> [Char]
go Int
n (Char
'.':[Char]
xs) = Int -> [Char] -> [Char]
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Char]
xs
    go Int
n (Char
'O':[Char]
xs) = Char
'O' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char] -> [Char]
go Int
n [Char]
xs
    go Int
n (Char
'#':[Char]
xs) = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
n Char
'.' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
'#' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char] -> [Char]
go Int
0 [Char]
xs
    go Int
n [Char]
_        = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
n Char
'.'

-- | Report the first and second index a duplicate element
-- is found in the list.
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
i b -> b -> b
forall a. Num a => a -> a -> a
+ b
1) [k]
xs
        Just b
j  -> (b
j, b
i)