diff options
Diffstat (limited to 'src/Xanthous/Generators/Util.hs')
| -rw-r--r-- | src/Xanthous/Generators/Util.hs | 97 |
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 |