snix/src/Xanthous/Generators/Util.hs

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.Util
  ( MCells
  , Cells
  , CellM
  , randInitialize
  , numAliveNeighborsM
  , numAliveNeighbors
  , fillOuterEdgesM
  , cloneMArray
  , floodFill
  , regions
  , fillAll
  , fillAllM
  , fromPoints
  , fromPointsM
  ) where
--------------------------------------------------------------------------------
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, for_)
import qualified Data.Set as Set
import           Data.Semigroup.Foldable
--------------------------------------------------------------------------------
import           Xanthous.Util (foldlMapM', maximum1, minimum1)
import           Xanthous.Data (Dimensions, width, height)
--------------------------------------------------------------------------------

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 (MCells s)
randInitialize dims aliveChance = do
  res <- lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False
  for_ [0..dims ^. width] $ \i ->
    for_ [0..dims ^. height] $ \j -> do
      val <- (>= aliveChance) <$> getRandomR (0, 1)
      lift $ writeArray res (i, j) val
  pure res

numAliveNeighborsM
  :: forall a i j m
  . (MArray a Bool m, Ix (i, j), Integral i, Integral j)
  => a (i, j) Bool
  -> (i, j)
  -> m Word
numAliveNeighborsM cells (x, y) = do
  cellBounds <- getBounds cells
  getSum <$> foldlMapM'
    (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds)
    neighborPositions

  where
    boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> m Bool
    boundedGet ((minX, minY), (maxX, maxY)) (i, j)
      | x <= minX
        || y <= minY
        || x >= maxX
        || y >= maxY
      = pure True
      | otherwise =
        let nx = fromIntegral $ fromIntegral x + i
            ny = fromIntegral $ fromIntegral y + j
        in readArray cells (nx, ny)

    neighborPositions :: [(Int, Int)]
    neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]

numAliveNeighbors
  :: forall a i j
  . (IArray a Bool, Ix (i, j), Integral i, Integral j)
  => a (i, j) Bool
  -> (i, j)
  -> Word
numAliveNeighbors cells (x, y) =
  let cellBounds = bounds cells
  in getSum $ foldMap
      (Sum . fromIntegral . fromEnum . boundedGet cellBounds)
      neighborPositions

  where
    boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> Bool
    boundedGet ((minX, minY), (maxX, maxY)) (i, j)
      | x <= minX
        || y <= minY
        || x >= maxX
        || y >= maxY
      = True
      | otherwise =
        let nx = fromIntegral $ fromIntegral x + i
            ny = fromIntegral $ fromIntegral y + j
        in cells ! (nx, ny)

    neighborPositions :: [(Int, Int)]
    neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]

fillOuterEdgesM :: (MArray a Bool m, Ix i, Ix j) => a (i, j) Bool -> m ()
fillOuterEdgesM arr = do
  ((minX, minY), (maxX, maxY)) <- getBounds arr
  for_ (range (minX, maxX)) $ \x -> do
    writeArray arr (x, minY) True
    writeArray arr (x, maxY) True
  for_ (range (minY, maxY)) $ \y -> do
    writeArray arr (minX, y) True
    writeArray arr (maxX, y) True

cloneMArray
  :: forall a a' i e m.
  ( Ix i
  , MArray a e m
  , MArray a' e m
  , IArray UArray e
  )
  => 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 :: (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

fromPoints
  :: forall a f i.
    ( IArray a Bool
    , Ix i
    , Functor f
    , Foldable1 f
    )
  => f (i, i)
  -> a (i, i) Bool
fromPoints points =
  let pts = Set.fromList $ toList points
      dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points)
             , (maximum1 $ fst <$> points, maximum1 $ snd <$> points)
             )
  in array dims $ range dims <&> \i -> (i, i `member` pts)

fromPointsM
  :: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f)
  => NonNull f
  -> m (a i Bool)
fromPointsM points = do
  arr <- newArray (minimum points, maximum points) False
  fillAllM (otoList points) arr
  pure arr