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.
This commit is contained in:
Griffin Smith 2019-09-13 15:24:05 -04:00
parent 9ebdc6fbb4
commit c06edf3cc6
9 changed files with 171 additions and 34 deletions

View file

@ -1,20 +1,23 @@
module Main where module Main ( main ) where
--------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
import Brick import Brick
import qualified Options.Applicative as Opt import qualified Options.Applicative as Opt
import System.Random import System.Random
--------------------------------------------------------------------------------
import Xanthous.Game (getInitialState) import Xanthous.Game (getInitialState)
import Xanthous.App (makeApp) import Xanthous.App (makeApp)
import Xanthous.Generators import Xanthous.Generators
( GeneratorInput(..) ( GeneratorInput(..)
, parseGeneratorInput , parseGeneratorInput
, generateFromInput , generateFromInput
, showCells , 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 data Command
= Run = Run
| Generate GeneratorInput Dimensions | Generate GeneratorInput Dimensions
@ -61,6 +64,13 @@ runGenerate :: GeneratorInput -> Dimensions -> IO ()
runGenerate input dims = do runGenerate input dims = do
randGen <- getStdGen randGen <- getStdGen
let res = generateFromInput input dims randGen 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 putStrLn $ showCells res
runCommand :: Command -> IO () runCommand :: Command -> IO ()

View file

@ -9,7 +9,13 @@ import Control.Monad.State (get)
import Control.Monad.Random (getRandom) import Control.Monad.Random (getRandom)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Command 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 qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data.EntityMap (EntityMap) import Xanthous.Data.EntityMap (EntityMap)
import Xanthous.Game import Xanthous.Game
@ -24,6 +30,7 @@ import Xanthous.Entities.Raws (raw)
import Xanthous.Entities import Xanthous.Entities
import Xanthous.Generators import Xanthous.Generators
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import Xanthous.Generators.LevelContents
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
type App = Brick.App GameState () Name type App = Brick.App GameState () Name
@ -49,10 +56,13 @@ testGormlak =
startEvent :: AppM () startEvent :: AppM ()
startEvent = do startEvent = do
say_ ["welcome"] say_ ["welcome"]
level <- generateLevel SCaveAutomata CaveAutomata.defaultParams (level, charPos) <-
$ Dimensions 120 80 generateLevel SCaveAutomata CaveAutomata.defaultParams
$ Dimensions 80 80
entities <>= level 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 :: BrickEvent Name () -> AppM (Next GameState)
handleEvent (VtyEvent (EvKey k mods)) 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 generateLevel g ps dims = do
gen <- use randomGen gen <- use randomGen
let cells = generate g ps dims gen let cells = generate g ps dims gen
_ <- getRandom @_ @Int -- perturb the generator, so we don't get the same level twice _ <- 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)

View file

@ -15,6 +15,7 @@ module Xanthous.Data
, position , position
, positioned , positioned
, loc , loc
, positionFromPair
-- * -- *
, Dimensions'(..) , Dimensions'(..)
@ -91,6 +92,9 @@ loc = iso hither yon
hither (Position px py) = Location (px, py) hither (Position px py) = Location (px, py)
yon (Location (lx, ly)) = Position lx ly 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 data Dimensions' a = Dimensions

View file

@ -101,7 +101,7 @@ _EntityMap = iso hither yon
yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap
instance Semigroup (EntityMap a) where 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 instance Monoid (EntityMap a) where
mempty = emptyEntityMap mempty = emptyEntityMap

View file

@ -33,13 +33,13 @@ generate
-> Params gen -> Params gen
-> Dimensions -> Dimensions
-> g -> g
-> UArray (Word, Word) Bool -> Cells
generate SCaveAutomata = CaveAutomata.generate generate SCaveAutomata = CaveAutomata.generate
data GeneratorInput where data GeneratorInput where
GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput 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 generateFromInput (GeneratorInput sg ps) = generate sg ps
parseGeneratorInput :: Opt.Parser GeneratorInput parseGeneratorInput :: Opt.Parser GeneratorInput
@ -48,7 +48,7 @@ parseGeneratorInput = Opt.subparser $
(GeneratorInput <$> pure SCaveAutomata <*> CaveAutomata.parseParams) (GeneratorInput <$> pure SCaveAutomata <*> CaveAutomata.parseParams)
(Opt.progDesc "cellular-automata based cave generator")) (Opt.progDesc "cellular-automata based cave generator"))
showCells :: UArray (Word, Word) Bool -> Text showCells :: Cells -> Text
showCells arr = showCells arr =
let ((minX, minY), (maxX, maxY)) = bounds arr let ((minX, minY), (maxX, maxY)) = bounds arr
showCellVal True = "x" showCellVal True = "x"
@ -58,7 +58,7 @@ showCells arr =
rows = row <$> [minY..maxY] rows = row <$> [minY..maxY]
in intercalate "\n" rows in intercalate "\n" rows
cellsToWalls :: UArray (Word, Word) Bool -> EntityMap Wall cellsToWalls :: Cells -> EntityMap Wall
cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
where where
maybeInsertWall em (pos@(x, y), True) maybeInsertWall em (pos@(x, y), True)

