--- /dev/null
+-- 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]
+ ]
+
--- /dev/null
+-- 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]
+ ]
+
projects / advent-of-code-24.git / commitdiff