diff options
| -rw-r--r-- | src/Xanthous/AI/Gormlak.hs | 5 | ||||
| -rw-r--r-- | src/Xanthous/Game.hs | 1 | ||||
| -rw-r--r-- | src/Xanthous/Game/Draw.hs | 53 | ||||
| -rw-r--r-- | src/Xanthous/Game/Lenses.hs | 13 | ||||
| -rw-r--r-- | src/Xanthous/Game/State.hs | 3 |
5 files changed, 49 insertions, 26 deletions
diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs index 8b30bc2c9de0..3e950f67f364 100644 --- a/src/Xanthous/AI/Gormlak.hs +++ b/src/Xanthous/AI/Gormlak.hs @@ -90,10 +90,13 @@ newtype GormlakBrain = GormlakBrain Creature instance Brain GormlakBrain where step ticks = fmap coerce . stepGormlak ticks . coerce + entityCanMove = const True -------------------------------------------------------------------------------- -instance Brain Creature where step = brainVia GormlakBrain +instance Brain Creature where + step = brainVia GormlakBrain + entityCanMove = const True instance Entity Creature where blocksVision _ = False diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index 14b8230218ab..094858618dbf 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -14,6 +14,7 @@ module Xanthous.Game , character , characterPosition , updateCharacterVision + , characterVisiblePositions -- * Messages , MessageHistory(..) diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index d98b48c02742..8a86101d9915 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -20,6 +20,7 @@ import Xanthous.Game , entities , revealedPositions , characterPosition + , characterVisiblePositions , character , MessageHistory(..) , messageHistory @@ -62,10 +63,12 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = drawEntities :: (Position -> Bool) - -- ^ Can we render a given position? + -- ^ Is a given position directly visible to the character? + -> (Position -> Bool) + -- ^ Has a given position *ever* been seen by the character? -> EntityMap SomeEntity -- ^ all entities -> Widget Name -drawEntities canRenderPos allEnts +drawEntities isVisible isRevealed allEnts = vBox rows where entityPositions = EntityMap.positions allEnts @@ -74,23 +77,27 @@ drawEntities canRenderPos allEnts rows = mkRow <$> [0..maxY] mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] renderEntityAt pos - | canRenderPos pos + = let entitiesAtPosition = allEnts ^. atPosition pos + immobileEntitiesAtPosition = + filter (not . entityCanMove) entitiesAtPosition + in renderTopEntity pos + $ if | isVisible pos -> entitiesAtPosition + | isRevealed pos -> immobileEntitiesAtPosition + | otherwise -> mempty + renderTopEntity pos ents = let neighbors = EntityMap.neighbors pos allEnts in maybe (str " ") (drawWithNeighbors neighbors) - $ maximumByOf - (atPosition pos . folded) - (compare `on` drawPriority) - allEnts - | otherwise = str " " + $ maximumBy (compare `on` drawPriority) + <$> fromNullable ents drawMap :: GameState -> Widget Name drawMap game = viewport Resource.MapViewport Both . cursorPosition game $ drawEntities - (\pos -> - (game ^. debugState . allRevealed) - || (pos `member` (game ^. revealedPositions))) + (\pos -> (game ^. debugState . allRevealed) + || (pos `member` (game ^. revealedPositions))) + (`member` characterVisiblePositions game) -- 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 @@ -99,17 +106,11 @@ drawMap game bullet :: Char bullet = '•' -drawPanel :: GameState -> Panel -> Widget Name -drawPanel game panel - = border - . hLimit 35 - . viewport (Resource.Panel panel) Vertical - $ case panel of - InventoryPanel -> - drawWielded (game ^. character . inventory . wielded) - <=> drawBackpack (game ^. character . inventory . backpack) +drawInventoryPanel :: GameState -> Widget Name +drawInventoryPanel game + = drawWielded (game ^. character . inventory . wielded) + <=> drawBackpack (game ^. character . inventory . backpack) where - drawWielded :: Wielded -> Widget Name drawWielded (Hands Nothing Nothing) = emptyWidget drawWielded (DoubleHanded i) = txtWrap $ "You are holding " <> description i <> " in both hands" @@ -132,6 +133,16 @@ drawPanel game panel (txtWrap . ((bullet <| " ") <>) . description) backpackItems) + +drawPanel :: GameState -> Panel -> Widget Name +drawPanel game panel + = border + . hLimit 35 + . viewport (Resource.Panel panel) Vertical + . case panel of + InventoryPanel -> drawInventoryPanel + $ game + drawCharacterInfo :: Character -> Widget Name drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints where diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index 853f758385b1..4a080f85f017 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -5,6 +5,7 @@ module Xanthous.Game.Lenses , character , characterPosition , updateCharacterVision + , characterVisiblePositions , getInitialState , initialStateFromSeed @@ -84,12 +85,16 @@ characterPosition = positionedCharacter . position visionRadius :: Word visionRadius = 12 -- TODO make this dynamic --- | Update the revealed entities at the character's position based on their vision +-- | Update the revealed entities at the character's position based on their +-- vision updateCharacterVision :: GameState -> GameState -updateCharacterVision game = +updateCharacterVision game + = game & revealedPositions <>~ characterVisiblePositions game + +characterVisiblePositions :: GameState -> Set Position +characterVisiblePositions game = let charPos = game ^. characterPosition - visible = visiblePositions charPos visionRadius $ game ^. entities - in game & revealedPositions <>~ visible + in visiblePositions charPos visionRadius $ game ^. entities data Collision = Stop diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 0ba7b2744a80..853d0b6922d1 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -287,6 +287,8 @@ instance class Brain a where step :: Ticks -> Positioned a -> AppM (Positioned a) + entityCanMove :: a -> Bool + entityCanMove = const False newtype Brainless a = Brainless a @@ -429,6 +431,7 @@ instance Eq GameState where , gs ^. messageHistory , gs ^. sentWelcome , gs ^. activePanel + , gs ^. debugState ) -------------------------------------------------------------------------------- |