From 2ae5c6ac4018d9df4222fb9b98247c855a7d5195 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Thu, 12 Dec 2024 15:10:48 +0000 Subject: [PATCH] Done day 12, twice --- advent12/Main.hs | 152 +++++++++++++++++++++++++++++++ advent12/MainOriginal.hs | 189 +++++++++++++++++++++++++++++++++++++++ adventofcode24.cabal | 17 +++- 3 files changed, 355 insertions(+), 3 deletions(-) create mode 100644 advent12/Main.hs create mode 100644 advent12/MainOriginal.hs diff --git a/advent12/Main.hs b/advent12/Main.hs new file mode 100644 index 0000000..242ca9b --- /dev/null +++ b/advent12/Main.hs @@ -0,0 +1,152 @@ +-- Writeup at https://work.njae.me.uk/2024/12/12/advent-of-code-2024-day-12/ + +import AoC +import Linear +-- import qualified Data.Set as S +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import Data.List (foldl') + +type Position = V2 Int -- r, c +-- type Bounds = (Position, Position) +data Plot = Plot { pos :: Position, plant :: Char, fenceLength :: Int } + deriving (Show, Eq, Ord) + +type Region = [Plot] + +data Facing = T | R | B | L deriving (Show, Eq, Ord) +data SideFragment = SideFragment Position Facing + deriving (Show, Eq, Ord) +type Side = [SideFragment] + +data UFElement a = UFElement a Int -- the rank + deriving (Show, Eq, Ord) + +type UFind a = M.Map a (UFElement a) + +class Ord a => Joinable a where + ufStart :: [a] -> UFind a + ufStart xs = M.fromList [(x, UFElement x 0) | x <- xs] + + exemplar :: UFind a -> a -> a + exemplar uf x + | x == parent = x + | otherwise = exemplar uf parent + where UFElement parent _ = uf ! x + + join :: UFind a -> a -> a -> UFind a + join uf x y + | x' == y' = uf + | rankX < rankY = M.insert x' (UFElement y' rankX) uf + | rankX > rankY = M.insert y' (UFElement x' rankY) uf + | otherwise = M.insert y' (UFElement x' (rankX + 1)) uf + where x' = exemplar uf x + y' = exemplar uf y + UFElement _ rankX = uf ! x' + UFElement _ rankY = uf ! y' + + merge :: UFind a -> UFind a + merge uf = foldl' mergeItem uf $ M.keys uf + + mergeItem :: UFind a -> a -> UFind a + mergeItem uf x = foldl' (\u y -> join u x y) uf nbrs + where nbrs = filter (meets x) $ M.keys uf + + exemplars :: UFind a -> [a] + exemplars uf = filter (\x -> x == exemplar uf x) $ M.keys uf + + distinctSets :: UFind a -> [[a]] + distinctSets uf = fmap go es + where es = exemplars uf + go e = filter (\x -> exemplar uf x == e) $ M.keys uf + + meets :: a -> a -> Bool + +instance Joinable Plot where + meets plot1 plot2 = plot1.pos `elem` neighbours plot2.pos && plot1.plant == plot2.plant + +instance Joinable SideFragment where + meets (SideFragment p1 T) (SideFragment p2 T) = p1 `elem` neighboursH p2 + meets (SideFragment p1 B) (SideFragment p2 B) = p1 `elem` neighboursH p2 + meets (SideFragment p1 L) (SideFragment p2 L) = p1 `elem` neighboursV p2 + meets (SideFragment p1 R) (SideFragment p2 R) = p1 `elem` neighboursV p2 + meets _ _ = False + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- readFile dataFileName + let field = mkField text + -- print field + let fenceField = fmap (findFenceLength field) field + let regionsU = findRegions fenceField + -- print $ regionsU + -- print $ exemplars regionsU + -- let regions = distinctSets regionsU + -- print regions + -- print $ fmap fenceCost regions + print $ part1 regionsU + -- print $ fmap sideFragments regions + -- let allSides = fmap sidesOfRegion regions + -- print allSides + -- print $ fmap (fmap S.size) allSides + -- print $ fmap bulkFenceCost regions + print $ part2 regionsU + +part1, part2 :: UFind Plot -> Int +part1 regions = sum $ fmap fenceCost $ distinctSets regions + + +-- part2 :: UFind Plot -> Int +part2 regionsU = sum $ zipWith bulkFenceCost regions regionSideCounts + where regions = distinctSets regionsU + regionSides = fmap sideFragments regions + findSides r = exemplars $ merge $ ufStart r + regionSideCounts = fmap (length . findSides) regionSides + +perimeter :: Region -> Int +perimeter region = sum $ fmap fenceLength region + +fenceCost :: Region -> Int +fenceCost region = (perimeter region) * (length region) + +bulkFenceCost :: Region -> Int -> Int +bulkFenceCost region nSides = (length region) * nSides + + +findRegions :: Region -> UFind Plot +findRegions field = merge $ ufStart field + +sideFragments :: Region -> Side +sideFragments region = concatMap (plotSides region) region + +plotSides :: Region -> Plot -> Side +plotSides region plot = + [ SideFragment plot.pos f + | f <- [T, R, B, L] + , (sideP f) `notElem` regionPoss + ] + where sideP T = plot.pos + V2 (-1) 0 + sideP R = plot.pos + V2 0 1 + sideP B = plot.pos + V2 1 0 + sideP L = plot.pos + V2 0 (-1) + regionPoss = fmap pos region + +findFenceLength :: Region -> Plot -> Plot +findFenceLength region plot = plot { fenceLength = 4 - (length nbrs) } + where nbrs = filter (meets plot) region + +neighbours, neighboursH, neighboursV :: Position -> [Position] +neighboursH (V2 r c) = [V2 r (c-1), V2 r (c+1)] +neighboursV (V2 r c) = [V2 (r-1) c, V2 (r+1) c] +neighbours here = neighboursH here ++ neighboursV here + +mkField :: String -> Region +mkField text = plots + where rows = lines text + rMax = length rows - 1 + cMax = (length $ head rows) - 1 + plots = [ Plot { plant = rows !! r !! c, pos = V2 r c, fenceLength = 4 } + | r <- [0..rMax], c <- [0..cMax] + ] + diff --git a/advent12/MainOriginal.hs b/advent12/MainOriginal.hs new file mode 100644 index 0000000..f14ba1e --- /dev/null +++ b/advent12/MainOriginal.hs @@ -0,0 +1,189 @@ +-- Writeup at https://work.njae.me.uk/2024/12/12/advent-of-code-2024-day-12/ + +import AoC +import Linear +import qualified Data.Set as S +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) + +type Position = V2 Int -- r, c +-- type Bounds = (Position, Position) +data Plot = Plot { pos :: Position, plant :: Char, fenceLength :: Int } + deriving (Show, Eq, Ord) + +type Region = S.Set Plot + +data Facing = T | R | B | L deriving (Show, Eq, Ord) +data SideFragment = SideFragment Position Facing + deriving (Show, Eq, Ord) +type Side = S.Set SideFragment + +data UFElement a = UFElemeent a Int -- the rank + deriving (Show, Eq, Ord) + +type UFind a = M.Map a (UFElement a) + +class Joinable a where + exemplar :: UFind a -> a -> a + join :: UFind a -> a -> a -> UFind a + meets :: a -> a -> Bool + +instance Joinable Plot where + meets plot1 plot2 = plot1.pos `elem` neighbours plot2.pos && plot1.plant == plot2.plant + +instance Joinable SideFragment where + meets (SideFragment p1 T) (SideFragment p2 T) = p1 `elem` neighboursH p2 + meets (SideFragment p1 B) (SideFragment p2 B) = p1 `elem` neighboursH p2 + meets (SideFragment p1 L) (SideFragment p2 L) = p1 `elem` neighboursV p2 + meets (SideFragment p1 R) (SideFragment p2 R) = p1 `elem` neighboursV p2 + meets _ _ = False + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- readFile dataFileName + let field = mkField text + -- print field + let fenceField = S.map (findFenceLength field) field + let regions = findRegions fenceField [] + -- print $ regions + -- print $ fmap fenceCost regions + print $ part1 regions + -- print $ fmap sideFragments regions + -- let allSides = fmap sidesOfRegion regions + -- print allSides + -- print $ fmap (fmap S.size) allSides + -- print $ fmap bulkFenceCost regions + print $ part2 regions + + +part1, part2 :: [Region] -> Int +part1 regions = sum $ fmap fenceCost regions +part2 regions = sum $ fmap bulkFenceCost regions + +-- find the regions + +findRegions :: Region -> [Region] -> [Region] +findRegions unaccounted regions + | S.null unaccounted = regions + | otherwise = findRegions unaccounted'' (region:regions) + where + (s, unaccounted') = S.deleteFindMin unaccounted + seed = S.singleton s + (region, unaccounted'') = growRegion seed unaccounted' + +growRegion :: Region -> Region -> (Region, Region) +growRegion region unaccounted + | S.null unaccounted = (region, unaccounted) + | S.null newPlots = (region, unaccounted) + | otherwise = growRegion region' unaccounted' + where + -- possibleNeighbours = S.filter (meetsAny region) unaccounted + possibleNeighbours = unaccounted `adjoins` region + thisPlant = plant $ S.findMin region + newPlots = S.filter ((== thisPlant) . plant) possibleNeighbours + region' = S.union region newPlots + unaccounted' = unaccounted `S.difference` newPlots + +-- handle fences + +findFenceLength :: Region -> Plot -> Plot +findFenceLength region plot = plot { fenceLength = 4 - (S.size sameNbrs) } + where nbrs = S.filter (meets plot) region + sameNbrs = S.filter ((== plant plot) . plant) nbrs + +perimeter :: Region -> Int +perimeter region = sum $ fmap fenceLength $ S.toList region + +fenceCost :: Region -> Int +fenceCost region = (perimeter region) * (S.size region) + +bulkFenceCost :: Region -> Int +bulkFenceCost region = (length $ sidesOfRegion region) * (S.size region) + +-- deal with sides + +sideFragments :: Region -> Side +sideFragments region = S.fromList $ concatMap (plotSides region) plots + where plots = S.toList region + +plotSides :: Region -> Plot -> [SideFragment] +plotSides region plot = + [ SideFragment plot.pos f + | f <- [T, R, B, L] + , S.notMember (sideP f) regionPoss + ] + where sideP T = plot.pos + V2 (-1) 0 + sideP R = plot.pos + V2 0 1 + sideP B = plot.pos + V2 1 0 + sideP L = plot.pos + V2 0 (-1) + regionPoss = S.map pos region + +sidesOfRegion :: Region -> [Side] +sidesOfRegion region = findSides (sideFragments region) [] + +findSides :: Side -> [Side] -> [Side] +findSides unaccounted sides + | S.null unaccounted = sides + | otherwise = findSides unaccounted'' (side:sides) + where + (s, unaccounted') = S.deleteFindMin unaccounted + seed = S.singleton s + (side, unaccounted'') = growSide seed unaccounted' + +growSide :: Side -> Side -> (Side, Side) +growSide side unaccounted + | S.null unaccounted = (side, unaccounted) + | S.null neighbours = (side, unaccounted) + | otherwise = growSide side' unaccounted' + where + -- possibleNeighbours = S.filter (meetsAny region) unaccounted + neighbours = unaccounted `adjoinsS` side + side' = S.union side neighbours + unaccounted' = unaccounted `S.difference` neighbours + +sideExtension :: SideFragment -> [SideFragment] +sideExtension (SideFragment here T) = [SideFragment there T | there <- neighboursH here] +sideExtension (SideFragment here B) = [SideFragment there B | there <- neighboursH here] +sideExtension (SideFragment here L) = [SideFragment there L | there <- neighboursV here] +sideExtension (SideFragment here R) = [SideFragment there R | there <- neighboursV here] + +-- handle sides touching sides + +-- all the plots in region1 that are adjacent to any plot in region2 +adjoinsS :: Side -> Side -> Side +adjoinsS side1 side2 = S.filter (meetsAnyS side2) side1 + +meetsAnyS :: Side -> SideFragment -> Bool +meetsAnyS side frag = not $ S.null $ S.filter (meetsS frag) side + +meetsS :: SideFragment -> SideFragment -> Bool +meetsS side1 side2 = side1 `elem` sideExtension side2 + +-- handle plots touching regions + +-- all the plots in region1 that are adjacent to any plot in region2 +adjoins :: Region -> Region -> Region +adjoins region1 region2 = S.filter (meetsAny region2) region1 + +meetsAny :: Region -> Plot -> Bool +meetsAny region plot = not $ S.null $ S.filter (meets plot) region + +meets :: Plot -> Plot -> Bool +meets plot1 plot2 = plot1.pos `elem` neighbours plot2.pos + +neighbours, neighboursH, neighboursV :: Position -> [Position] +neighboursH (V2 r c) = [V2 r (c-1), V2 r (c+1)] +neighboursV (V2 r c) = [V2 (r-1) c, V2 (r+1) c] +neighbours here = neighboursH here ++ neighboursV here + + +mkField :: String -> Region +mkField text = S.fromList plots + where rows = lines text + rMax = length rows - 1 + cMax = (length $ head rows) - 1 + plots = [ Plot { plant = rows !! r !! c, pos = V2 r c, fenceLength = 4 } + | r <- [0..rMax], c <- [0..cMax] + ] + diff --git a/adventofcode24.cabal b/adventofcode24.cabal index 2f3eb9c..022e79b 100644 --- a/adventofcode24.cabal +++ b/adventofcode24.cabal @@ -47,7 +47,7 @@ common build-directives hs-source-dirs: ., app, src -- other-modules: AoC ghc-options: -O2 - -Wall + -- -Wall -threaded -rtsopts "-with-rtsopts=-N" @@ -125,11 +125,22 @@ executable advent09 build-depends: containers executable advent10 - import: common-extensions, build-directives + import: warnings, common-extensions, build-directives, common-modules main-is: advent10/Main.hs build-depends: linear, array, mtl executable advent11 - import: common-extensions, build-directives + import: warnings, common-extensions, build-directives, common-modules main-is: advent11/Main.hs build-depends: attoparsec, text, multiset + +executable advent12 + import: warnings, common-extensions, build-directives, common-modules + main-is: advent12/Main.hs + build-depends: linear, containers + +executable advent12orig + import: warnings, common-extensions, build-directives, common-modules + main-is: advent12/MainOriginal.hs + build-depends: linear, containers + \ No newline at end of file -- 2.34.1