From c8e8b43c7b965abce34195ae84482dc32dd52660 Mon Sep 17 00:00:00 2001 From: Javran Cheng Date: Sun, 11 Feb 2024 21:53:59 -0800 Subject: [PATCH] d18 cleanup done. happy with it now. --- src/Javran/AdventOfCode/Y2023/Day18.hs | 316 +++++++++++++++++-------- 1 file changed, 215 insertions(+), 101 deletions(-) diff --git a/src/Javran/AdventOfCode/Y2023/Day18.hs b/src/Javran/AdventOfCode/Y2023/Day18.hs index d1ac9f7..6ced231 100644 --- a/src/Javran/AdventOfCode/Y2023/Day18.hs +++ b/src/Javran/AdventOfCode/Y2023/Day18.hs @@ -2,7 +2,9 @@ module Javran.AdventOfCode.Y2023.Day18 () where import Control.Monad import Data.Bits (unsafeShiftR, (.&.)) +import Data.Containers.ListUtils (nubOrd) import qualified Data.DList as DL +import qualified Data.IntMap.Strict as IM import Data.List import qualified Data.Map.Strict as M import Data.Monoid @@ -214,13 +216,54 @@ coordPack coords = (f, g) -} newtype Blk = Blk CoordP deriving (Eq, Ord) --- TODO: below are still messy to be cleaned up. - {- - "in" and "out" pair of a turn. + Returns local "in" and "out" block given a turn. + + This function helps to find an initial set of blocks + for starting the floodfill process. + + For a left turn that is a `R` followed by `U`: + + ^ + | + (i) U + | + --R--> A ..... + . + . (o) + . + + where `(i)` is the "in" block and `(o)` the "out" block, + and `A` the turning point (in this particular example, + it is also top-left point of the `(o)` block) + + Similarly, for a right turn that is a `L` followed by `U`: + + ^ + | + U (i) + | + ..... A <--L-- + . + (o) . + . + + Rotate those two examples to get the complete table. + + Note that the turn alone does not decide if the corresponding blocks + are inside or outside, but one of them + must be inside and the other one outside, which all depends on + whether the loop goes clockwise or counterclockwise. + + - for a clockwise loop, right turn's "in" are inside blocks, + and left turn's "out" are inside blocks. + + - for a counterclockwise loop, left turn's "in" are inside, + and right turn's "out" are inside. + + In other words, if a turn "agrees" with loop's direction, + it's "in" block is the block inside. - note that this is not the final "inside" or "outside" block, - we need clockwise / counterclockwise to determine that. -} turnBlocks :: Dir -> Dir -> CoordP -> (Blk, Blk) turnBlocks t0 t1 (CoordP (r, c)) = case (t0, t1) of @@ -241,43 +284,79 @@ turnBlocks t0 t1 (CoordP (r, c)) = case (t0, t1) of where blk a b = Blk (CoordP (a, b)) -edgePredicates :: [CoordP] -> (CoordP -> CoordP -> Bool, CoordP -> Bool) -edgePredicates (cs :: [CoordP]) = (isEdgeOnEdge, isCoordOnEdge) +{- + Takes constructed path (list of points), + and builds several predicates regarding the path: + + - `isEdgeOnPath u v` assumes that `u` and `v` are either + vertically or horizontally nearby to each other + (i.e. they share either `r` or `c` value), + and tests whether it is completely covered by the path. + + - `isCoordOnPath u` tests whether a point is covered by a path. + + Recognizing that what we want to do with constructed paths are mostly + testing whether something is covered by it, + we can instead make those predicates and pass them around instead of passing around the path. + + One benefit we get is that we can make some optimizations to the implementation + and its detail remain contained inside this function. + (In this case we can speed things up by breaking the path into + horizontal and vertical segments and index them by their shared dimensions) + + -} +loopPathPredicates :: [CoordP] -> (CoordP -> CoordP -> Bool, CoordP -> Bool) +loopPathPredicates cs = (isEdgeOnPath, isCoordOnPath) where (vs, hs) = mconcat do e@(MinMax (CoordP (r0, c0), CoordP (r1, c1))) <- zipWith (curry minMaxFromPair) cs (tail cs) if | r0 == r1 -> pure (mempty, DL.singleton (r0, DL.singleton (c0, c1))) | c0 == c1 -> pure (DL.singleton (c0, DL.singleton (r0, r1)), mempty) - | otherwise -> error $ "invalid edge: " <> show e - -- separate vertical and horizontal edges - vSegs = M.map DL.toList $ M.fromListWith (<>) $ DL.toList vs - hSegs = M.map DL.toList $ M.fromListWith (<>) $ DL.toList hs + | otherwise -> error $ "invalid segment: " <> show e + -- separate vertical and horizontal segments of the path + vSegs = IM.map DL.toList $ IM.fromListWith (<>) $ DL.toList vs + hSegs = IM.map DL.toList $ IM.fromListWith (<>) $ DL.toList hs + + lookupAux segs i f = any f $ fromMaybe [] (segs IM.!? i) - isEdgeOnEdge (CoordP (r0, c0)) (CoordP (r1, c1)) + isEdgeOnPath (CoordP (r0, c0)) (CoordP (r1, c1)) | r0 == r1 = - let segs = fromMaybe [] $ hSegs M.!? r0 - in any (\(l, r) -> inRange (l, r) c0 && inRange (l, r) c1) segs + lookupAux hSegs r0 (\rng -> inRange rng c0 && inRange rng c1) | c0 == c1 = - let segs = fromMaybe [] $ vSegs M.!? c0 - in any (\(l, r) -> inRange (l, r) r0 && inRange (l, r) r1) segs + lookupAux vSegs c0 (\rng -> inRange rng r0 && inRange rng r1) | otherwise = False - isCoordOnEdge (CoordP (r0, c0)) = - ( let segs = fromMaybe [] $ hSegs M.!? r0 - in any (\(l, r) -> inRange (l, r) c0) segs - ) - || ( let segs = fromMaybe [] $ vSegs M.!? c0 - in any (\(l, r) -> inRange (l, r) r0) segs - ) + isCoordOnPath (CoordP (r0, c0)) = + lookupAux hSegs r0 (\rng -> inRange rng c0) + || lookupAux hSegs c0 (\rng -> inRange rng r0) + +{- + Tests whether moving a block in certain direction will hit the loop path. + + Current block and points of its 4 corners: + + U + (r,c) --------- (r,c+1) + | | + L | this block | R + | | + (r+1,c)-------- (r+1,c+1) + D -blkMoveTest :: (CoordP -> CoordP -> Bool) -> Blk -> Dir -> Bool -blkMoveTest isEdgeOnEdge (Blk (CoordP (r, c))) = \case - U -> isEdgeOnEdge (CoordP (r, c)) (CoordP (r, c + 1)) - D -> isEdgeOnEdge (CoordP (r + 1, c)) (CoordP (r + 1, c + 1)) - L -> isEdgeOnEdge (CoordP (r, c)) (CoordP (r + 1, c)) - R -> isEdgeOnEdge (CoordP (r, c + 1)) (CoordP (r + 1, c + 1)) + In other words, here we test if the edge corresponding + to the direction lies directly on the path. + Returns True if moving in that direction will hit the loop path. + -} +blkMoveHit :: (CoordP -> CoordP -> Bool) -> Blk -> Dir -> Bool +blkMoveHit isEdgeOnPath (Blk cur@(CoordP (r, c))) = \case + U -> isEdgeOnPath cur (CoordP (r, c + 1)) + D -> isEdgeOnPath (CoordP (r + 1, c)) (CoordP (r + 1, c + 1)) + L -> isEdgeOnPath cur (CoordP (r + 1, c)) + R -> isEdgeOnPath (CoordP (r, c + 1)) (CoordP (r + 1, c + 1)) + +{- Pretty much standard BFS-based floodfill -} floodfill :: (Blk -> Dir -> Bool) -> S.Set Blk -> Seq.Seq Blk -> S.Set Blk floodfill moveTest = fix \go discovered -> \case Seq.Empty -> discovered @@ -289,8 +368,70 @@ floodfill moveTest = fix \go discovered -> \case pure next in go (foldr S.insert discovered nexts) (q1 <> Seq.fromList nexts) -solve :: [Instr] -> IO Int -solve instrs = do +{- + A helper for collecting everything relevant to area counting from a block. + + Return value is by design an instance of Monoid. + -} +blkExplode :: (CoordP -> Pt) -> Blk -> (Sum Int, DL.DList (Coord, Coord), DL.DList Coord) +blkExplode cToP (Blk coord@(CoordP (r, c))) = + ( -- area, excluding edges + Sum area + , {- + edges, edges are normalized: forall (u, v), u <= v. + -} + DL.fromList edges + , -- four corners + DL.fromList [(r0, c0), (r0, c1), (r1, c0), (r1, c1)] + ) + where + P (V2 r0 c0) = cToP coord + P (V2 r1 c1) = cToP (CoordP (r + 1, c + 1)) + area = (r1 - r0 - 1) * (c1 - c0 - 1) + edges = + [ -- U side + ((r0, c0 + 1), (r0, c1 - 1)) + , -- D side + ((r1, c0 + 1), (r1, c1 - 1)) + , -- L side + ((r0 + 1, c0), (r1 - 1, c0)) + , -- R side + ((r0 + 1, c1), (r1 - 1, c1)) + ] + +-- a pretty-printer for visualization. +ppr :: [CoordP] -> (CoordP -> CoordP -> Bool) -> (CoordP -> Bool) -> S.Set Blk -> IO () +ppr turnCoordPs isEdgeOnPath isCoordOnPath insides = do + let + tffff = True : repeat False + Just (MinMax2D ((rMin, rMax), (cMin, cMax))) = + foldMap + ((Just . minMax2D) . (\(CoordP c) -> c)) + turnCoordPs + + forM_ (zip [rMin .. rMax] tffff) \(r, firstRow) -> do + unless firstRow do + -- print out a row describing connection between `r-1` and `r`, stuff like |x|x|x| + let + render c firstCol = + if firstCol + then [vCh] + else [if S.member (Blk (CoordP (r - 1, c - 1))) insides then 'i' else ' ', vCh] + where + vCh = if blkMoveHit isEdgeOnPath (Blk (CoordP (r - 1, c))) L then '|' else ' ' + putStrLn $ concat $ zipWith render [cMin .. cMax] tffff + + -- prints current row, like `o-o-o-o` stuff + let + render c firstCol = if firstCol then [vCh] else [conn, vCh] + where + coord = CoordP (r, c) + vCh = if isCoordOnPath coord then 'o' else ' ' + conn = if blkMoveHit isEdgeOnPath (Blk (CoordP (r, c - 1))) U then '-' else ' ' + putStrLn $ concat $ zipWith render [cMin .. cMax] tffff + +solve :: Bool -> [Instr] -> IO Int +solve prettyPrint instrs = do {- Construct the path following instructions, validate various assumptions we've made. @@ -298,83 +439,56 @@ solve instrs = do (clockwise, turnPoints) <- case constructPath instrs of Left err -> error $ "failed while validating the path:" <> err Right v -> pure v - let (pToC, cToP) = coordPack turnPoints - turnCoordPs = fmap pToC turnPoints - (isEdgeOnEdge, isCoordOnEdge) = edgePredicates turnCoordPs - initInsides :: [Blk] - initInsides = - fmap - ( \(t0, c, t1) -> - let (bx, by) = turnBlocks t0 t1 c - in if clockwise - then (if t1 == turnRight t0 then bx else by) - else (if t1 == turnLeft t0 then bx else by) - ) - $ zip3 dirs (tail turnCoordPs) (tail $ cycle dirs) - where - dirs = fmap fst instrs - finInsides = floodfill (blkMoveTest isEdgeOnEdge) (S.fromList initInsides) (Seq.fromList initInsides) - blkExplode :: Blk -> (Sum Int, DL.DList (Coord, Coord), DL.DList Coord) - blkExplode (Blk coord@(CoordP (r, c))) = (Sum area, edges, DL.fromList [(r0, c0), (r0, c1), (r1, c0), (r1, c1)]) - where - P (V2 r0 c0) = cToP coord - P (V2 r1 c1) = cToP (CoordP (r + 1, c + 1)) - area = (r1 - r0 - 1) * (c1 - c0 - 1) - edges = - DL.fromList - [ -- U - ((r0, c0 + 1), (r0, c1 - 1)) - , -- D - ((r1, c0 + 1), (r1, c1 - 1)) - , -- L - ((r0 + 1, c0), (r1 - 1, c0)) - , -- R - ((r0 + 1, c1), (r1 - 1, c1)) - ] - let (Sum p1, p2, p3) = foldMap blkExplode (S.toList finInsides) - eArea = sum $ fmap f $ S.toList $ S.fromList $ DL.toList p2 + {- + Build scaled-down bijection, pre-process path predicates, and floodfill. + -} + let + (pToC, cToP) = coordPack turnPoints + turnCoordPs = fmap pToC turnPoints + (isEdgeOnPath, isCoordOnPath) = loopPathPredicates turnCoordPs + initInsides :: [Blk] + initInsides = + zipWith3 + ( \t0 c t1 -> + let (bx, by) = turnBlocks t0 t1 c + in if clockwise + then (if t1 == turnRight t0 then bx else by) + else (if t1 == turnLeft t0 then bx else by) + ) + dirs + (tail turnCoordPs) + (tail $ cycle dirs) + where + dirs = fmap fst instrs + insides = + floodfill + (blkMoveHit isEdgeOnPath) + (S.fromList initInsides) + (Seq.fromList initInsides) + + {- + We don't have to mathematically determine which edge / vertex + are overcounted putting them together - just put them in Set and + let it de-dup for us. + + It's probably less efficient but easier to read. + -} + let (Sum p1, p2, p3) = foldMap (blkExplode cToP) insides + eArea = sum $ fmap f $ nubOrd $ DL.toList p2 where f ((r0, c0), (r1, c1)) | r0 == r1 = c1 - c0 + 1 | c0 == c1 = r1 - r0 + 1 | otherwise = unreachable - - let Just (MinMax2D ((rMin, rMax), (cMin, cMax))) = - foldMap - ((Just . minMax2D) . (\(CoordP c) -> c)) - ( S.toList $ - S.fromList (fmap pToC turnPoints) - ) - prettyPrint = False when prettyPrint do - forM_ (zip [rMin .. rMax] (True : repeat False)) \(r, firstRow) -> do - unless firstRow do - -- print out a row describing connection between `r-1` and `r`, stuff like |x|x|x| - let ln1 = concat $ zipWith render [cMin .. cMax] (True : repeat False) - where - render c firstCol = - if firstCol - then [vCh] - else [if S.member (Blk (CoordP (r - 1, c - 1))) finInsides then 'i' else ' ', vCh] - where - vCh = if blkMoveTest isEdgeOnEdge (Blk (CoordP (r - 1, c))) L then '|' else ' ' - putStrLn ln1 - - -- o-o-o-o stuff - let ln2 = concat $ zipWith render [cMin .. cMax] (True : repeat False) - where - render c firstCol = if firstCol then [vCh] else [conn, vCh] - where - coord = CoordP (r, c) - vCh = if isCoordOnEdge coord then 'o' else ' ' - conn = if blkMoveTest isEdgeOnEdge (Blk (CoordP (r, c - 1))) U then '-' else ' ' - putStrLn ln2 - + ppr turnCoordPs isEdgeOnPath isCoordOnPath insides pure (p1 + eArea + S.size (S.fromList $ DL.toList p3)) instance Solution Day18 where - solutionRun _ SolutionContext {getInputS, answerShow} = do + solutionRun _ SolutionContext {getInputS, answerShow, terminal} = do instrs <- fmap (consumeOrDie planLineP) . lines <$> getInputS - let (plan1, plan2) = unzip $ (fmap . second) getInstr2 instrs - solve plan1 >>= answerShow - solve plan2 >>= answerShow + let + (plan1, plan2) = unzip $ (fmap . second) getInstr2 instrs + prettyPrint = isJust terminal + solve prettyPrint plan1 >>= answerShow + solve prettyPrint plan2 >>= answerShow