about summary refs log tree commit diff
path: root/users/aspen/xanthous/src/Xanthous/Game/Draw.hs
blob: 291dfd8b5e4649d8a5c193651ebe3a554ca47834 (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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
--------------------------------------------------------------------------------
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           Control.Monad.State.Lazy (evalState)
import           Control.Monad.State.Class ( get, MonadState, gets )
--------------------------------------------------------------------------------
import           Xanthous.Data
import           Xanthous.Data.App (ResourceName, Panel(..))
import qualified Xanthous.Data.App as Resource
import qualified Xanthous.Data.EntityMap as EntityMap
import           Xanthous.Game.State
import           Xanthous.Entities.Common (Wielded(..), wielded, backpack)
import           Xanthous.Entities.Character
import           Xanthous.Entities.Item (Item)
import           Xanthous.Game
                 ( characterPosition
                 , character
                 , revealedEntitiesAtPosition
                 )
import           Xanthous.Game.Prompt
import           Xanthous.Orphans ()
import Brick.Widgets.Center (hCenter)
import Xanthous.Command (Keybinding (..), keybindings, Command, commandIsHidden)
import Graphics.Vty.Input.Events (Modifier(..))
import Graphics.Vty.Input (Key(..))
import Brick.Widgets.Table
--------------------------------------------------------------------------------

cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
cursorPosition game
  | WaitingPrompt _ (Prompt _ _ (preview promptStatePosition -> Just pos) _ _)
    <- game ^. promptState
  = showCursor Resource.Prompt (pos ^. loc)
  | otherwise
  = showCursor Resource.Character (game ^. characterPosition . loc)

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

drawPromptState :: GamePromptState m -> Widget ResourceName
drawPromptState NoPrompt = emptyWidget
drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
  case (pt, ps, pri) of
    (SStringPrompt, StringPromptState edit, mDef) ->
      txt msg
      <+> txt (maybe "" (\def -> "(default: " <> def <> ") ") mDef)
      <+> renderEditor (txt . fold) True edit
    (SDirectionPrompt, DirectionPromptState, _) -> 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
  :: forall m. MonadState GameState m
  => m (Widget ResourceName)
drawEntities = do
  allEnts <- use entities
  let entityPositions = EntityMap.positions allEnts
      maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
      maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
      rows = traverse mkRow [0..maxY]
      mkRow rowY = hBox <$> traverse (renderEntityAt . flip Position rowY) [0..maxX]
      renderEntityAt pos
        = renderTopEntity pos <$> revealedEntitiesAtPosition pos
      renderTopEntity pos ents
        = let neighbors = EntityMap.neighbors pos allEnts
          in maybe (str " ") (drawWithNeighbors neighbors)
             $ maximumBy (compare `on` drawPriority)
             <$> fromNullable ents
  vBox <$> rows

drawMap :: MonadState GameState m => m (Widget ResourceName)
drawMap = do
  cursorPos <- gets cursorPosition
  viewport Resource.MapViewport Both . cursorPos <$> drawEntities

bullet :: Char
bullet = '•'

drawInventoryPanel :: GameState -> Widget ResourceName
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 ResourceName
    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)

drawHelpPanel :: Widget ResourceName
drawHelpPanel
  = txtWrap "To move in a direction or attack, use vi keys (hjklyubn):"
  <=> txt " "
  <=> hCenter keyStar
  <=> txt " "
  <=> cmds
  where
    keyStar
      =   txt "y k u"
      <=> txt " \\|/"
      <=> txt "h-.-l"
      <=> txt " /|\\"
      <=> txt "b j n"

    cmds
      = renderTable
      . alignRight 0
      . setDefaultRowAlignment AlignTop
      . surroundingBorder False
      . rowBorders False
      . columnBorders False
      . table $ help <&> \(key, cmd) -> [ txt $ key <> " : "
                                       , hLimitPercent 100 $ txtWrap cmd]

    help =
      extraHelp <>
      keybindings
        ^.. ifolded
          . filtered (not . commandIsHidden)
          . withIndex
          . to (bimap displayKeybinding displayCommand)
    extraHelp
      = [("Shift-Dir", "Auto-move")]

    displayCommand = tshow @Command
    displayKeybinding (Keybinding k mods) = foldMap showMod mods <> showKey k

    showMod MCtrl  = "Ctrl-"
    showMod MShift = "Shift-"
    showMod MAlt   = "Alt-"
    showMod MMeta  = "Meta-"

    showKey (KChar c) = pack [c]
    showKey KEsc = "<Esc>"
    showKey KBS = "<Backspace>"
    showKey KEnter = "<Enter>"
    showKey KLeft = "<Left>"
    showKey KRight = "<Right>"
    showKey KUp = "<Up>"
    showKey KDown = "<Down>"
    showKey KUpLeft = "<UpLeft>"
    showKey KUpRight = "<UpRight>"
    showKey KDownLeft = "<DownLeft>"
    showKey KDownRight = "<DownRight>"
    showKey KCenter = "<Center>"
    showKey (KFun n) = "<F" <> tshow n <> ">"
    showKey KBackTab = "<BackTab>"
    showKey KPrtScr = "<PrtScr>"
    showKey KPause = "<Pause>"
    showKey KIns = "<Ins>"
    showKey KHome = "<Home>"
    showKey KPageUp = "<PageUp>"
    showKey KDel = "<Del>"
    showKey KEnd = "<End>"
    showKey KPageDown = "<PageDown>"
    showKey KBegin = "<Begin>"
    showKey KMenu = "<Menu>"

drawPanel :: GameState -> Panel -> Widget ResourceName
drawPanel game panel
  = border
  . hLimit 35
  . viewport (Resource.Panel panel) Vertical
  $ case panel of
      HelpPanel -> drawHelpPanel
      InventoryPanel -> drawInventoryPanel game
      ItemDescriptionPanel desc -> txtWrap desc

drawCharacterInfo :: Character -> Widget ResourceName
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 ResourceName]
drawGame = evalState $ do
  game <- get
  drawnMap <- drawMap
  pure
    . pure
    . withBorderStyle unicode
    $ case game ^. promptState of
        NoPrompt -> drawMessages (game ^. messageHistory)
        _ -> emptyWidget
    <=> drawPromptState (game ^. promptState)
    <=>
    (maybe emptyWidget (drawPanel game) (game ^. activePanel)
    <+> border drawnMap
    )
    <=> drawCharacterInfo (game ^. character)