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 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
|
||||||
|
@ -13,8 +13,11 @@ import Xanthous.Generators
|
||||||
, generateFromInput
|
, generateFromInput
|
||||||
, showCells
|
, showCells
|
||||||
)
|
)
|
||||||
|
import Xanthous.Generators.Util (regions)
|
||||||
|
import Xanthous.Generators.LevelContents
|
||||||
import Xanthous.Data (Dimensions, Dimensions'(Dimensions))
|
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 ()
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
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
|
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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue