Skip to content

Commit

Permalink
a bit of cleanup.
Browse files Browse the repository at this point in the history
  • Loading branch information
@Javran
Javran committed Feb 2, 2024
1 parent 48e6ff6 commit 86afb42
Showing 1 changed file with 77 additions and 95 deletions.
172 changes: 77 additions & 95 deletions src/Javran/AdventOfCode/Y2023/Day12.hs
View file
Original file line number Diff line number Diff line change
@@ -1,31 +1,11 @@
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
{-# OPTIONS_GHC -Wno-typed-holes #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -fdefer-typed-holes #-}

module Javran.AdventOfCode.Y2023.Day12 () where

{- HLINT ignore -}

import Control.Applicative
import Control.Monad
import Data.Char
import Data.Function
import Data.Function.Memoize (memoFix, memoFix2)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Data.Function.Memoize (memoFix2)
import Data.List
import Data.List.Split hiding (sepBy)
import qualified Data.Map.Strict as M
import Data.Monoid hiding (First, Last)
import Data.Semigroup
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Vector as V
import Debug.Trace
import GHC.Generics (Generic)
import Javran.AdventOfCode.Prelude
import Javran.AdventOfCode.TestExtra (consumeExtra)
import Text.ParserCombinators.ReadP hiding (count, get, many)
Expand All @@ -50,6 +30,9 @@ rowP = do
pure (xs, ys)

{-
# General notes
For this problem we first implement a slow method by constructing
valid spring configurations one at a time.
Expand All @@ -62,63 +45,65 @@ rowP = do
on established results.
For this dynamic programming / memoization is used.
-}
{-
since damaged springs are groupped together, we may want to generate
a consecutive number of `#`s, optionally followed by a `.`
(iff. this number is not the last one).
and we want to know if this segment of spring setup is consistent with
what we are given. this function attempts to match and take away prefixes.
# "Left" and "Right"
TODO: could use `cases` but that'll mess up identation so let's go with this for now...
-}
match :: [Maybe SpCond] -> [SpCond] -> Maybe [Maybe SpCond]
match ls rs = case (ls, rs) of
([], _ : _) -> Nothing
(xs, []) -> Just xs
(x : xs, y : ys) -> case x of
Nothing -> match xs ys
Just x' -> guard (x' == y) >> match xs ys
This problem is about finding spring configurations that satisifies
both descriptions given in a row. The code below refer to those two
descriptions "Left" and "Right".
{-
TODO: ideas:
- "Left" is the description given first, which consists of `.`, `#`, and `?`
that matches the exact length of the spring configuration.
- I think this is just nonogram puzzles but with some parts
already filled in?
- "Right" is the description given later, which is a sequence of numbers
describing clusters of consecutive damaged springs.
- might have something to do with an integer partitioning problem?
for this problem, given a sequence of numbers, we know the minimum length
needed to have that particular arrangement.
# Random thoughts
and for # of remaining spaces S we want to divide up S into integers
(nofn-negative, I think) and this will be the setup for extra spaces
(not counting the mandantory one that seperates operational ones apart)
This somewhat reminds me of nongram puzzles, especially the sequence of numbers.
TODO: probably dynamic programming the more I think about this:
if we can reuse partially constructed answers.
-}

Let's try this:
let LHS description be l[_] (damanged / operational),
and RHS description be r[_] (a number)
{-
`match xs ys` matches left pattern `xs` against prefix of
a concrete spring configuration `ys`.
I think it should be possible to come up with a function f,
For a match to be successful, `ys` must be as long as `xs`
and values in all positions must be compatible.
where f[i][j] is the # of ways you can arrange LHS of index 0..i (inclusive)
to satisfy RHS index of 0..j (inclusive).
and on top of this, we also constraint that we only count cases
where l[i] is a damaged one (this is so that we can better keep track of
where to "insert" an operational one).
Upon successful matches, remaining part of `ys` is returned.
-}
match :: [Maybe SpCond] -> [SpCond] -> Maybe [Maybe SpCond]
match = \cases
[] (_ : _) -> Nothing
xs [] -> Just xs
(x : xs) (y : ys) -> case x of
Nothing -> match xs ys
Just x' -> guard (x' == y) >> match xs ys

