Skip to content

Commit

Permalink
d18 cleanup done.
Browse files Browse the repository at this point in the history 
happy with it now.
  • Loading branch information
@Javran
Javran committed Feb 12, 2024
1 parent df68ac8 commit c8e8b43
Showing 1 changed file with 215 additions and 101 deletions.
316 changes: 215 additions & 101 deletions src/Javran/AdventOfCode/Y2023/Day18.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -289,92 +368,127 @@ 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.
-}
(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

0 comments on commit c8e8b43

Please sign in to comment.