From 006e5231e526b3b1e9d06644bd1d2de9d5decb1e Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 12 Jun 2021 14:57:30 -0400 Subject: refactor(xanthous): Generators -> Generators.Level I'm going to start adding generators for things like text soon, so it makes sense to specifically sequester level generators as their own thing Change-Id: I175025375204fab7d75eba67dd06dab9bd2939d3 Reviewed-on: https://cl.tvl.fyi/c/depot/+/3201 Reviewed-by: grfn Tested-by: BuildkiteCI --- users/grfn/xanthous/src/Xanthous/Generators.hs | 168 ------------------------- 1 file changed, 168 deletions(-) delete mode 100644 users/grfn/xanthous/src/Xanthous/Generators.hs (limited to 'users/grfn/xanthous/src/Xanthous/Generators.hs') diff --git a/users/grfn/xanthous/src/Xanthous/Generators.hs b/users/grfn/xanthous/src/Xanthous/Generators.hs deleted file mode 100644 index ef37070b6ede..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators - ( generate - , Generator(..) - , SGenerator(..) - , GeneratorInput(..) - , generateFromInput - , parseGeneratorInput - , showCells - , Level(..) - , levelWalls - , levelItems - , levelCreatures - , levelDoors - , levelCharacterPosition - , levelTutorialMessage - , levelExtra - , generateLevel - , levelToEntityMap - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Data.Array.Unboxed -import qualified Options.Applicative as Opt -import Control.Monad.Random --------------------------------------------------------------------------------- -import qualified Xanthous.Generators.CaveAutomata as CaveAutomata -import qualified Xanthous.Generators.Dungeon as Dungeon -import Xanthous.Generators.Util -import Xanthous.Generators.LevelContents -import Xanthous.Generators.Village as Village -import Xanthous.Data (Dimensions, Position'(Position), Position) -import Xanthous.Data.EntityMap (EntityMap, _EntityMap) -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Environment -import Xanthous.Entities.Item (Item) -import Xanthous.Entities.Creature (Creature) -import Xanthous.Game.State (SomeEntity(..)) -import Linear.V2 --------------------------------------------------------------------------------- - -data Generator - = CaveAutomata - | Dungeon - deriving stock (Show, Eq) - -data SGenerator (gen :: Generator) where - SCaveAutomata :: SGenerator 'CaveAutomata - SDungeon :: SGenerator 'Dungeon - -type family Params (gen :: Generator) :: Type where - Params 'CaveAutomata = CaveAutomata.Params - Params 'Dungeon = Dungeon.Params - -generate - :: RandomGen g - => SGenerator gen - -> Params gen - -> Dimensions - -> g - -> Cells -generate SCaveAutomata = CaveAutomata.generate -generate SDungeon = Dungeon.generate - -data GeneratorInput where - GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput - -generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells -generateFromInput (GeneratorInput sg ps) = generate sg ps - -parseGeneratorInput :: Opt.Parser GeneratorInput -parseGeneratorInput = Opt.subparser - $ generatorCommand SCaveAutomata - "cave" - "Cellular-automata based cave generator" - CaveAutomata.parseParams - <> generatorCommand SDungeon - "dungeon" - "Classic dungeon map generator" - Dungeon.parseParams - where - generatorCommand sgen name desc parseParams = - Opt.command name - (Opt.info - (GeneratorInput <$> pure sgen <*> parseParams) - (Opt.progDesc desc) - ) - - -showCells :: Cells -> Text -showCells arr = - let (V2 minX minY, V2 maxX maxY) = bounds arr - showCellVal True = "x" - showCellVal False = " " - showCell = showCellVal . (arr !) - row r = foldMap (showCell . (`V2` r)) [minX..maxX] - rows = row <$> [minY..maxY] - in intercalate "\n" rows - -cellsToWalls :: Cells -> EntityMap Wall -cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells - where - maybeInsertWall em (pos@(V2 x y), True) - | not (surroundedOnAllSides pos) = - let x' = fromIntegral x - y' = fromIntegral y - in EntityMap.insertAt (Position x' y') Wall em - maybeInsertWall em _ = em - surroundedOnAllSides pos = numAliveNeighbors cells pos == 8 - --------------------------------------------------------------------------------- - -data Level = Level - { _levelWalls :: !(EntityMap Wall) - , _levelDoors :: !(EntityMap Door) - , _levelItems :: !(EntityMap Item) - , _levelCreatures :: !(EntityMap Creature) - , _levelTutorialMessage :: !(EntityMap GroundMessage) - , _levelStaircases :: !(EntityMap Staircase) - , _levelExtra :: !(EntityMap SomeEntity) -- ^ TODO this is a bit of a hack... - , _levelCharacterPosition :: !Position - } - deriving stock (Generic) - deriving anyclass (NFData) -makeLenses ''Level - -generateLevel - :: MonadRandom m - => SGenerator gen - -> Params gen - -> Dimensions - -> m Level -generateLevel gen ps dims = do - rand <- mkStdGen <$> getRandom - let cells = generate gen ps dims rand - _levelWalls = cellsToWalls cells - village <- generateVillage cells gen - let _levelExtra = village - _levelItems <- randomItems cells - _levelCreatures <- randomCreatures cells - _levelDoors <- randomDoors cells - _levelCharacterPosition <- chooseCharacterPosition cells - let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)] - downStaircase <- placeDownStaircase cells - let _levelStaircases = upStaircase <> downStaircase - _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition - pure Level {..} - -levelToEntityMap :: Level -> EntityMap SomeEntity -levelToEntityMap level - = (SomeEntity <$> level ^. levelWalls) - <> (SomeEntity <$> level ^. levelDoors) - <> (SomeEntity <$> level ^. levelItems) - <> (SomeEntity <$> level ^. levelCreatures) - <> (SomeEntity <$> level ^. levelTutorialMessage) - <> (SomeEntity <$> level ^. levelStaircases) - <> (level ^. levelExtra) - -generateVillage - :: MonadRandom m - => Cells -- ^ Wall positions - -> SGenerator gen - -> m (EntityMap SomeEntity) -generateVillage wallPositions SCaveAutomata = Village.fromCave wallPositions -generateVillage _ _ = pure mempty -- cgit 1.4.1