diff options
Diffstat (limited to 'users/aspen/xanthous/src/Xanthous/Game/Draw.hs')
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/Game/Draw.hs | 224 |
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 0000000000..291dfd8b5e --- /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) |