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.
This commit is contained in:
Griffin Smith 2019-09-07 14:49:59 -04:00
parent 73a52e531d
commit f03ad6bbd6
10 changed files with 434 additions and 8 deletions

View file

@ -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

View file

@ -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 ()
ui = str "Hello, world!"
data Command
= Run
| Generate GeneratorInput Dimensions
main :: IO ()
main = do
parseDimensions :: Opt.Parser Dimensions
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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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
]
]

View file

@ -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