Store revealed positions on the level itself
This was a bit of an oversight initially - we should be storing the positions that the character has seen *on the level*, rather than on the entire game state, for obvious reasons. This introduces a GameLevel record, which has this field, the entities, and also the up staircase position, which we can *also* use to position the character after going down to a level we've already visited.
This commit is contained in:
		
							parent
							
								
									72edcff323
								
							
						
					
					
						commit
						7082a4088b
					
				
					 5 changed files with 61 additions and 19 deletions
				
			
		|  | @ -1,5 +1,6 @@ | |||
| {-# LANGUAGE ViewPatterns #-} | ||||
| {-# LANGUAGE ViewPatterns         #-} | ||||
| {-# LANGUAGE UndecidableInstances #-} | ||||
| {-# LANGUAGE RecordWildCards      #-} | ||||
| -------------------------------------------------------------------------------- | ||||
| module Xanthous.App (makeApp) where | ||||
| -------------------------------------------------------------------------------- | ||||
|  | @ -298,7 +299,7 @@ handleCommand GoDown = do | |||
|   then do | ||||
|     levs <- use levels | ||||
|     let newLevelNum = Levels.pos levs + 1 | ||||
|     levs' <- nextLevel (levelToEntityMap <$> genLevel newLevelNum) levs | ||||
|     levs' <- nextLevel (levelToGameLevel <$> genLevel newLevelNum) levs | ||||
|     cEID <- use characterEntityID | ||||
|     pCharacter <- entities . at cEID <<.= Nothing | ||||
|     levels .= levs' | ||||
|  | @ -600,3 +601,10 @@ genLevel _num = do | |||
|     Dungeon -> generateLevel SDungeon Dungeon.defaultParams dims | ||||
|   characterPosition .= level ^. levelCharacterPosition | ||||
|   pure $!! level | ||||
| 
 | ||||
| levelToGameLevel :: Level -> GameLevel | ||||
| levelToGameLevel level = | ||||
|   let _levelEntities = levelToEntityMap level | ||||
|       _upStaircasePosition = level ^. levelCharacterPosition | ||||
|       _levelRevealedPositions = mempty | ||||
|   in GameLevel {..} | ||||
|  |  | |||
|  | @ -40,6 +40,8 @@ instance FromJSON SomeEntity where | |||
|       "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data" | ||||
|       _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\"" | ||||
| 
 | ||||
| deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel | ||||
|   instance FromJSON GameLevel | ||||
| deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState | ||||
|   instance FromJSON GameState | ||||
| 
 | ||||
|  |  | |||
|  | @ -16,20 +16,26 @@ import qualified Xanthous.Data.EntityMap as EntityMap | |||
| import           Xanthous.Entities.Entities () | ||||
| import           Xanthous.Entities.Character | ||||
| import           Xanthous.Game.State | ||||
| import           Xanthous.Util.QuickCheck (GenericArbitrary(..)) | ||||
| -------------------------------------------------------------------------------- | ||||
| 
 | ||||
| deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel | ||||
| 
 | ||||
| instance Arbitrary GameState where | ||||
|   arbitrary = do | ||||
|     chr <- arbitrary @Character | ||||
|     charPos <- arbitrary | ||||
|     _upStaircasePosition <- arbitrary | ||||
|     _messageHistory <- arbitrary | ||||
|     levs <- arbitrary | ||||
|     let (_characterEntityID, currentLevel) = | ||||
|           EntityMap.insertAtReturningID charPos (SomeEntity chr) | ||||
|           $ extract levs | ||||
|         _levels = levs & current .~ currentLevel | ||||
|     _revealedPositions <- fmap setFromList . sublistOf | ||||
|                          $ foldMap EntityMap.positions levs | ||||
|     levs <- arbitrary @(Levels GameLevel) | ||||
|     _levelRevealedPositions <- | ||||
|       fmap setFromList | ||||
|       . sublistOf | ||||
|       . foldMap (EntityMap.positions . _levelEntities) | ||||
|       $ levs | ||||
|     let (_characterEntityID, _levelEntities) = | ||||
|           EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr) | ||||
|           $ levs ^. current . levelEntities | ||||
|         _levels = levs & current .~ GameLevel {..} | ||||
|     _randomGen <- mkStdGen <$> arbitrary | ||||
|     let _promptState = NoPrompt -- TODO | ||||
|     _activePanel <- arbitrary | ||||
|  | @ -38,6 +44,8 @@ instance Arbitrary GameState where | |||
|     pure $ GameState {..} | ||||
| 
 | ||||
| 
 | ||||
| instance CoArbitrary GameLevel | ||||
| instance Function GameLevel | ||||
| instance CoArbitrary GameState | ||||
| instance Function GameState | ||||
| deriving newtype instance CoArbitrary (m (a, GameState)) => CoArbitrary (AppT m a) | ||||
|  |  | |||
|  | @ -39,14 +39,16 @@ initialStateFromSeed :: Int -> GameState | |||
| initialStateFromSeed seed = | ||||
|   let _randomGen = mkStdGen seed | ||||
|       chr = mkCharacter | ||||
|       (_characterEntityID, level) | ||||
|       _upStaircasePosition = Position 0 0 | ||||
|       (_characterEntityID, _levelEntities) | ||||
|         = EntityMap.insertAtReturningID | ||||
|           (Position 0 0) | ||||
|           _upStaircasePosition | ||||
|           (SomeEntity chr) | ||||
|           mempty | ||||
|       _levelRevealedPositions = mempty | ||||
|       level = GameLevel {..} | ||||
|       _levels = oneLevel level | ||||
|       _messageHistory = mempty | ||||
|       _revealedPositions = mempty | ||||
|       _promptState = NoPrompt | ||||
|       _activePanel = Nothing | ||||
|       _debugState = DebugState | ||||
|  |  | |||
|  | @ -17,6 +17,12 @@ module Xanthous.Game.State | |||
|   , characterEntityID | ||||
|   , GamePromptState(..) | ||||
| 
 | ||||
|     -- * Game Level | ||||
|   , GameLevel(..) | ||||
|   , levelEntities | ||||
|   , upStaircasePosition | ||||
|   , levelRevealedPositions | ||||
| 
 | ||||
|     -- * Messages | ||||
|   , MessageHistory(..) | ||||
|   , HasMessages(..) | ||||
|  | @ -80,6 +86,7 @@ import qualified Graphics.Vty.Attributes as Vty | |||
| import qualified Graphics.Vty.Image as Vty | ||||
| -------------------------------------------------------------------------------- | ||||
| import           Xanthous.Util (KnownBool(..)) | ||||
| import           Xanthous.Util.QuickCheck (GenericArbitrary(..)) | ||||
| import           Xanthous.Data | ||||
| import           Xanthous.Data.Levels | ||||
| import           Xanthous.Data.EntityMap (EntityMap, EntityID) | ||||
|  | @ -98,6 +105,7 @@ data MessageHistory | |||
|   } | ||||
|   deriving stock (Show, Eq, Generic) | ||||
|   deriving anyclass (NFData, CoArbitrary, Function) | ||||
|   deriving Arbitrary via GenericArbitrary MessageHistory | ||||
|   deriving (ToJSON, FromJSON) | ||||
|        via WithOptions '[ FieldLabelModifier '[Drop 1] ] | ||||
|            MessageHistory | ||||
|  | @ -113,9 +121,6 @@ instance Semigroup MessageHistory where | |||
| instance Monoid MessageHistory where | ||||
|   mempty = MessageHistory mempty 0 Nothing | ||||
| 
 | ||||
| instance Arbitrary MessageHistory where | ||||
|   arbitrary = genericArbitrary | ||||
| 
 | ||||
| type instance Element MessageHistory = [Text] | ||||
| instance MonoFunctor MessageHistory where | ||||
|   omap f mh@(MessageHistory _ t _) = | ||||
|  | @ -400,6 +405,19 @@ instance | |||
| 
 | ||||
| -------------------------------------------------------------------------------- | ||||
| 
 | ||||
| data GameLevel = GameLevel | ||||
|   { _levelEntities :: !(EntityMap SomeEntity) | ||||
|   , _upStaircasePosition :: !Position | ||||
|   , _levelRevealedPositions :: !(Set Position) | ||||
|   } | ||||
|   deriving stock (Show, Eq, Generic) | ||||
|   deriving anyclass (NFData) | ||||
|   deriving (ToJSON) | ||||
|        via WithOptions '[ FieldLabelModifier '[Drop 1] ] | ||||
|            GameLevel | ||||
| 
 | ||||
