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…
	
	Add table
		Add a link
		
	
		Reference in a new issue