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

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

This problem asks us to find the number of unqiue
rows that satisfy the grouping constraint. The question
mark characters are wildcards.

A naive enumeration solution won't work here, there are
far too many possible assignments in part 2. This solution
uses a boxed array to implement a dynamic programing solution
to the problem.

Because the array is boxed we can lean on laziness to resolve
all of the data dependencies entailed by the dynamic programming
approach implicitly. By indexing on Ints representing the
suffix instead of suffixes as Map keys we get a performance
speedup.

To break the problem into increasingly smaller components
we solve it for all the suffixes of the input pattern and
group constraint.

>>> :{
:main +
"???.### 1,1,3
.??..??...?##. 1,1,3
?#?#?#?#?#?#?#? 1,3,1,6
????.#...#... 4,1,1
????.######..#####. 1,6,5
?###???????? 3,2,1
"
:}
21
525152

-}
module Main (main) where

import Advent (format, arrIx, stageTH)
import Data.Array (range, (!), listArray)
import Data.List (intercalate)

data C = C_HASH | C_DOT | C_QUESTION

stageTH

-- | Parse the input sequences and print out answers to both parts.
--
-- >>> :main
-- 6871
-- 2043098029844
main :: IO ()
IO ()
main =
 do input <- [format|2023 12 (@C* %d&,%n)*|]
    print (sum [ways g s | (s,g) <- input])
    print (sum [ways (concat (replicate 5 g)) (unfoldSprings s) | (s,g) <- input])

-- | Expand the input row as specified for part 2
unfoldSprings :: [C] -> [C]
unfoldSprings :: [C] -> [C]
unfoldSprings = [C] -> [[C]] -> [C]
forall a. [a] -> [[a]] -> [a]
intercalate [C
C_QUESTION] ([[C]] -> [C]) -> ([C] -> [[C]]) -> [C] -> [C]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [C] -> [[C]]
forall a. Int -> a -> [a]
replicate Int
5

-- | Given a group clue and an spring sequence, compute the number
-- of unique rows that match the clue.
ways :: [Int] -> [C] -> Int
ways :: [Int] -> [C] -> Int
ways [Int]
groups [C]
springs = Array (Int, Int) Int
answersA Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
! (Int
0,Int
0)
  where
    groupsN :: Int
groupsN = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
groups
    groupsA :: Array Int Int
groupsA = (Int, Int) -> [Int] -> Array Int Int
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
groupsN Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Int]
groups

    springsN :: Int
springsN = [C] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [C]
springs
    springsA :: Array Int C
springsA = (Int, Int) -> [C] -> Array Int C
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
springsN Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [C]
springs

    answersB :: ((Int, Int), (Int, Int))
answersB = ((Int
0, Int
0), (Int
groupsN, Int
springsN))
    answersA :: Array (Int, Int) Int
answersA = ((Int, Int), (Int, Int)) -> [Int] -> Array (Int, Int) Int
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray ((Int, Int), (Int, Int))
answersB [Int -> Int -> Int
go Int
i Int
j | (Int
i,Int
j) <- ((Int, Int), (Int, Int)) -> [(Int, Int)]
forall a. Ix a => (a, a) -> [a]
range ((Int, Int), (Int, Int))
answersB]

    -- recusive calls to go are memoized via the array
    rec :: Int -> Int -> Int
rec Int
groupI Int
springI = Array (Int, Int) Int
answersA Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
! (Int
groupI, Int
springI)

    -- compute the number of matches at suffixes starting at these indexes
    go :: Int -> Int -> Int
go Int
groupI Int
springI =
      let dotCase :: Int
dotCase  = Int -> Int -> Int
rec Int
groupI (Int
springI Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          hashCase :: Int
hashCase = Int -> Int -> Int
startGroup Int
groupI (Int
springI Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          {-# Inline hashCase #-} in -- improved benchmark results
      case Array Int C -> Int -> Maybe C
forall (a :: * -> * -> *) e i (f :: * -> *).
(IArray a e, Ix i, Alternative f) =>
a i e -> i -> f e
arrIx Array Int C
springsA Int
springI of
        Maybe C
Nothing         -> if Int
groupI Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
groupsN then Int
1 else Int
0
        Just C
C_DOT      -> Int
dotCase
        Just C
C_HASH     -> Int
hashCase
        Just C
C_QUESTION -> Int
hashCase Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dotCase

    -- compute the number of ways assuming the next group starts here
    startGroup :: Int -> Int -> Int
startGroup Int
groupI Int
springI =
      case Array Int Int -> Int -> Maybe Int
forall (a :: * -> * -> *) e i (f :: * -> *).
(IArray a e, Ix i, Alternative f) =>
a i e -> i -> f e
arrIx Array Int Int
groupsA Int
groupI of
        Just Int
n     -> Int -> Int -> Int -> Int
loopGroup (Int
groupI Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
springI (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Maybe Int
Nothing    -> Int
0 -- no group available to start

    loopGroup :: Int -> Int -> Int -> Int
loopGroup Int
groupI Int
springI Int
0 = -- end of group
      let dotCase :: Int
dotCase = Int -> Int -> Int
rec Int
groupI (Int
springI Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) in
      case Array Int C -> Int -> Maybe C
forall (a :: * -> * -> *) e i (f :: * -> *).
(IArray a e, Ix i, Alternative f) =>
a i e -> i -> f e
arrIx Array Int C
springsA Int
springI of
        Maybe C
Nothing         -> if Int
groupI Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
groupsN then Int
1 else Int
0
        Just C
C_DOT      -> Int
dotCase
        Just C
C_HASH     -> Int
0       -- group too long
        Just C
C_QUESTION -> Int
dotCase -- question mark forced to be dot

    loopGroup Int
groupI Int
springI Int
n = -- middle of group
      let hashCase :: Int
hashCase = Int -> Int -> Int -> Int
loopGroup Int
groupI (Int
springI Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) in
      case Array Int C -> Int -> Maybe C
forall (a :: * -> * -> *) e i (f :: * -> *).
(IArray a e, Ix i, Alternative f) =>
a i e -> i -> f e
arrIx Array Int C
springsA Int
springI of
        Maybe C
Nothing         -> Int
0 -- group too short
        Just C
C_DOT      -> Int
0 -- group too short
        Just C
C_HASH     -> Int
hashCase
        Just C
C_QUESTION -> Int
hashCase -- question mark forced to be hash