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
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 ()

View file

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

View file

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

View file

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

View file

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

View file

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

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

View file

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