From c06edf3cc698f36e995719dc6e192c5663110f6d Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 13 Sep 2019 15:24:05 -0400 Subject: Place the chacracter in the level at startup time Randomly select a position in the largest contiguous region of the generated level in which to place the character at startup time. --- src/Main.hs | 32 +++++++---- src/Xanthous/App.hs | 28 +++++++-- src/Xanthous/Data.hs | 4 ++ src/Xanthous/Data/EntityMap.hs | 2 +- src/Xanthous/Generators.hs | 8 +-- src/Xanthous/Generators/CaveAutomata.hs | 4 +- src/Xanthous/Generators/LevelContents.hs | 26 +++++++++ src/Xanthous/Generators/Util.hs | 97 +++++++++++++++++++++++++++++--- 8 files changed, 168 insertions(+), 33 deletions(-) create mode 100644 src/Xanthous/Generators/LevelContents.hs (limited to 'src') diff --git a/src/Main.hs b/src/Main.hs index d49e082b7c..2da277b640 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,20 +1,23 @@ -module Main where - -import Xanthous.Prelude -import Brick +module Main ( 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 +import System.Random +-------------------------------------------------------------------------------- +import Xanthous.Game (getInitialState) +import Xanthous.App (makeApp) +import Xanthous.Generators ( GeneratorInput(..) , parseGeneratorInput , generateFromInput , showCells ) -import Xanthous.Data (Dimensions, Dimensions'(Dimensions)) - +import Xanthous.Generators.Util (regions) +import Xanthous.Generators.LevelContents +import Xanthous.Data (Dimensions, Dimensions'(Dimensions)) +import Data.Array.IArray ( amap ) +-------------------------------------------------------------------------------- data Command = Run | Generate GeneratorInput Dimensions @@ -61,6 +64,13 @@ runGenerate :: GeneratorInput -> Dimensions -> IO () runGenerate input dims = do randGen <- getStdGen let res = generateFromInput input dims randGen + rs = regions $ amap not res + putStr "num regions: " + print $ length rs + putStr "region lengths: " + print $ length <$> rs + putStr "character position: " + print =<< chooseCharacterPosition res putStrLn $ showCells res runCommand :: Command -> IO () diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index af6b5caf61..0dc24b9d41 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -9,7 +9,13 @@ import Control.Monad.State (get) import Control.Monad.Random (getRandom) -------------------------------------------------------------------------------- import Xanthous.Command -import Xanthous.Data (move, Position(..), Dimensions'(Dimensions), Dimensions) +import Xanthous.Data + ( move + , Position(..) + , Dimensions'(Dimensions) + , Dimensions + , positionFromPair + ) import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Data.EntityMap (EntityMap) import Xanthous.Game @@ -24,6 +30,7 @@ import Xanthous.Entities.Raws (raw) import Xanthous.Entities import Xanthous.Generators import qualified Xanthous.Generators.CaveAutomata as CaveAutomata +import Xanthous.Generators.LevelContents -------------------------------------------------------------------------------- type App = Brick.App GameState () Name @@ -49,10 +56,13 @@ testGormlak = startEvent :: AppM () startEvent = do say_ ["welcome"] - level <- generateLevel SCaveAutomata CaveAutomata.defaultParams - $ Dimensions 120 80 + (level, charPos) <- + generateLevel SCaveAutomata CaveAutomata.defaultParams + $ Dimensions 80 80 entities <>= level - entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak) + characterPosition .= charPos + -- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak) + handleEvent :: BrickEvent Name () -> AppM (Next GameState) handleEvent (VtyEvent (EvKey k mods)) @@ -73,9 +83,15 @@ handleCommand PreviousMessage = do -------------------------------------------------------------------------------- -generateLevel :: SGenerator gen -> Params gen -> Dimensions -> AppM (EntityMap SomeEntity) +generateLevel + :: SGenerator gen + -> Params gen + -> Dimensions + -> AppM (EntityMap SomeEntity, Position) generateLevel g ps dims = do gen <- use randomGen let cells = generate g ps dims gen _ <- getRandom @_ @Int -- perturb the generator, so we don't get the same level twice - pure $ SomeEntity <$> cellsToWalls cells + charPos <- positionFromPair <$> chooseCharacterPosition cells + let level = SomeEntity <$> cellsToWalls cells + pure (level, charPos) diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index e435526384..468e59217c 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -15,6 +15,7 @@ module Xanthous.Data , position , positioned , loc + , positionFromPair -- * , Dimensions'(..) @@ -91,6 +92,9 @@ loc = iso hither yon hither (Position px py) = Location (px, py) yon (Location (lx, ly)) = Position lx ly +positionFromPair :: (Integral i, Integral j) => (i, j) -> Position +positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) + -------------------------------------------------------------------------------- data Dimensions' a = Dimensions diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs index 401e395547..e713aff32c 100644 --- a/src/Xanthous/Data/EntityMap.hs +++ b/src/Xanthous/Data/EntityMap.hs @@ -101,7 +101,7 @@ _EntityMap = iso hither yon yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap instance Semigroup (EntityMap a) where - em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₁ ^. _EntityMap) em₂ + em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁ instance Monoid (EntityMap a) where mempty = emptyEntityMap diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs index 740b39c5f0..6e2e89d14a 100644 --- a/src/Xanthous/Generators.hs +++ b/src/Xanthous/Generators.hs @@ -33,13 +33,13 @@ generate -> Params gen -> Dimensions -> g - -> UArray (Word, Word) Bool + -> Cells 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 :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells generateFromInput (GeneratorInput sg ps) = generate sg ps parseGeneratorInput :: Opt.Parser GeneratorInput @@ -48,7 +48,7 @@ parseGeneratorInput = Opt.subparser $ (GeneratorInput <$> pure SCaveAutomata <*> CaveAutomata.parseParams) (Opt.progDesc "cellular-automata based cave generator")) -showCells :: UArray (Word, Word) Bool -> Text +showCells :: Cells -> Text showCells arr = let ((minX, minY), (maxX, maxY)) = bounds arr showCellVal True = "x" @@ -58,7 +58,7 @@ showCells arr = rows = row <$> [minY..maxY] in intercalate "\n" rows -cellsToWalls :: UArray (Word, Word) Bool -> EntityMap Wall +cellsToWalls :: Cells -> EntityMap Wall cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells where maybeInsertWall em (pos@(x, y), True) diff --git a/src/Xanthous/Generators/CaveAutomata.hs b/src/Xanthous/Generators/CaveAutomata.hs index bf37cb3f08..a2f0a165e3 100644 --- a/src/Xanthous/Generators/CaveAutomata.hs +++ b/src/Xanthous/Generators/CaveAutomata.hs @@ -92,7 +92,7 @@ generate params dims gen $ flip runRandT gen $ generate' params dims -generate' :: RandomGen g => Params -> Dimensions -> CellM g s (Cells s) +generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) generate' params dims = do cells <- randInitialize dims $ params ^. aliveStartChance let steps' = params ^. steps @@ -100,7 +100,7 @@ generate' params dims = do $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params pure cells -stepAutomata :: forall s g. Cells s -> Dimensions -> Params -> CellM g s () +stepAutomata :: forall s g. MCells 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 diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs new file mode 100644 index 0000000000..f8d9b8a204 --- /dev/null +++ b/src/Xanthous/Generators/LevelContents.hs @@ -0,0 +1,26 @@ +-------------------------------------------------------------------------------- +module Xanthous.Generators.LevelContents + ( chooseCharacterPosition + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Control.Monad.Random +import Data.Array.IArray (amap) +-------------------------------------------------------------------------------- +import Xanthous.Generators.Util +import Xanthous.Random +-------------------------------------------------------------------------------- + +chooseCharacterPosition :: MonadRandom m => Cells -> m (Word, Word) +chooseCharacterPosition cells = choose $ impureNonNull candidates + where + -- cells ends up with true = wall, we want true = can put a character here + placeableCells = amap not cells + + -- find the largest contiguous region of cells in the cave. + candidates + = maximumBy (compare `on` length) + $ fromMaybe (error "No regions generated! this should never happen.") + $ fromNullable + $ regions placeableCells diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs index 260c41ac60..47ee81b293 100644 --- a/src/Xanthous/Generators/Util.hs +++ b/src/Xanthous/Generators/Util.hs @@ -1,28 +1,34 @@ --- | - +{-# LANGUAGE ViewPatterns #-} +-------------------------------------------------------------------------------- module Xanthous.Generators.Util - ( Cells + ( MCells + , Cells , CellM , randInitialize , numAliveNeighborsM , numAliveNeighbors , cloneMArray + , floodFill + , regions ) where - -import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Foldable, toList) import Data.Array.ST import Data.Array.Unboxed import Control.Monad.ST import Control.Monad.Random import Data.Monoid - -import Xanthous.Util (foldlMapM') +import Data.Foldable (Foldable, toList) +-------------------------------------------------------------------------------- +import Xanthous.Util (foldlMapM', between) import Xanthous.Data (Dimensions, width, height) +-------------------------------------------------------------------------------- -type Cells s = STUArray s (Word, Word) Bool +type MCells s = STUArray s (Word, Word) Bool +type Cells = UArray (Word, Word) Bool type CellM g s a = RandT g (ST s) a -randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (Cells s) +randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) randInitialize dims aliveChance = do res <- lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False for_ [0..dims ^. width] $ \i -> @@ -87,6 +93,14 @@ numAliveNeighbors cells (x, y) = neighborPositions :: [(Int, Int)] neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] +safeGet :: (IArray a e, Ix i) => a i e -> i -> Maybe e +safeGet arr idx = + let (minIdx, maxIdx) = bounds arr + in if idx < minIdx || idx > maxIdx + then Nothing + else Just $ arr ! idx + + cloneMArray :: forall a a' i e m. ( Ix i @@ -97,3 +111,68 @@ cloneMArray => a i e -> m (a' i e) cloneMArray = thaw @_ @UArray <=< freeze + +-------------------------------------------------------------------------------- + +-- | Flood fill a cell array starting at a point, returning a list of all the +-- (true) cell locations reachable from that point +floodFill :: forall a i j. + ( IArray a Bool + , Ix (i, j) + , Enum i , Enum j + , Bounded i , Bounded j + , Eq i , Eq j + , Show i, Show j + ) + => a (i, j) Bool -- ^ array + -> (i, j) -- ^ position + -> Set (i, j) +floodFill = go mempty + where + go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j) + -- TODO pass result in rather than passing seen in, return result + go res arr@(bounds -> arrBounds) idx@(x, y) + | not (inRange arrBounds idx) = res + | not (arr ! idx) = res + | otherwise = + let neighbors + = filter (inRange arrBounds) + . filter (/= idx) + . filter (`notMember` res) + $ (,) + <$> [(if x == minBound then x else pred x) + .. + (if x == maxBound then x else succ x)] + <*> [(if y == minBound then y else pred y) + .. + (if y == maxBound then y else succ y)] + in foldl' (\r idx' -> + if arr ! idx' + then r <> go (r & contains idx' .~ True) arr idx' + else r) + (res & contains idx .~ True) neighbors + +-- | Gives a list of all the disconnected regions in a cell array, represented +-- each as lists of points +regions :: forall a i j. + ( IArray a Bool + , Ix (i, j) + , Enum i , Enum j + , Bounded i , Bounded j + , Eq i , Eq j + , Show i, Show j + ) + => a (i, j) Bool + -> [Set (i, j)] +regions arr + | Just firstPoint <- findFirstPoint arr = + let region = floodFill arr firstPoint + arr' = fillAll region arr + in region : regions arr' + | otherwise = [] + where + findFirstPoint :: a (i, j) Bool -> Maybe (i, j) + findFirstPoint = fmap fst . headMay . filter snd . assocs + + fillAll :: Foldable f => f (i, j) -> a (i, j) Bool -> a (i, j) Bool + fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes -- cgit 1.4.1