From 15895c69fe8f1415f45fe33f7b3d564f4239496e Mon Sep 17 00:00:00 2001
From: Griffin Smith <root@gws.fyi>
Date: Sun, 15 Sep 2019 17:00:27 -0400
Subject: Remove all but the largest region in caves

When generating cave levels, remove all but the largest contiguous
region from the resulting level.
---
 src/Xanthous/Generators/CaveAutomata.hs |  3 +++
 src/Xanthous/Generators/Util.hs         | 13 +++++++++----
 2 files changed, 12 insertions(+), 4 deletions(-)

(limited to 'src/Xanthous')

diff --git a/src/Xanthous/Generators/CaveAutomata.hs b/src/Xanthous/Generators/CaveAutomata.hs
index fd4c68ddbe90..f1123abbd8f4 100644
--- a/src/Xanthous/Generators/CaveAutomata.hs
+++ b/src/Xanthous/Generators/CaveAutomata.hs
@@ -99,6 +99,9 @@ generate' params dims = do
   when (steps' > 0)
    $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params
   lift $ fillOuterEdgesM cells
+  -- Remove all but the largest contiguous region of unfilled space
+  (_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells
+  lift $ fillAllM (fold smallerRegions) cells
   pure cells
 
 stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s ()
diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs
index e399ca5d4936..8fd04c0b9326 100644
--- a/src/Xanthous/Generators/Util.hs
+++ b/src/Xanthous/Generators/Util.hs
@@ -11,15 +11,17 @@ module Xanthous.Generators.Util
   , cloneMArray
   , floodFill
   , regions
+  , fillAll
+  , fillAllM
   ) where
 --------------------------------------------------------------------------------
-import Xanthous.Prelude hiding (Foldable, toList)
+import Xanthous.Prelude hiding (Foldable, toList, for_)
 import Data.Array.ST
 import Data.Array.Unboxed
 import Control.Monad.ST
 import Control.Monad.Random
 import Data.Monoid
-import Data.Foldable (Foldable, toList)
+import Data.Foldable (Foldable, toList, for_)
 --------------------------------------------------------------------------------
 import Xanthous.Util (foldlMapM')
 import Xanthous.Data (Dimensions, width, height)
@@ -177,5 +179,8 @@ regions arr
     findFirstPoint :: a (i, j) Bool -> Maybe (i, j)
     findFirstPoint = fmap fst . headMay . filter snd . assocs
 
-    fillAll :: Foldable f => f (i, j) -> a (i, j) Bool -> a (i, j) Bool
-    fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes
+fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool
+fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes
+
+fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m ()
+fillAllM ixes a = for_ ixes $ \i -> writeArray a i False
-- 
cgit 1.4.1