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:
parent
9ebdc6fbb4
commit
c06edf3cc6
9 changed files with 171 additions and 34 deletions
18
src/Main.hs
18
src/Main.hs
|
@ -1,10 +1,10 @@
|
|||
module Main where
|
||||
|
||||
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
|
||||
|
@ -13,8 +13,11 @@ import Xanthous.Generators
|
|||
, generateFromInput
|
||||
, showCells
|
||||
)
|
||||
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 ()
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
26
src/Xanthous/Generators/LevelContents.hs
Normal file
26
src/Xanthous/Generators/LevelContents.hs
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue