snix/users/grfn/xanthous/src/Xanthous/Game/Draw.hs

--------------------------------------------------------------------------------
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)