| -------------------------------------------------------------------------------- | ||||
| 
 | ||||
| 
 | ||||
| data DebugState = DebugState | ||||
|   { _allRevealed :: !Bool | ||||
|  | @ -415,8 +433,7 @@ instance Arbitrary DebugState where | |||
|   arbitrary = genericArbitrary | ||||
| 
 | ||||
| data GameState = GameState | ||||
|   { _levels            :: !(Levels (EntityMap SomeEntity)) | ||||
|   , _revealedPositions :: !(Set Position) | ||||
|   { _levels            :: !(Levels GameLevel) | ||||
|   , _characterEntityID :: !EntityID | ||||
|   , _messageHistory    :: !MessageHistory | ||||
|   , _randomGen         :: !StdGen | ||||
|  | @ -433,10 +450,15 @@ data GameState = GameState | |||
|   deriving (ToJSON) | ||||
|        via WithOptions '[ FieldLabelModifier '[Drop 1] ] | ||||
|            GameState | ||||
| 
 | ||||
| makeLenses ''GameLevel | ||||
| makeLenses ''GameState | ||||
| 
 | ||||
| entities :: Lens' GameState (EntityMap SomeEntity) | ||||
| entities = levels . current | ||||
| entities = levels . current . levelEntities | ||||
| 
 | ||||
| revealedPositions :: Lens' GameState (Set Position) | ||||
| revealedPositions = levels . current . levelRevealedPositions | ||||
| 
 | ||||
| instance Eq GameState where | ||||
|   (==) = (==) `on` \gs -> | ||||
|  |  | |||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue