Add cellular-automata cave generator

Add a cellular-automata-based cave level generator, plus an
optparse-applicative-based CLI for invoking level generators in general.

package.yaml

@@ -18,6 +18,7 @@ dependencies:
 - base
 
 - aeson
+- array
 - QuickCheck
 - quickcheck-text
 - quickcheck-instances
@@ -37,6 +38,7 @@ dependencies:
 - megaparsec
 - MonadRandom
 - mtl
+- optparse-applicative
 - random
 - raw-strings-qq
 - reflection

src/Main.hs

@@ -2,16 +2,70 @@ module Main where
 
 import Xanthous.Prelude
 import Brick
+import qualified Options.Applicative as Opt
+import System.Random
 
 import Xanthous.Game (getInitialState)
 import Xanthous.App (makeApp)
+import Xanthous.Generators
+  ( GeneratorInput(..)
+  , parseGeneratorInput
+  , generateFromInput
+  , showCells
+  )
+import Xanthous.Data (Dimensions, Dimensions'(Dimensions))
 
-ui :: Widget ()
+data Command
-ui = str "Hello, world!"
+  = Run
+  | Generate GeneratorInput Dimensions
 
-main :: IO ()
+parseDimensions :: Opt.Parser Dimensions
-main = do
+parseDimensions = Dimensions
+  <$> Opt.option Opt.auto
+       ( Opt.short 'w'
+       <> Opt.long "width"
+       )
+  <*> Opt.option Opt.auto
+       ( Opt.short 'h'
+       <> Opt.long "height"
+       )
+
+parseCommand :: Opt.Parser Command
+parseCommand = Opt.subparser
+  $ Opt.command "run"
+      (Opt.info
+       (pure Run)
+       (Opt.progDesc "Run the game"))
+  <> Opt.command "generate"
+      (Opt.info
+       (Generate
+        <$> parseGeneratorInput
+        <*> parseDimensions
+        <**> Opt.helper
+       )
+       (Opt.progDesc "Generate a sample level"))
+
+optParser :: Opt.ParserInfo Command
+optParser = Opt.info
+  (parseCommand <**> Opt.helper)
+  (Opt.header "Xanthous: a WIP TUI RPG")
+
+runGame :: IO ()
+runGame =  do
   app <- makeApp
   initialState <- getInitialState
   _ <- defaultMain app initialState
   pure ()
+
+runGenerate :: GeneratorInput -> Dimensions -> IO ()
+runGenerate input dims = do
+  randGen <- getStdGen
+  let res = generateFromInput input dims randGen
+  putStrLn $ showCells res
+
+runCommand :: Command -> IO ()
+runCommand Run = runGame
+runCommand (Generate input dims) = runGenerate input dims
+
+main :: IO ()
+main = runCommand =<< Opt.execParser optParser

src/Xanthous/Data.hs

@@ -16,6 +16,12 @@ module Xanthous.Data
   , positioned
   , loc
 
+    -- *
+  , Dimensions'(..)
+  , Dimensions
+  , HasWidth(..)
+  , HasHeight(..)
+
     -- *
   , Direction(..)
   , opposite
@@ -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

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

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

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

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

test/Spec.hs

@@ -1,10 +1,11 @@
 import Test.Prelude
-import qualified Xanthous.DataSpec
 import qualified Xanthous.Data.EntityMapSpec
+import qualified Xanthous.DataSpec
+import qualified Xanthous.Entities.RawsSpec
 import qualified Xanthous.GameSpec
+import qualified Xanthous.Generators.UtilSpec
 import qualified Xanthous.MessageSpec
 import qualified Xanthous.OrphansSpec
-import qualified Xanthous.Entities.RawsSpec
 
 main :: IO ()
 main = defaultMain test
@@ -14,6 +15,7 @@ test = testGroup "Xanthous"
   [ Xanthous.Data.EntityMapSpec.test
   , Xanthous.Entities.RawsSpec.test
   , Xanthous.GameSpec.test
+  , Xanthous.Generators.UtilSpec.test
   , Xanthous.MessageSpec.test
   , Xanthous.OrphansSpec.test
   , Xanthous.DataSpec.test

test/Xanthous/Generators/UtilSpec.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE PackageImports #-}
+
+module Xanthous.Generators.UtilSpec (main, test) where
+
+import Test.Prelude
+import System.Random (mkStdGen)
+import Control.Monad.Random (runRandT)
+import Data.Array.ST (STUArray, runSTUArray, thaw)
+import Data.Array.IArray (bounds)
+import Data.Array.MArray (newArray, readArray, writeArray)
+import Data.Array (Array, range, listArray, Ix)
+import Control.Monad.ST (ST, runST)
+import "checkers" Test.QuickCheck.Instances.Array ()
+
+import Xanthous.Util
+import Xanthous.Data (width, height)
+import Xanthous.Generators.Util
+
+main :: IO ()
+main = defaultMain test
+
+newtype GenArray a b = GenArray (Array a b)
+  deriving stock (Show, Eq)
+
+instance (Ix a, Arbitrary a, CoArbitrary a, Arbitrary b) => Arbitrary (GenArray a b) where
+  arbitrary = GenArray <$> do
+    (mkElem :: a -> b) <- arbitrary
+    minDims <- arbitrary
+    maxDims <- arbitrary
+    let bnds = (minDims, maxDims)
+    pure $ listArray bnds $ mkElem <$> range bnds
+
+test :: TestTree
+test = testGroup "Xanthous.Generators.Util"
+  [ testGroup "randInitialize"
+    [ testProperty "returns an array of the correct dimensions" $ \dims seed aliveChance ->
+        let gen = mkStdGen seed
+            res = runSTUArray
+                $ fmap fst
+                $ flip runRandT gen
+                $ randInitialize dims aliveChance
+        in bounds res === ((0, 0), (dims ^. width, dims ^. height))
+    ]
+  , testGroup "numAliveNeighbors"
+    [ testProperty "maxes out at 8" $ \(GenArray (arr :: Array (Word, Word) Bool)) loc ->
+        let
+          act :: forall s. ST s Word
+          act = do
+            mArr <- thaw @_ @_ @_ @(STUArray s) arr
+            numAliveNeighborsM mArr loc
+          res = runST act
+        in counterexample (show res) $ between 0 8 res
+    ]
+  , testGroup "cloneMArray"
+      [ testCase "clones the array" $ runST $
+          let
+            go :: forall s. ST s Assertion
+            go = do
+              arr <- newArray @(STUArray s) (0 :: Int, 5) (1 :: Int)
+              arr' <- cloneMArray @_ @(STUArray s) arr
+              writeArray arr' 0 1234
+              x <- readArray arr 0
+              pure $ x @?= 1
+          in go
+      ]
+  ]

xanthous.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 1e2605418faf05255c5de59433688704543e21d7d3edf669e7e18a99977c0241
+-- hash: e01963f3bf85136fe2b6993775d225999898d4c478efef6f917056f726d72e33
 
 name:           xanthous
 version:        0.1.0.0
@@ -42,6 +42,9 @@ library
       Xanthous.Entities.SomeEntity
       Xanthous.Game
       Xanthous.Game.Draw
+      Xanthous.Generators
+      Xanthous.Generators.CaveAutomata
+      Xanthous.Generators.Util
       Xanthous.Messages
       Xanthous.Monad
       Xanthous.Orphans
@@ -59,6 +62,7 @@ library
       MonadRandom
     , QuickCheck
     , aeson
+    , array
     , base
     , brick
     , checkers
@@ -75,6 +79,7 @@ library
     , lens
     , megaparsec
     , mtl
+    , optparse-applicative
     , quickcheck-instances
     , quickcheck-text
     , random
@@ -102,6 +107,9 @@ executable xanthous
       Xanthous.Entities.SomeEntity
       Xanthous.Game
       Xanthous.Game.Draw
+      Xanthous.Generators
+      Xanthous.Generators.CaveAutomata
+      Xanthous.Generators.Util
       Xanthous.Messages
       Xanthous.Monad
       Xanthous.Orphans
@@ -118,6 +126,7 @@ executable xanthous
       MonadRandom
     , QuickCheck
     , aeson
+    , array
     , base
     , brick
     , checkers
@@ -134,6 +143,7 @@ executable xanthous
     , lens
     , megaparsec
     , mtl
+    , optparse-applicative
     , quickcheck-instances
     , quickcheck-text
     , random
@@ -155,6 +165,7 @@ test-suite test
       Xanthous.DataSpec
       Xanthous.Entities.RawsSpec
       Xanthous.GameSpec
+      Xanthous.Generators.UtilSpec
       Xanthous.MessageSpec
       Xanthous.OrphansSpec
       Paths_xanthous
@@ -166,6 +177,7 @@ test-suite test
       MonadRandom
     , QuickCheck
     , aeson
+    , array
     , base
     , brick
     , checkers
@@ -183,6 +195,7 @@ test-suite test
     , lens-properties
     , megaparsec
     , mtl
+    , optparse-applicative
     , quickcheck-instances
     , quickcheck-text
     , random