about summary refs log tree commit diff
path: root/src/Xanthous/Game/Draw.hs
blob: 8a86101d9915bbe08dc67d7f7b5f68f476f12566 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
--------------------------------------------------------------------------------
module Xanthous.Game.Draw
  ( drawGame
  ) where
--------------------------------------------------------------------------------
import           Xanthous.Prelude
import           Brick hiding (loc, on)
import           Brick.Widgets.Border
import           Brick.Widgets.Border.Style
import           Brick.Widgets.Edit
--------------------------------------------------------------------------------
import           Xanthous.Data
import           Xanthous.Data.EntityMap (EntityMap, atPosition)
import qualified Xanthous.Data.EntityMap as EntityMap
import           Xanthous.Game.State
import           Xanthous.Entities.Character
import           Xanthous.Entities.Item (Item)
import           Xanthous.Game
                 ( GameState(..)
                 , entities
                 , revealedPositions
                 , characterPosition
                 , characterVisiblePositions
                 , character
                 , MessageHistory(..)
                 , messageHistory
                 , GamePromptState(..)
                 , promptState
                 , debugState, allRevealed
                 )
import           Xanthous.Game.Prompt
import           Xanthous.Resource (Name, Panel(..))
import qualified Xanthous.Resource as Resource
import           Xanthous.Orphans ()
--------------------------------------------------------------------------------

cursorPosition :: GameState -> Widget Name -> Widget Name
cursorPosition game
  | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _)
    <- game ^. promptState
  = showCursor Resource.Prompt (pos ^. loc)
  | otherwise
  = showCursor Resource.Character (game ^. characterPosition . loc)

drawMessages :: MessageHistory -> Widget Name
drawMessages = txtWrap . (<> " ") . unwords . oextract

drawPromptState :: GamePromptState m -> Widget Name
drawPromptState NoPrompt = emptyWidget
drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
  case (pt, ps, pri) of
    (SStringPrompt, StringPromptState edit, _) ->
      txtWrap msg <+> txt " " <+> renderEditor (txt . fold) True edit
    (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg
    (SContinue, _, _) -> txtWrap msg
    (SMenu, _, menuItems) ->
      txtWrap msg
      <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)
    _ -> txtWrap msg
  where
    drawMenuItem (chr, MenuOption m _) =
      str ("[" <> pure chr <> "] ") <+> txtWrap m

drawEntities
  :: (Position -> Bool)
    -- ^ 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 isVisible isRevealed allEnts
  = vBox rows
  where
    entityPositions = EntityMap.positions allEnts
    maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
    maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
    rows = mkRow <$> [0..maxY]
    mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
    renderEntityAt 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)
           $ 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)))
    (`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
    (game ^. entities)

bullet :: Char
bullet = '•'

drawInventoryPanel :: GameState -> Widget Name
drawInventoryPanel game
  =   drawWielded  (game ^. character . inventory . wielded)
  <=> drawBackpack (game ^. character . inventory . backpack)
  where
    drawWielded (Hands Nothing Nothing) = emptyWidget
    drawWielded (DoubleHanded i) =
      txtWrap $ "You are holding " <> description i <> " in both hands"
    drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r
    drawHand side = maybe emptyWidget $ \i ->
      txtWrap ( "You are holding "
              <> description i
              <> " in your " <> side <> " hand"
              )
      <=> txt " "

    drawBackpack :: Vector Item -> Widget Name
    drawBackpack Empty = txtWrap "Your backpack is empty right now."
    drawBackpack backpackItems
      = txtWrap ( "You are currently carrying the following items in your "
                <> "backpack:")
        <=> txt " "
        <=> foldl' (<=>) emptyWidget
            (map
              (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
    charName | Just n <- ch ^. characterName
             = txt $ n <> " "
             | otherwise
             = emptyWidget
    charHitpoints
        = txt "Hitpoints: "
      <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)

drawGame :: GameState -> [Widget Name]
drawGame game
  = pure
  . withBorderStyle unicode
  $ case game ^. promptState of
       NoPrompt -> drawMessages (game ^. messageHistory)
       _ -> emptyWidget
  <=> drawPromptState (game ^. promptState)
  <=>
  (maybe emptyWidget (drawPanel game) (game ^. activePanel)
  <+> border (drawMap game)
  )
  <=> drawCharacterInfo (game ^. character)