Update: we need to take into account existing setup, which I think
is easy to do.
{-
Helper to verify a match of exact length,
and return different things as if this is a if-expression.
-}
matchExactlyThenElse :: [Maybe SpCond] -> [SpCond] -> a -> a -> a
matchExactlyThenElse ls rs tt ff =
case match ls rs of
Nothing -> ff
Just [] -> tt
Just (_ : _) ->
{-
ls and rs should be of the same length.
Reaching this branch indicates some mistakes are made in the implementation.
-}
error "leftover found, supposed to match exactly."

{-
TODO: `dp` and `solve` functions are not well explained.
-}

{-
Computes the number of ways that L[0 .. i] (inclusive)
can be constructed satisfying R[0 .. j] (inclusive)
-}
dp :: (Int -> Maybe SpCond) -> (Int -> Int) -> Int -> Int -> Integer
dp getL getR = memoFix2 \f i j -> case compare j 0 of
Expand All @@ -132,27 +117,19 @@ dp getL getR = memoFix2 \f i j -> case compare j 0 of
rs :: [SpCond]
rs = replicate (i + 1 - r0) SDot <> replicate r0 SHash
in -- try simple matching here to determine.
case match ls rs of
Nothing -> 0
Just [] -> 1
Just (_ : _) -> error "should not be reachable"
matchExactlyThenElse ls rs 1 0
GT ->
{-
TODO:
dp[i][j] = sum of { dp[i'][j-1] }, where we need to:
- make sure last part (r[j] and paddings) matches
- determine the minimal i' possible
-}
let
iMax = i - getR j - 1
iMin = sum (fmap getR [0 .. j - 1]) + j - 2
testAndCount i' =
-- here we need to make sure L[i' + 1 .. i] matches.
case match ls rs of
Nothing -> 0
Just [] -> f i' (j - 1)
Just (_ : _) -> error "should not be reachable"
matchExactlyThenElse ls rs (f i' (j - 1)) 0
where
rj = getR j
ls :: [Maybe SpCond]
Expand All @@ -167,35 +144,40 @@ dp getL getR = memoFix2 \f i j -> case compare j 0 of
solve :: [Maybe SpCond] -> [Int] -> Integer
solve ls rs = sum (fmap testAndCount [iMin .. length ls - 1])
where
l = length ls
testAndCount i' = case match ls' rs' of
Nothing -> 0
Just _ -> dp getL getR i' (length rs - 1)
l = V.length lsV
testAndCount i' =
matchExactlyThenElse ls' rs' (dp getL getR i' (length rs - 1)) 0
where
rs' = replicate (l - i' - 1) SDot
ls' = fmap getL [i' + 1 .. l - 1]

iMin = sum rs + length rs - 2
getL = (ls !!)
getR = (rs !!)
iMin = sum rs + V.length rsV - 2
lsV = V.fromList ls
rsV = V.fromList rs
getL = (lsV V.!)
getR = (rsV V.!)

instance Solution Day12 where
solutionRun _ SolutionContext {getInputS, answerShow, answerS} = do
(ex, rawInput) <- consumeExtra getInputS
let xs = fmap (consumeOrDie rowP) . lines $ rawInput
ans1 = fmap (uncurry solve) xs
showIndividual = isJust ex

when showIndividual do
answerS $ unwords (fmap show ans1)

answerShow $ sum ans1
let solve2 (lsPre, rsPre) = solve ls rs
where
ls = intercalate [Nothing] (replicate 5 lsPre)
rs = (concat (replicate 5 rsPre))
ans2 = fmap solve2 xs
when showIndividual do
answerS $ unwords (fmap show ans2)

answerShow $ sum ans2
let inp1 = fmap (consumeOrDie rowP) . lines $ rawInput
solveAll inp = do
let ways = fmap (uncurry solve) inp
{-
The extra data serves as a marker
that we print result from individual rows
to make it easier for troubleshooting.
-}
when (isJust ex) do
answerS $ unwords (fmap show ways)
answerShow $ sum ways

solveAll inp1

let inp2 = fmap five inp1
five (ls, rs) =
( intercalate [Nothing] (replicate 5 ls)
, concat (replicate 5 rs)
)

solveAll inp2

0 comments on commit 86afb42

Please sign in to comment.