{-|
Module:         Day4
Description:    <https://adventofcode.com/2021/day/4 Day 4: Giant Squid>
-}
{-# LANGUAGE TypeFamilies #-}
module Day4 (day4) where

import Control.Arrow ((&&&))
import qualified Data.IntMap as IntMap ((!?), fromListWith)
import Data.List (transpose)
import Data.List.NonEmpty (nonEmpty)
import Data.Maybe (mapMaybe)
import Data.Semigroup (Max(Max), Min(Min), sconcat)
import Data.Text (Text)
import Data.Void (Void)
import Text.Megaparsec (MonadParsec, ParseErrorBundle, Token, count, eof, parse, sepBy, sepBy1, sepEndBy, skipSome)
import Text.Megaparsec.Char (char, hspace, hspace1, newline)
import Text.Megaparsec.Char.Lexer (decimal)

parser :: (MonadParsec e s m, Token s ~ Char) => m ([Int], [[[Int]]])
parser :: m ([Int], [[[Int]]])
parser = do
    [Int]
draws <- m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal m Int -> m Char -> m [Int]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
',' m [Int] -> m () -> m [Int]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m Char -> m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipSome m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
    [[[Int]]]
boards <- m [[Int]]
board m [[Int]] -> m Char -> m [[[Int]]]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
    ([Int]
draws, [[[Int]]]
boards) ([Int], [[[Int]]]) -> m () -> m ([Int], [[[Int]]])
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  where
    board :: m [[Int]]
board = do
        [Int]
first <- m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace m () -> m [Int] -> m [Int]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal m Int -> m () -> m [Int]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1 m [Int] -> m Char -> m [Int]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
        let width :: Int
width = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
first
        [[Int]]
rest <- Int -> m [Int]
forall e s (f :: * -> *) a.
(MonadParsec e s f, Num a, Token s ~ Char) =>
Int -> f [a]
line Int
width m [Int] -> m Char -> m [[Int]]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy` m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
        [[Int]] -> m [[Int]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Int]] -> m [[Int]]) -> [[Int]] -> m [[Int]]
forall a b. (a -> b) -> a -> b
$ [Int]
first[Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
:[[Int]]
rest
    line :: Int -> f [a]
line Int
n = (:) (a -> [a] -> [a]) -> f a -> f ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace f () -> f a -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal) f ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> f a -> f [a]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (f ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1 f () -> f a -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal)

day4 :: Text -> Either (ParseErrorBundle Text Void) (Maybe (Int, Int))
day4 :: Text -> Either (ParseErrorBundle Text Void) (Maybe (Int, Int))
day4 Text
input = do
    ([Int]
draws, [[[Int]]]
boards) <- Parsec Void Text ([Int], [[[Int]]])
-> String
-> Text
-> Either (ParseErrorBundle Text Void) ([Int], [[[Int]]])
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text ([Int], [[[Int]]])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ([Int], [[[Int]]])
parser String
"" Text
input
    let drawTurns :: IntMap Int
drawTurns = (Int -> Int -> Int) -> [(Int, Int)] -> IntMap Int
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith Int -> Int -> Int
forall a b. a -> b -> a
const ([(Int, Int)] -> IntMap Int) -> [(Int, Int)] -> IntMap Int
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
draws [Int
0 :: Int ..]
        scoreBoard :: [[Int]] -> Maybe (Int, Int)
scoreBoard [[Int]]
board = do
            let turns :: [[Maybe Int]]
turns = (Int -> Maybe Int) -> [Int] -> [Maybe Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IntMap Int
drawTurns IntMap Int -> Int -> Maybe Int
forall a. IntMap a -> Int -> Maybe a
IntMap.!?) ([Int] -> [Maybe Int]) -> [[Int]] -> [[Maybe Int]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Int]]
board
                rows :: [Int]
rows = ([Maybe Int] -> Maybe Int) -> [[Maybe Int]] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (([Int] -> Int) -> Maybe [Int] -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Maybe [Int] -> Maybe Int)
-> ([Maybe Int] -> Maybe [Int]) -> [Maybe Int] -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Int] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence) [[Maybe Int]]
turns
                cols :: [Int]
cols = ([Maybe Int] -> Maybe Int) -> [[Maybe Int]] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (([Int] -> Int) -> Maybe [Int] -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Maybe [Int] -> Maybe Int)
-> ([Maybe Int] -> Maybe [Int]) -> [Maybe Int] -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Int] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence) ([[Maybe Int]] -> [Int]) -> [[Maybe Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[Maybe Int]] -> [[Maybe Int]]
forall a. [[a]] -> [[a]]
transpose [[Maybe Int]]
turns
            Int
turn <- NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (NonEmpty Int -> Int) -> Maybe (NonEmpty Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Int]
rows [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
cols)
            let remaining :: Int
remaining = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
                  [ Int
value
                  | ([Int], [Maybe Int])
row <- [[Int]] -> [[Maybe Int]] -> [([Int], [Maybe Int])]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Int]]
board [[Maybe Int]]
turns
                  , (Int
value, Maybe Int
maybeTurn) <- ([Int] -> [Maybe Int] -> [(Int, Maybe Int)])
-> ([Int], [Maybe Int]) -> [(Int, Maybe Int)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Int] -> [Maybe Int] -> [(Int, Maybe Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int], [Maybe Int])
row
                  , Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
turn) Maybe Int
maybeTurn
                  ]
            (Int, Int) -> Maybe (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
turn, [Int]
draws [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
turn Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
remaining)
    Maybe (Int, Int)
-> Either (ParseErrorBundle Text Void) (Maybe (Int, Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Int, Int)
 -> Either (ParseErrorBundle Text Void) (Maybe (Int, Int)))
-> Maybe (Int, Int)
-> Either (ParseErrorBundle Text Void) (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$ do
        NonEmpty (Int, Int)
scores <- [(Int, Int)] -> Maybe (NonEmpty (Int, Int))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([(Int, Int)] -> Maybe (NonEmpty (Int, Int)))
-> [(Int, Int)] -> Maybe (NonEmpty (Int, Int))
forall a b. (a -> b) -> a -> b
$ ([[Int]] -> Maybe (Int, Int)) -> [[[Int]]] -> [(Int, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [[Int]] -> Maybe (Int, Int)
scoreBoard [[[Int]]]
boards
        let (Min (Int
_, Int
minScore), Max (Int
_, Int
maxScore)) = NonEmpty (Min (Int, Int), Max (Int, Int))
-> (Min (Int, Int), Max (Int, Int))
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty (Min (Int, Int), Max (Int, Int))
 -> (Min (Int, Int), Max (Int, Int)))
-> NonEmpty (Min (Int, Int), Max (Int, Int))
-> (Min (Int, Int), Max (Int, Int))
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Min (Int, Int)
forall a. a -> Min a
Min ((Int, Int) -> Min (Int, Int))
-> ((Int, Int) -> Max (Int, Int))
-> (Int, Int)
-> (Min (Int, Int), Max (Int, Int))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Int, Int) -> Max (Int, Int)
forall a. a -> Max a
Max) ((Int, Int) -> (Min (Int, Int), Max (Int, Int)))
-> NonEmpty (Int, Int) -> NonEmpty (Min (Int, Int), Max (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Int, Int)
scores
        (Int, Int) -> Maybe (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
minScore, Int
maxScore)