diff options
Diffstat (limited to 'src/Xanthous/Game')
| -rw-r--r-- | src/Xanthous/Game/Draw.hs | 16 | ||||
| -rw-r--r-- | src/Xanthous/Game/Prompt.hs | 32 |
2 files changed, 36 insertions, 12 deletions
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index ffbf30cca864..2f7ccf29f795 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -32,6 +32,14 @@ import qualified Xanthous.Resource as Resource import Xanthous.Orphans () -------------------------------------------------------------------------------- +cursorPosition :: GameState -> Widget Name -> Widget Name +cursorPosition game + | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _) + <- game ^. promptState + = showCursor Resource.Prompt (pos ^. loc) + | otherwise + = showCursor Resource.Character (game ^. characterPosition . loc) + drawMessages :: MessageHistory -> Widget Name drawMessages = txt . (<> " ") . unwords . oextract @@ -46,7 +54,7 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = (SMenu, _, menuItems) -> txt msg <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems) - _ -> undefined + _ -> txt msg where drawMenuItem (chr, MenuOption m _) = str ("[" <> pure chr <> "] ") <+> txt m @@ -77,7 +85,7 @@ drawEntities canRenderPos allEnts drawMap :: GameState -> Widget Name drawMap game = viewport Resource.MapViewport Both - . showCursor Resource.Character (game ^. characterPosition . loc) + . cursorPosition game $ drawEntities (\pos -> (game ^. debugState . allRevealed) @@ -102,7 +110,9 @@ drawGame :: GameState -> [Widget Name] drawGame game = pure . withBorderStyle unicode - $ drawMessages (game ^. messageHistory) + $ case game ^. promptState of + NoPrompt -> drawMessages (game ^. messageHistory) + _ -> emptyWidget <=> drawPromptState (game ^. promptState) <=> border (drawMap game) <=> drawCharacterInfo (game ^. character) diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs index 1154d6db5a4c..6c3629f31055 100644 --- a/src/Xanthous/Game/Prompt.hs +++ b/src/Xanthous/Game/Prompt.hs @@ -15,6 +15,7 @@ module Xanthous.Game.Prompt , Prompt(..) , mkPrompt , mkMenu + , mkPointOnMapPrompt , isCancellable , submitPrompt ) where @@ -67,6 +68,7 @@ instance NFData (SPromptType pt) where class SingPromptType pt where singPromptType :: SPromptType pt instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt +instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap instance SingPromptType 'Continue where singPromptType = SContinue instance Show (SPromptType pt) where @@ -115,16 +117,20 @@ instance Arbitrary (PromptResult 'Continue) where -------------------------------------------------------------------------------- data PromptState pt where - StringPromptState :: Editor Text Name -> PromptState 'StringPrompt - DirectionPromptState :: PromptState 'DirectionPrompt - ContinuePromptState :: PromptState 'Continue - MenuPromptState :: forall a. PromptState ('Menu a) + StringPromptState :: Editor Text Name -> PromptState 'StringPrompt + DirectionPromptState :: PromptState 'DirectionPrompt + ContinuePromptState :: PromptState 'Continue + ConfirmPromptState :: PromptState 'Confirm + MenuPromptState :: forall a. PromptState ('Menu a) + PointOnMapPromptState :: Position -> PromptState 'PointOnMap instance NFData (PromptState pt) where rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` () rnf DirectionPromptState = () rnf ContinuePromptState = () + rnf ConfirmPromptState = () rnf MenuPromptState = () + rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` () instance Arbitrary (PromptState 'StringPrompt) where arbitrary = StringPromptState <$> arbitrary @@ -170,6 +176,7 @@ instance Show (MenuOption a) where type family PromptInput (pt :: PromptType) :: Type where PromptInput ('Menu a) = Map Char (MenuOption a) + PromptInput 'PointOnMap = Position -- Character pos PromptInput _ = () data Prompt (m :: Type -> Type) where @@ -236,7 +243,7 @@ mkPrompt c pt@SStringPrompt cb = in Prompt c pt ps () cb mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb -mkPrompt _ _ _ = undefined +mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb mkMenu :: forall a m. @@ -246,6 +253,13 @@ mkMenu -> Prompt m mkMenu c = Prompt c SMenu MenuPromptState +mkPointOnMapPrompt + :: PromptCancellable + -> Position + -> (PromptResult 'PointOnMap -> m ()) + -> Prompt m +mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos + isCancellable :: Prompt m -> Bool isCancellable (Prompt Cancellable _ _ _ _) = True isCancellable (Prompt Uncancellable _ _ _ _) = False @@ -261,7 +275,7 @@ submitPrompt (Prompt _ pt ps _ cb) = cb ContinueResult (SMenu, MenuPromptState) -> pure () -- Don't use submit with a menu prompt - _ -> undefined - --- data PromptInput :: PromptType -> Type where --- StringInput :: PromptInput 'StringPrompt + (SPointOnMap, PointOnMapPromptState pos) -> + cb $ PointOnMapResult pos + (SConfirm, ConfirmPromptState) -> + cb $ ConfirmResult True |