diff options
Diffstat (limited to 'src/Xanthous/Game')
| -rw-r--r-- | src/Xanthous/Game/Arbitrary.hs | 1 | ||||
| -rw-r--r-- | src/Xanthous/Game/Draw.hs | 19 | ||||
| -rw-r--r-- | src/Xanthous/Game/State.hs | 23 |
3 files changed, 33 insertions, 10 deletions
diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs index 5ab2301e7083..5bba77d5a174 100644 --- a/src/Xanthous/Game/Arbitrary.hs +++ b/src/Xanthous/Game/Arbitrary.hs @@ -24,4 +24,5 @@ instance Arbitrary GameState where _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities _randomGen <- mkStdGen <$> arbitrary let _promptState = NoPrompt -- TODO + _debugState <- arbitrary pure $ GameState {..} diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index ff9240a5e1bf..b3e27f86a693 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -23,6 +23,7 @@ import Xanthous.Game , messageHistory , GamePromptState(..) , promptState + , debugState, allRevealed ) import Xanthous.Game.Prompt import Xanthous.Resource (Name) @@ -46,14 +47,11 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) = _ -> undefined drawEntities - :: Set Position - -- ^ Positions the character has seen - -- FIXME: this will break down as soon as creatures can walk around on their - -- own, since we don't want to render things walking around when the - -- character can't see them + :: (Position -> Bool) + -- ^ Can we render a given position? -> EntityMap SomeEntity -- ^ all entities -> Widget Name -drawEntities visiblePositions allEnts +drawEntities canRenderPos allEnts = vBox rows where entityPositions = EntityMap.positions allEnts @@ -62,7 +60,7 @@ drawEntities visiblePositions allEnts rows = mkRow <$> [0..maxY] mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] renderEntityAt pos - | pos `member` visiblePositions + | canRenderPos pos = let neighbors = EntityMap.neighbors pos allEnts in maybe (str " ") (drawWithNeighbors neighbors) $ allEnts ^? atPosition pos . folded @@ -73,7 +71,12 @@ drawMap game = viewport Resource.MapViewport Both . showCursor Resource.Character (game ^. characterPosition . loc) $ drawEntities - (game ^. revealedPositions) + (\pos -> + (game ^. debugState . allRevealed) + || (pos `member` (game ^. revealedPositions))) + -- FIXME: this will break down as soon as creatures can walk around on their + -- own, since we don't want to render things walking around when the + -- character can't see them (game ^. entities) drawGame :: GameState -> [Widget Name] diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 9b81abe35247..00785bf12440 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -32,6 +32,11 @@ module Xanthous.Game.State , downcastEntity , _SomeEntity , entityIs + + -- * Debug State + , DebugState(..) + , debugState + , allRevealed ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -158,10 +163,10 @@ instance Entity SomeEntity where blocksVision (SomeEntity ent) = blocksVision ent description (SomeEntity ent) = description ent -downcastEntity :: forall a. (Entity a, Typeable a) => SomeEntity -> Maybe a +downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a downcastEntity (SomeEntity e) = cast e -entityIs :: forall a. (Entity a, Typeable a) => SomeEntity -> Bool +entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool entityIs = isJust . downcastEntity @a _SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a @@ -169,6 +174,15 @@ _SomeEntity = prism' SomeEntity downcastEntity -------------------------------------------------------------------------------- +data DebugState = DebugState + { _allRevealed :: !Bool + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + +instance Arbitrary DebugState where + arbitrary = genericArbitrary + data GameState = GameState { _entities :: !(EntityMap SomeEntity) , _revealedPositions :: !(Set Position) @@ -176,6 +190,7 @@ data GameState = GameState , _messageHistory :: !MessageHistory , _randomGen :: !StdGen , _promptState :: !(GamePromptState AppM) + , _debugState :: DebugState } deriving stock (Show) makeLenses ''GameState @@ -198,3 +213,7 @@ instance (Monad m) => MonadRandom (AppT m) where getRandom = randomGen %%= random getRandomRs rng = uses randomGen $ randomRs rng getRandoms = uses randomGen randoms + +-------------------------------------------------------------------------------- + +makeLenses ''DebugState |