diff options
| -rw-r--r-- | src/Xanthous/App.hs | 12 | ||||
| -rw-r--r-- | src/Xanthous/Entities/Entities.hs | 2 | ||||
| -rw-r--r-- | src/Xanthous/Game/Arbitrary.hs | 24 | ||||
| -rw-r--r-- | src/Xanthous/Game/Lenses.hs | 8 | ||||
| -rw-r--r-- | src/Xanthous/Game/State.hs | 34 |
5 files changed, 61 insertions, 19 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 577466328101..1f7714da1d57 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -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 {..} diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs index 1e533a297310..1b9f138fe22f 100644 --- a/src/Xanthous/Entities/Entities.hs +++ b/src/Xanthous/Entities/Entities.hs @@ -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 diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs index d6f4784d55ff..4a64a12be096 100644 --- a/src/Xanthous/Game/Arbitrary.hs +++ b/src/Xanthous/Game/Arbitrary.hs @@ -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) diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index 010fcb7022b5..8f6053a5ecc6 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -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 diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 36a2c2c174e5..e5ee66deac45 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -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 -> |