6266c5d32f
Rename my //users directory and all places that refer to glittershark to grfn, including nix references and documentation. This may require some extra attention inside of gerrit's database after it lands to allow me to actually push things. Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933 Tested-by: BuildkiteCI Reviewed-by: tazjin <mail@tazj.in> Reviewed-by: lukegb <lukegb@tvl.fyi> Reviewed-by: glittershark <grfn@gws.fyi>
143 lines
5 KiB
Haskell
143 lines
5 KiB
Haskell
--------------------------------------------------------------------------------
|
|
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.App (ResourceName, Panel(..))
|
|
import qualified Xanthous.Data.App as Resource
|
|
import qualified Xanthous.Data.EntityMap as EntityMap
|
|
import Xanthous.Game.State
|
|
import Xanthous.Entities.Character
|
|
import Xanthous.Entities.Item (Item)
|
|
import Xanthous.Game
|
|
( characterPosition
|
|
, character
|
|
, revealedEntitiesAtPosition
|
|
)
|
|
import Xanthous.Game.Prompt
|
|
import Xanthous.Orphans ()
|
|
--------------------------------------------------------------------------------
|
|
|
|
cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
|
|
cursorPosition game
|
|
| WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState 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, _) ->
|
|
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
|
|
:: GameState
|
|
-> Widget ResourceName
|
|
drawEntities game = vBox rows
|
|
where
|
|
allEnts = game ^. entities
|
|
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
|
|
= renderTopEntity pos $ revealedEntitiesAtPosition pos game
|
|
renderTopEntity pos ents
|
|
= let neighbors = EntityMap.neighbors pos allEnts
|
|
in maybe (str " ") (drawWithNeighbors neighbors)
|
|
$ maximumBy (compare `on` drawPriority)
|
|
<$> fromNullable ents
|
|
|
|
drawMap :: GameState -> Widget ResourceName
|
|
drawMap game
|
|
= viewport Resource.MapViewport Both
|
|
. cursorPosition game
|
|
$ drawEntities game
|
|
|
|
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)
|
|
|
|
|
|
drawPanel :: GameState -> Panel -> Widget ResourceName
|
|
drawPanel game panel
|
|
= border
|
|
. hLimit 35
|
|
. viewport (Resource.Panel panel) Vertical
|
|
. case panel of
|
|
InventoryPanel -> drawInventoryPanel
|
|
$ game
|
|
|
|
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 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)
|