5 files changed, 290 insertions, 1 deletions
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index e891a8e9e0d6..6e779a450525 100644
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@@ -17,6 +17,12 @@ module Xanthous.Data
   , loc
 
     -- *
+  , Dimensions'(..)
+  , Dimensions
+  , HasWidth(..)
+  , HasHeight(..)
+
+    -- *
   , Direction(..)
   , opposite
   , move
@@ -88,6 +94,21 @@ loc = iso hither yon
 
 --------------------------------------------------------------------------------
 
+data Dimensions' a = Dimensions
+  { _width :: a
+  , _height :: a
+  }
+  deriving stock (Show, Eq, Functor, Generic)
+  deriving anyclass (CoArbitrary, Function)
+makeFieldsNoPrefix ''Dimensions'
+
+instance Arbitrary a => Arbitrary (Dimensions' a) where
+  arbitrary = Dimensions <$> arbitrary <*> arbitrary
+
+type Dimensions = Dimensions' Word
+
+--------------------------------------------------------------------------------
+
 data Direction where
   Up        :: Direction
   Down      :: Direction
diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs
new file mode 100644
index 000000000000..c266742b0590
--- /dev/null
+++ b/src/Xanthous/Generators.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE GADTs #-}
+
+module Xanthous.Generators where
+
+import Xanthous.Prelude
+import Data.Array.Unboxed
+import System.Random (RandomGen)
+import qualified Options.Applicative as Opt
+
+import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
+import Xanthous.Data (Dimensions)
+
+data Generator = CaveAutomata
+  deriving stock (Show, Eq)
+
+data SGenerator (gen :: Generator) where
+  SCaveAutomata :: SGenerator 'CaveAutomata
+
+data AGenerator where
+  AGenerator :: forall gen. SGenerator gen -> AGenerator
+
+type family Params (gen :: Generator) :: Type where
+  Params 'CaveAutomata = CaveAutomata.Params
+
+generate
+  :: RandomGen g
+  => SGenerator gen
+  -> Params gen
+  -> Dimensions
+  -> g
+  -> UArray (Word, Word) Bool
+generate SCaveAutomata = CaveAutomata.generate
+
+data GeneratorInput where
+  GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput
+
+generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> UArray (Word, Word) Bool
+generateFromInput (GeneratorInput sg ps) = generate sg ps
+
+parseGeneratorInput :: Opt.Parser GeneratorInput
+parseGeneratorInput = Opt.subparser $
+  Opt.command "cave" (Opt.info
+                      (GeneratorInput <$> pure SCaveAutomata <*> CaveAutomata.parseParams)
+                      (Opt.progDesc "cellular-automata based cave generator"))
+
+showCells :: UArray (Word, Word) Bool -> Text
+showCells arr =
+  let ((minX, minY), (maxX, maxY)) = bounds arr
+      showCellVal True = "x"
+      showCellVal False = " "
+      showCell = showCellVal . (arr !)
+      row r = foldMap (showCell . (, r)) [minX..maxX]
+      rows = row <$> [minY..maxY]
+  in intercalate "\n" rows
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
diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs
index 377b66cf15cf..cf1f80b82e39 100644
--- a/src/Xanthous/Util.hs
+++ b/src/Xanthous/Util.hs
@@ -1,14 +1,46 @@
+{-# LANGUAGE BangPatterns #-}
+
 module Xanthous.Util
   ( EqEqProp(..)
   , EqProp(..)
+  , foldlMapM
+  , foldlMapM'
+  , between
   ) where
 
-import Xanthous.Prelude
+import Xanthous.Prelude hiding (foldr)
 
 import Test.QuickCheck.Checkers
+import Data.Foldable (foldr)
 
 newtype EqEqProp a = EqEqProp a
   deriving newtype Eq
 
 instance Eq a => EqProp (EqEqProp a) where
   (=-=) = eq
+
+foldlMapM :: forall g b a m. (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b
+foldlMapM f = foldr f' (pure mempty)
+  where
+    f' :: a -> m b -> m b
+    f' x = liftA2 mappend (f x)
+
+-- Strict in the monoidal accumulator. For monads strict
+-- in the left argument of bind, this will run in constant
+-- space.
+foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
+foldlMapM' f xs = foldr f' pure xs mempty
+  where
+  f' :: a -> (b -> m b) -> b -> m b
+  f' x k bl = do
+    br <- f x
+    let !b = mappend bl br
+    k b
+
+between
+  :: Ord a
+  => a -- ^ lower bound
+  -> a -- ^ upper bound
+  -> a -- ^ scrutinee
+  -> Bool
+between lower upper x = x >= lower && x <= upper