{-|
Module:         Day25
Description:    <https://adventofcode.com/2021/day/25 Day 25: Sea Cucumber>
-}
{-# LANGUAGE FlexibleContexts, TypeApplications #-}
module Day25 (day25) where

import Control.Arrow (first, second)
import Control.Monad (guard)
import Data.Array.Unboxed (UArray, (!), (//), accumArray, assocs)
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T (length, lines, unpack)

day25 :: Text -> Maybe Int
day25 :: Text -> Maybe Int
day25 Text
input = do
    let inputs :: [Text]
inputs = Text -> [Text]
T.lines Text
input
        height :: Int
height = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
inputs
    Int
width <- [Maybe Int] -> Maybe Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Maybe Int] -> Maybe Int) -> [Maybe Int] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Maybe Int
forall a. Maybe a
Nothing Maybe Int -> [Maybe Int] -> [Maybe Int]
forall a. a -> [a] -> [a]
: (Text -> Maybe Int) -> [Text] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Text -> Int) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length) [Text]
inputs
    let state0 :: UArray (Int, Int) Char
state0 = (Char -> Char -> Char)
-> Char
-> ((Int, Int), (Int, Int))
-> [((Int, Int), Char)]
-> UArray (Int, Int) Char
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
accumArray @UArray ((Char -> Char) -> Char -> Char -> Char
forall a b. a -> b -> a
const Char -> Char
forall a. a -> a
id) Char
'.' ((Int
0, Int
0), (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            [((Int
y, Int
x), Char
c) | (Int
y, Text
line) <- [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Text]
inputs, (Int
x, Char
c) <- [Int] -> [Char] -> [(Int, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([Char] -> [(Int, Char)]) -> [Char] -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
line]
        step :: a (Int, Int) Char -> f (a (Int, Int) Char)
step a (Int, Int) Char
state = a (Int, Int) Char
state'' a (Int, Int) Char -> f () -> f (a (Int, Int) Char)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> f ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool
a Bool -> Bool -> Bool
|| Bool
b) where
            (Bool
a, a (Int, Int) Char
state') = ((Int, Int) -> (Int, Int))
-> Char -> a (Int, Int) Char -> (Bool, a (Int, Int) Char)
forall (a :: * -> * -> *) i.
(IArray a Char, Ix i) =>
(i -> i) -> Char -> a i Char -> (Bool, a i Char)
step' ((Int -> Int) -> (Int, Int) -> (Int, Int)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Int -> Int) -> (Int, Int) -> (Int, Int))
-> (Int -> Int) -> (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ \Int
x -> Int -> Int
forall a. Enum a => a -> a
succ Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
width) Char
'>' a (Int, Int) Char
state
            (Bool
b, a (Int, Int) Char
state'') = ((Int, Int) -> (Int, Int))
-> Char -> a (Int, Int) Char -> (Bool, a (Int, Int) Char)
forall (a :: * -> * -> *) i.
(IArray a Char, Ix i) =>
(i -> i) -> Char -> a i Char -> (Bool, a i Char)
step' ((Int -> Int) -> (Int, Int) -> (Int, Int)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Int -> Int) -> (Int, Int) -> (Int, Int))
-> (Int -> Int) -> (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ \Int
y -> Int -> Int
forall a. Enum a => a -> a
succ Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
height) Char
'v' a (Int, Int) Char
state'
        step' :: (i -> i) -> Char -> a i Char -> (Bool, a i Char)
step' i -> i
f Char
d a i Char
state = (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(i, Char)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(i, Char)]
acc, a i Char
state a i Char -> [(i, Char)] -> a i Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(i, Char)]
acc) where
            acc :: [(i, Char)]
acc = do
                (i
i, Char
c) <- a i Char -> [(i, Char)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs a i Char
state
                Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
d Bool -> Bool -> Bool
&& a i Char
state a i Char -> i -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! i -> i
f i
i Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
                [(i
i, Char
'.'), (i -> i
f i
i, Char
d)]
    Int -> Maybe Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Maybe (UArray (Int, Int) Char)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Maybe (UArray (Int, Int) Char)] -> Int)
-> [Maybe (UArray (Int, Int) Char)] -> Int
forall a b. (a -> b) -> a -> b
$ (Maybe (UArray (Int, Int) Char) -> Bool)
-> [Maybe (UArray (Int, Int) Char)]
-> [Maybe (UArray (Int, Int) Char)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Maybe (UArray (Int, Int) Char) -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe (UArray (Int, Int) Char)]
 -> [Maybe (UArray (Int, Int) Char)])
-> [Maybe (UArray (Int, Int) Char)]
-> [Maybe (UArray (Int, Int) Char)]
forall a b. (a -> b) -> a -> b
$ (Maybe (UArray (Int, Int) Char) -> Maybe (UArray (Int, Int) Char))
-> Maybe (UArray (Int, Int) Char)
-> [Maybe (UArray (Int, Int) Char)]
forall a. (a -> a) -> a -> [a]
iterate (Maybe (UArray (Int, Int) Char)
-> (UArray (Int, Int) Char -> Maybe (UArray (Int, Int) Char))
-> Maybe (UArray (Int, Int) Char)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UArray (Int, Int) Char -> Maybe (UArray (Int, Int) Char)
forall (f :: * -> *) (a :: * -> * -> *).
(Alternative f, IArray a Char) =>
a (Int, Int) Char -> f (a (Int, Int) Char)
step) (Maybe (UArray (Int, Int) Char)
 -> [Maybe (UArray (Int, Int) Char)])
-> Maybe (UArray (Int, Int) Char)
-> [Maybe (UArray (Int, Int) Char)]
forall a b. (a -> b) -> a -> b
$ UArray (Int, Int) Char -> Maybe (UArray (Int, Int) Char)
forall a. a -> Maybe a
Just UArray (Int, Int) Char
state0