2 files changed, 182 insertions, 0 deletions
diff --git a/src/Xanthous/Generators/CaveAutomata.hs b/src/Xanthous/Generators/CaveAutomata.hs
new file mode 100644
index 000000000000..bf37cb3f08e7
--- /dev/null
+++ b/src/Xanthous/Generators/CaveAutomata.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Xanthous.Generators.CaveAutomata
+  ( Params(..)
+  , defaultParams
+  , parseParams
+  , generate
+  ) where
+
+import Xanthous.Prelude
+import Control.Monad.Random (RandomGen, runRandT)
+import Data.Array.ST
+import Data.Array.Unboxed
+import qualified Options.Applicative as Opt
+
+import Xanthous.Util (between)
+import Xanthous.Data (Dimensions, width, height)
+import Xanthous.Generators.Util
+
+data Params = Params
+  { _aliveStartChance :: Double
+  , _birthLimit :: Word
+  , _deathLimit :: Word
+  , _steps :: Word
+  }
+  deriving stock (Show, Eq, Generic)
+makeLenses ''Params
+
+defaultParams :: Params
+defaultParams = Params
+  { _aliveStartChance = 0.6
+  , _birthLimit = 3
+  , _deathLimit = 4
+  , _steps = 4
+  }
+
+parseParams :: Opt.Parser Params
+parseParams = Params
+  <$> Opt.option parseChance
+      ( Opt.long "alive-start-chance"
+      <> Opt.value (defaultParams ^. aliveStartChance)
+      <> Opt.showDefault
+      <> Opt.help ( "Chance for each cell to start alive at the beginning of "
+                 <> "the cellular automata"
+                 )
+      <> Opt.metavar "CHANCE"
+      )
+  <*> Opt.option parseNeighbors
+      ( Opt.long "birth-limit"
+      <> Opt.value (defaultParams ^. birthLimit)
+      <> Opt.showDefault
+      <> Opt.help "Minimum neighbor count required for birth of a cell"
+      <> Opt.metavar "NEIGHBORS"
+      )
+  <*> Opt.option parseNeighbors
+      ( Opt.long "death-limit"
+      <> Opt.value (defaultParams ^. deathLimit)
+      <> Opt.showDefault
+      <> Opt.help "Maximum neighbor count required for death of a cell"
+      <> Opt.metavar "NEIGHBORS"
+      )
+  <*> Opt.option Opt.auto
+      ( Opt.long "steps"
+      <> Opt.value (defaultParams ^. steps)
+      <> Opt.showDefault
+      <> Opt.help "Number of generations to run the automata for"
+      <> Opt.metavar "STEPS"
+      )
+  where
+    readWithGuard predicate errmsg = do
+      res <- Opt.auto
+      unless (predicate res)
+        $ Opt.readerError
+        $ errmsg res
+      pure res
+
+    parseChance = readWithGuard
+      (between 0 1)
+      $ \res -> "Chance must be in the range [0,1], got: " <> show res
+
+    parseNeighbors = readWithGuard
+      (between 0 8)
+      $ \res -> "Neighbors must be in the range [0,8], got: " <> show res
+
+generate :: RandomGen g => Params -> Dimensions -> g -> UArray (Word, Word) Bool
+generate params dims gen
+  = runSTUArray
+  $ fmap fst
+  $ flip runRandT gen
+  $ generate' params dims
+
+generate' :: RandomGen g => Params -> Dimensions -> CellM g s (Cells s)
+generate' params dims = do
+  cells <- randInitialize dims $ params ^. aliveStartChance
+  let steps' = params ^. steps
+  when (steps' > 0)
+   $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params
+  pure cells
+
+stepAutomata :: forall s g. Cells s -> Dimensions -> Params -> CellM g s ()
+stepAutomata cells dims params = do
+  origCells <- lift $ cloneMArray @_ @(STUArray s) cells
+  for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do
+    neighs <- lift $ numAliveNeighborsM origCells pos
+    origValue <- lift $ readArray origCells pos
+    lift . writeArray cells pos
+      $ if origValue
+        then neighs >= params ^. deathLimit
+        else neighs > params ^. birthLimit
diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs
new file mode 100644
index 000000000000..3f0d691b7fac
--- /dev/null
+++ b/src/Xanthous/Generators/Util.hs
@@ -0,0 +1,70 @@
+-- |
+
+module Xanthous.Generators.Util
+  ( Cells
+  , CellM
+  , randInitialize
+  , numAliveNeighborsM
+  , cloneMArray
+  ) where
+
+import Xanthous.Prelude
+import Data.Array.ST
+import Data.Array.Unboxed
+import Control.Monad.ST
+import Control.Monad.Random
+import Data.Monoid
+
+import Xanthous.Util (foldlMapM')
+import Xanthous.Data (Dimensions, width, height)
+
+type Cells s = STUArray s (Word, Word) Bool
+type CellM g s a = RandT g (ST s) a
+
+randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (Cells 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)]
+
+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