From 86afb42a77c48a93e2ec655587ce3a260dd7a0af Mon Sep 17 00:00:00 2001 From: Javran Cheng Date: Thu, 1 Feb 2024 21:07:56 -0800 Subject: [PATCH] a bit of cleanup. --- src/Javran/AdventOfCode/Y2023/Day12.hs | 172 +++++++++++-------------- 1 file changed, 77 insertions(+), 95 deletions(-) diff --git a/src/Javran/AdventOfCode/Y2023/Day12.hs b/src/Javran/AdventOfCode/Y2023/Day12.hs index de68b0c1..2ffaaf7b 100644 --- a/src/Javran/AdventOfCode/Y2023/Day12.hs +++ b/src/Javran/AdventOfCode/Y2023/Day12.hs @@ -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) @@ -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. @@ -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 @@ -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] @@ -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