Place the chacracter in the level at startup time

Randomly select a position in the largest contiguous region of the
generated level in which to place the character at startup time.

1 files changed, 88 insertions, 9 deletions

diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs
index 260c41ac6002..47ee81b2931e 100644
--- a/src/Xanthous/Generators/Util.hs
+++ b/src/Xanthous/Generators/Util.hs
@@ -1,28 +1,34 @@
--- |
-
+{-# LANGUAGE ViewPatterns #-}
+--------------------------------------------------------------------------------
 module Xanthous.Generators.Util
-  ( Cells
+  ( MCells
+  , Cells
   , CellM
   , randInitialize
   , numAliveNeighborsM
   , numAliveNeighbors
   , cloneMArray
+  , floodFill
+  , regions
   ) where
-
-import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (Foldable, toList)
 import Data.Array.ST
 import Data.Array.Unboxed
 import Control.Monad.ST
 import Control.Monad.Random
 import Data.Monoid
-
-import Xanthous.Util (foldlMapM')
+import Data.Foldable (Foldable, toList)
+--------------------------------------------------------------------------------
+import Xanthous.Util (foldlMapM', between)
 import Xanthous.Data (Dimensions, width, height)
+--------------------------------------------------------------------------------
 
-type Cells s = STUArray s (Word, Word) Bool
+type MCells s = STUArray s (Word, Word) Bool
+type Cells = UArray (Word, Word) Bool
 type CellM g s a = RandT g (ST s) a
 
-randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (Cells s)
+randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s)
 randInitialize dims aliveChance = do
   res <- lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False
   for_ [0..dims ^. width] $ \i ->
@@ -87,6 +93,14 @@ numAliveNeighbors cells (x, y) =
     neighborPositions :: [(Int, Int)]
     neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
 
+safeGet :: (IArray a e, Ix i) => a i e -> i -> Maybe e
+safeGet arr idx =
+  let (minIdx, maxIdx) = bounds arr
+  in if idx < minIdx || idx > maxIdx
+     then Nothing
+     else Just $ arr ! idx
+
+
 cloneMArray
   :: forall a a' i e m.
   ( Ix i
@@ -97,3 +111,68 @@ cloneMArray
   => a i e
   -> m (a' i e)
 cloneMArray = thaw @_ @UArray <=< freeze
+
+--------------------------------------------------------------------------------
+
+-- | Flood fill a cell array starting at a point, returning a list of all the
+-- (true) cell locations reachable from that point
+floodFill :: forall a i j.
+            ( IArray a Bool
+            , Ix (i, j)
+            , Enum i , Enum j
+            , Bounded i , Bounded j
+            , Eq i , Eq j
+            , Show i, Show j
+            )
+          => a (i, j) Bool -- ^ array
+          -> (i, j)        -- ^ position
+          -> Set (i, j)
+floodFill = go mempty
+  where
+    go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j)
+    -- TODO pass result in rather than passing seen in, return result
+    go res arr@(bounds -> arrBounds) idx@(x, y)
+      | not (inRange arrBounds idx) =  res
+      | not (arr ! idx) =  res
+      | otherwise =
+        let neighbors
+              = filter (inRange arrBounds)
+              . filter (/= idx)
+              . filter (`notMember` res)
+              $ (,)
+              <$> [(if x == minBound then x else pred x)
+                   ..
+                   (if x == maxBound then x else succ x)]
+              <*> [(if y == minBound then y else pred y)
+                   ..
+                   (if y == maxBound then y else succ y)]
+        in foldl' (\r idx' ->
+                     if arr ! idx'
+                     then r <> go (r & contains idx' .~ True) arr idx'
+                     else r)
+           (res & contains idx .~ True) neighbors
+
+-- | Gives a list of all the disconnected regions in a cell array, represented
+-- each as lists of points
+regions :: forall a i j.
+          ( IArray a Bool
+          , Ix (i, j)
+          , Enum i , Enum j
+          , Bounded i , Bounded j
+          , Eq i , Eq j
+          , Show i, Show j
+          )
+        => a (i, j) Bool
+        -> [Set (i, j)]
+regions arr
+  | Just firstPoint <- findFirstPoint arr =
+      let region = floodFill arr firstPoint
+          arr' = fillAll region arr
+      in region : regions arr'
+  | otherwise = []
+  where
+    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