diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 62 | ||||
| -rw-r--r-- | src/Xanthous/Data.hs | 21 | ||||
| -rw-r--r-- | src/Xanthous/Generators.hs | 54 | ||||
| -rw-r--r-- | src/Xanthous/Generators/CaveAutomata.hs | 112 | ||||
| -rw-r--r-- | src/Xanthous/Generators/Util.hs | 70 | ||||
| -rw-r--r-- | src/Xanthous/Util.hs | 34 |
6 files changed, 348 insertions, 5 deletions
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 @@ -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 |