diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Game/Draw.hs')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Draw.hs | 224 |
1 files changed, 0 insertions, 224 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs deleted file mode 100644 index 291dfd8b5e46..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs +++ /dev/null @@ -1,224 +0,0 @@ --------------------------------------------------------------------------------- -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) |