View file

@ -92,7 +92,7 @@ generate params dims gen
$ flip runRandT gen $ flip runRandT gen
$ generate' params dims $ 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 generate' params dims = do
cells <- randInitialize dims $ params ^. aliveStartChance cells <- randInitialize dims $ params ^. aliveStartChance
let steps' = params ^. steps let steps' = params ^. steps
@ -100,7 +100,7 @@ generate' params dims = do
$ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params
pure cells 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 stepAutomata cells dims params = do
origCells <- lift $ cloneMArray @_ @(STUArray s) cells origCells <- lift $ cloneMArray @_ @(STUArray s) cells
for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do

View file

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

View file

@ -1,28 +1,34 @@
-- | {-# LANGUAGE ViewPatterns #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.Util module Xanthous.Generators.Util
( Cells ( MCells
, Cells
, CellM , CellM
, randInitialize , randInitialize
, numAliveNeighborsM , numAliveNeighborsM
, numAliveNeighbors , numAliveNeighbors
, cloneMArray , cloneMArray
, floodFill
, regions
) where ) where
--------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude hiding (Foldable, toList)
import Data.Array.ST import Data.Array.ST
import Data.Array.Unboxed import Data.Array.Unboxed
import Control.Monad.ST import Control.Monad.ST
import Control.Monad.Random import Control.Monad.Random
import Data.Monoid import Data.Monoid
import Data.Foldable (Foldable, toList)
import Xanthous.Util (foldlMapM') --------------------------------------------------------------------------------
import Xanthous.Util (foldlMapM', between)
import Xanthous.Data (Dimensions, width, height) 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 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 randInitialize dims aliveChance = do
res <- lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False res <- lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False
for_ [0..dims ^. width] $ \i -> for_ [0..dims ^. width] $ \i ->
@ -87,6 +93,14 @@ numAliveNeighbors cells (x, y) =
neighborPositions :: [(Int, Int)] neighborPositions :: [(Int, Int)]
neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] 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 cloneMArray
:: forall a a' i e m. :: forall a a' i e m.
( Ix i ( Ix i
@ -97,3 +111,68 @@ cloneMArray
=> a i e => a i e
-> m (a' i e) -> m (a' i e)
cloneMArray = thaw @_ @UArray <=< freeze 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

View file

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 3fbeb53b2706e3f0186fa3c80619a166f64eb52cf045006ac993074fa7f3e9d1 -- hash: a79caccff8895730c394c19244f068830759636d17f55f3b6d1d8a9ebe43ecdd
name: xanthous name: xanthous
version: 0.1.0.0 version: 0.1.0.0
@ -46,6 +46,7 @@ library
Xanthous.Game.Draw Xanthous.Game.Draw
Xanthous.Generators Xanthous.Generators
Xanthous.Generators.CaveAutomata Xanthous.Generators.CaveAutomata
Xanthous.Generators.LevelContents
Xanthous.Generators.Util Xanthous.Generators.Util
Xanthous.Messages Xanthous.Messages
Xanthous.Monad Xanthous.Monad
@ -113,6 +114,7 @@ executable xanthous
Xanthous.Game.Draw Xanthous.Game.Draw
Xanthous.Generators Xanthous.Generators
Xanthous.Generators.CaveAutomata Xanthous.Generators.CaveAutomata
Xanthous.Generators.LevelContents
Xanthous.Generators.Util Xanthous.Generators.Util
Xanthous.Messages Xanthous.Messages
Xanthous.Monad Xanthous.Monad