From f03ad6bbd60b6ccdd329fc6740bcea2b554980dd Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 7 Sep 2019 14:49:59 -0400 Subject: 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 | 2 + src/Main.hs | 62 ++++++++++++++++-- src/Xanthous/Data.hs | 21 ++++++ src/Xanthous/Generators.hs | 54 +++++++++++++++ src/Xanthous/Generators/CaveAutomata.hs | 112 ++++++++++++++++++++++++++++++++ src/Xanthous/Generators/Util.hs | 70 ++++++++++++++++++++ src/Xanthous/Util.hs | 34 +++++++++- test/Spec.hs | 6 +- test/Xanthous/Generators/UtilSpec.hs | 66 +++++++++++++++++++ xanthous.cabal | 15 ++++- 10 files changed, 434 insertions(+), 8 deletions(-) create mode 100644 src/Xanthous/Generators.hs create mode 100644 src/Xanthous/Generators/CaveAutomata.hs create mode 100644 src/Xanthous/Generators/Util.hs create mode 100644 test/Xanthous/Generators/UtilSpec.hs diff --git a/package.yaml b/package.yaml index 9ea1ee521712..7df7234c160d 100644 --- a/package.yaml +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 1cd4e9445789..4d6ccfd4afc6 100644 --- a/src/Main.hs +++ b/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 () -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 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 @@ -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 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 diff --git a/test/Spec.hs b/test/Spec.hs index 7ae9b40d267e..dd4212c2eb70 100644 --- a/test/Spec.hs +++ b/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 diff --git a/test/Xanthous/Generators/UtilSpec.hs b/test/Xanthous/Generators/UtilSpec.hs new file mode 100644 index 000000000000..a1c2f79d6042 --- /dev/null +++ b/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 + ] + ] diff --git a/xanthous.cabal b/xanthous.cabal index 7f7d12932c57..36a560880552 100644 --- a/xanthous.cabal +++ b/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 -- cgit 1.4.1