chore(users): grfn -> aspen r/7511

Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>

1 files changed, 224 insertions, 0 deletions

diff --git a/users/aspen/xanthous/src/Xanthous/Game/Draw.hs b/users/aspen/xanthous/src/Xanthous/Game/Draw.hs
new file mode 100644
index 000000000000..291dfd8b5e46
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game/Draw.hs
@@ -0,0 +1,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)