Add the beginnings of a prompt system
Add the beginnings of a generic prompt system, with exclusive support atm for string prompts, and test it out by asking the character for their name at startup
This commit is contained in:
Griffin Smith
parent
62a2e05ef2
commit
7770ed0548
12 changed files with 312 additions and 96 deletions
|
|
@ -4,11 +4,13 @@ module Xanthous.App (makeApp) where
|
|||
import Xanthous.Prelude
|
||||
import Brick hiding (App, halt, continue, raw)
|
||||
import qualified Brick
|
||||
import Brick.Widgets.Edit (handleEditorEvent)
|
||||
import Graphics.Vty.Attributes (defAttr)
|
||||
import Graphics.Vty.Input.Events (Event(EvKey))
|
||||
import Control.Monad.State (get)
|
||||
import Graphics.Vty.Input.Events (Event(EvKey), Key(..))
|
||||
import Control.Monad.State (get, state, StateT(..))
|
||||
import Data.Coerce
|
||||
import Control.Monad.State.Class (modify)
|
||||
import Data.Aeson (object)
|
||||
import Data.Aeson (object, ToJSON)
|
||||
import qualified Data.Aeson as A
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Command
|
||||
|
|
@ -20,14 +22,13 @@ import Xanthous.Data
|
|||
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||
import Xanthous.Game
|
||||
import Xanthous.Game.Draw (drawGame)
|
||||
import Xanthous.Game.Prompt
|
||||
import Xanthous.Monad
|
||||
import Xanthous.Resource (Name)
|
||||
import Xanthous.Messages (message)
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Entities.Creature (Creature)
|
||||
import qualified Xanthous.Entities.Creature as Creature
|
||||
import qualified Xanthous.Entities.Character as Character
|
||||
import Xanthous.Entities.RawTypes (EntityRaw(..))
|
||||
import Xanthous.Entities.Raws (raw)
|
||||
import Xanthous.Entities.Character (characterName)
|
||||
import Xanthous.Entities
|
||||
import Xanthous.Entities.Item (Item)
|
||||
import Xanthous.Generators
|
||||
|
|
@ -41,7 +42,7 @@ makeApp :: IO App
|
|||
makeApp = pure $ Brick.App
|
||||
{ appDraw = drawGame
|
||||
, appChooseCursor = const headMay
|
||||
, appHandleEvent = \state event -> runAppM (handleEvent event) state
|
||||
, appHandleEvent = \game event -> runAppM (handleEvent event) game
|
||||
, appStartEvent = runAppM $ startEvent >> get
|
||||
, appAttrMap = const $ attrMap defAttr []
|
||||
}
|
||||
|
|
@ -49,14 +50,13 @@ makeApp = pure $ Brick.App
|
|||
runAppM :: AppM a -> GameState -> EventM Name a
|
||||
runAppM appm = fmap fst . runAppT appm
|
||||
|
||||
testGormlak :: Creature
|
||||
testGormlak =
|
||||
let Just (Creature gormlak) = raw "gormlak"
|
||||
in Creature.newWithType gormlak
|
||||
-- testGormlak :: Creature
|
||||
-- testGormlak =
|
||||
-- let Just (Creature gormlak) = raw "gormlak"
|
||||
-- in Creature.newWithType gormlak
|
||||
|
||||
startEvent :: AppM ()
|
||||
startEvent = do
|
||||
say_ ["welcome"]
|
||||
level <-
|
||||
generateLevel SCaveAutomata CaveAutomata.defaultParams
|
||||
$ Dimensions 80 80
|
||||
|
|
@ -64,15 +64,23 @@ startEvent = do
|
|||
entities <>= (SomeEntity <$> level ^. levelItems)
|
||||
characterPosition .= level ^. levelCharacterPosition
|
||||
modify updateCharacterVision
|
||||
-- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
|
||||
|
||||
prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable
|
||||
$ \(StringResult s) -> do
|
||||
character . characterName ?= s
|
||||
say ["welcome"] =<< use character
|
||||
|
||||
handleEvent :: BrickEvent Name () -> AppM (Next GameState)
|
||||
handleEvent (VtyEvent (EvKey k mods))
|
||||
handleEvent ev = use promptState >>= \case
|
||||
NoPrompt -> handleNoPromptEvent ev
|
||||
WaitingPrompt msg pr -> handlePromptEvent msg pr ev
|
||||
|
||||
|
||||
handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState)
|
||||
handleNoPromptEvent (VtyEvent (EvKey k mods))
|
||||
| Just command <- commandFromKey k mods
|
||||
= do messageHistory %= hideMessage
|
||||
handleCommand command
|
||||
handleEvent _ = continue
|
||||
handleNoPromptEvent _ = continue
|
||||
|
||||
handleCommand :: Command -> AppM (Next GameState)
|
||||
handleCommand Quit = halt
|
||||
|
|
@ -106,3 +114,48 @@ handleCommand PreviousMessage = do
|
|||
messageHistory %= popMessage
|
||||
continue
|
||||
|
||||
handlePromptEvent
|
||||
:: Text -- ^ Prompt message
|
||||
-> Prompt (AppT Identity)
|
||||
-> BrickEvent Name ()
|
||||
-> AppM (Next GameState)
|
||||
handlePromptEvent _ (Prompt Cancellable _ _ _) (VtyEvent (EvKey KEsc [])) = do
|
||||
promptState .= NoPrompt
|
||||
continue
|
||||
handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) = do
|
||||
() <- state . coerce $ submitPrompt pr
|
||||
promptState .= NoPrompt
|
||||
continue
|
||||
handlePromptEvent
|
||||
msg
|
||||
(Prompt c SStringPrompt (StringPromptState edit) cb)
|
||||
(VtyEvent ev)
|
||||
= do
|
||||
edit' <- lift $ handleEditorEvent ev edit
|
||||
let prompt' = Prompt c SStringPrompt (StringPromptState edit') cb
|
||||
promptState .= WaitingPrompt msg prompt'
|
||||
continue
|
||||
handlePromptEvent _ _ _ = undefined
|
||||
|
||||
prompt
|
||||
:: forall (pt :: PromptType) (params :: Type).
|
||||
(ToJSON params, SingPromptType pt)
|
||||
=> [Text] -- ^ Message key
|
||||
-> params -- ^ Message params
|
||||
-> PromptCancellable
|
||||
-> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler
|
||||
-> AppM ()
|
||||
prompt msgPath params cancellable cb = do
|
||||
let pt = singPromptType @pt
|
||||
msg <- message msgPath params
|
||||
let p = mkPrompt cancellable pt cb
|
||||
promptState .= WaitingPrompt msg p
|
||||
|
||||
prompt_
|
||||
:: forall (pt :: PromptType) .
|
||||
(SingPromptType pt)
|
||||
=> [Text] -- ^ Message key
|
||||
-> PromptCancellable
|
||||
-> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler
|
||||
-> AppM ()
|
||||
prompt_ msg = prompt msg $ object []
|
||||
|
|
|
|||
|
|
@ -23,7 +23,10 @@ module Xanthous.Data.EntityMap
|
|||
, neighbors
|
||||
, Deduplicate(..)
|
||||
|
||||
-- * Querying an entityMap
|
||||
-- * debug
|
||||
, byID
|
||||
, byPosition
|
||||
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude hiding (lookup)
|
||||
|
|
@ -31,7 +34,6 @@ import Xanthous.Data
|
|||
( Position
|
||||
, Positioned(..)
|
||||
, positioned
|
||||
, position
|
||||
, Neighbors(..)
|
||||
, neighborPositions
|
||||
)
|
||||
|
|
@ -81,12 +83,12 @@ instance At (EntityMap a) where
|
|||
pure $ m
|
||||
& removeEIDAtPos pos
|
||||
& byID . at eid .~ Nothing
|
||||
setter m (Just (Positioned pos e)) =
|
||||
case lookupWithPosition eid m of
|
||||
Nothing -> insertAt pos e m
|
||||
Just (Positioned origPos _) -> m
|
||||
& removeEIDAtPos origPos
|
||||
& byID . ix eid . position .~ pos
|
||||
setter m (Just pe@(Positioned pos _)) = m
|
||||
& (case lookupWithPosition eid m of
|
||||
Nothing -> id
|
||||
Just (Positioned origPos _) -> removeEIDAtPos origPos
|
||||
)
|
||||
& byID . at eid ?~ pe
|
||||
& byPosition . at pos %~ \case
|
||||
Nothing -> Just $ ncons eid mempty
|
||||
Just es -> Just $ eid <| es
|
||||
|
|
@ -117,9 +119,6 @@ instance Semigroup (Deduplicate a) where
|
|||
_lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
|
||||
in Deduplicate EntityMap{..}
|
||||
|
||||
instance Monoid (Deduplicate a) where
|
||||
mempty = Deduplicate emptyEntityMap
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Xanthous.Entities.Character
|
||||
( Character(..)
|
||||
, characterName
|
||||
, inventory
|
||||
, mkCharacter
|
||||
, pickUpItem
|
||||
) where
|
||||
|
|
@ -10,6 +12,8 @@ import Test.QuickCheck
|
|||
import Test.QuickCheck.Instances.Vector ()
|
||||
import Test.QuickCheck.Arbitrary.Generic
|
||||
import Brick
|
||||
import Data.Aeson.Generic.DerivingVia
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Entities
|
||||
import Xanthous.Entities.Item
|
||||
|
|
@ -17,9 +21,13 @@ import Xanthous.Entities.Item
|
|||
|
||||
data Character = Character
|
||||
{ _inventory :: !(Vector Item)
|
||||
, _characterName :: !(Maybe Text)
|
||||
}
|
||||
deriving stock (Show, Eq, Generic)
|
||||
deriving anyclass (CoArbitrary, Function)
|
||||
deriving (ToJSON, FromJSON)
|
||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||
Character
|
||||
makeLenses ''Character
|
||||
|
||||
scrollOffset :: Int
|
||||
|
|
@ -40,6 +48,7 @@ instance Arbitrary Character where
|
|||
mkCharacter :: Character
|
||||
mkCharacter = Character
|
||||
{ _inventory = mempty
|
||||
, _characterName = Nothing
|
||||
}
|
||||
|
||||
pickUpItem :: Item -> Character -> Character
|
||||
|
|
|
|||
|
|
@ -8,6 +8,8 @@ module Xanthous.Game
|
|||
, revealedPositions
|
||||
, messageHistory
|
||||
, randomGen
|
||||
, promptState
|
||||
, GamePromptState(..)
|
||||
|
||||
, getInitialState
|
||||
|
||||
|
|
@ -24,6 +26,9 @@ module Xanthous.Game
|
|||
-- * collisions
|
||||
, Collision(..)
|
||||
, collisionAt
|
||||
|
||||
-- * App monad
|
||||
, AppT(..)
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
|
|
@ -34,6 +39,8 @@ import System.Random
|
|||
import Test.QuickCheck
|
||||
import Test.QuickCheck.Arbitrary.Generic
|
||||
import Control.Monad.State.Class
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Random.Class
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Data.EntityMap (EntityMap, EntityID)
|
||||
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||
|
|
@ -45,6 +52,7 @@ import Xanthous.Entities.Creature
|
|||
import Xanthous.Entities.Item
|
||||
import Xanthous.Entities.Arbitrary ()
|
||||
import Xanthous.Orphans ()
|
||||
import Xanthous.Game.Prompt
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data MessageHistory
|
||||
|
|
@ -70,12 +78,33 @@ hideMessage :: MessageHistory -> MessageHistory
|
|||
hideMessage NoMessageHistory = NoMessageHistory
|
||||
hideMessage (MessageHistory msgs _) = MessageHistory msgs False
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data GamePromptState m where
|
||||
NoPrompt :: GamePromptState m
|
||||
WaitingPrompt :: Text -> Prompt m -> GamePromptState m
|
||||
deriving stock (Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype AppT m a
|
||||
= AppT { unAppT :: StateT GameState m a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadState GameState
|
||||
)
|
||||
via (StateT GameState m)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data GameState = GameState
|
||||
{ _entities :: !(EntityMap SomeEntity)
|
||||
, _revealedPositions :: !(Set Position)
|
||||
, _characterEntityID :: !EntityID
|
||||
, _messageHistory :: !MessageHistory
|
||||
, _randomGen :: !StdGen
|
||||
, _promptState :: !(GamePromptState (AppT Identity))
|
||||
}
|
||||
deriving stock (Show)
|
||||
makeLenses ''GameState
|
||||
|
|
@ -88,6 +117,7 @@ instance Eq GameState where
|
|||
, gs ^. messageHistory
|
||||
)
|
||||
|
||||
|
||||
instance Arbitrary GameState where
|
||||
arbitrary = do
|
||||
char <- arbitrary @Character
|
||||
|
|
@ -97,8 +127,10 @@ instance Arbitrary GameState where
|
|||
EntityMap.insertAtReturningID charPos (SomeEntity char)
|
||||
_revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
|
||||
_randomGen <- mkStdGen <$> arbitrary
|
||||
let _promptState = NoPrompt -- TODO
|
||||
pure $ GameState {..}
|
||||
|
||||
|
||||
getInitialState :: IO GameState
|
||||
getInitialState = do
|
||||
_randomGen <- getStdGen
|
||||
|
|
@ -110,6 +142,7 @@ getInitialState = do
|
|||
mempty
|
||||
_messageHistory = NoMessageHistory
|
||||
_revealedPositions = mempty
|
||||
_promptState = NoPrompt
|
||||
pure GameState {..}
|
||||
|
||||
positionedCharacter :: Lens' GameState (Positioned Character)
|
||||
|
|
@ -166,3 +199,14 @@ collisionAt pos = do
|
|||
| any (entityIs @Creature) ents -> pure Combat
|
||||
| all (entityIs @Item) ents -> Nothing
|
||||
| otherwise -> pure Stop
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
instance MonadTrans AppT where
|
||||
lift = AppT . lift
|
||||
|
||||
instance (Monad m) => MonadRandom (AppT m) where
|
||||
getRandomR rng = randomGen %%= randomR rng
|
||||
getRandom = randomGen %%= random
|
||||
getRandomRs rng = uses randomGen $ randomRs rng
|
||||
getRandoms = uses randomGen randoms
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Game.Draw
|
||||
( drawGame
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
import Brick hiding (loc)
|
||||
import Brick.Widgets.Border
|
||||
import Brick.Widgets.Border.Style
|
||||
import Brick.Widgets.Edit
|
||||
import Data.List.NonEmpty(NonEmpty((:|)))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Data (Position(Position), x, y, loc)
|
||||
import Xanthous.Data.EntityMap (EntityMap, atPosition)
|
||||
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||
|
|
@ -21,20 +21,27 @@ import Xanthous.Game
|
|||
, characterPosition
|
||||
, MessageHistory(..)
|
||||
, messageHistory
|
||||
, GamePromptState(..)
|
||||
, promptState
|
||||
)
|
||||
import Xanthous.Resource (Name(..))
|
||||
import Xanthous.Game.Prompt
|
||||
import Xanthous.Resource (Name)
|
||||
import qualified Xanthous.Resource as Resource
|
||||
import Xanthous.Orphans ()
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
drawMessages :: MessageHistory -> Widget Name
|
||||
drawMessages NoMessageHistory = emptyWidget
|
||||
drawMessages (MessageHistory _ False) = emptyWidget
|
||||
drawMessages (MessageHistory _ False) = str " "
|
||||
drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
|
||||
|
||||
-- an attempt to still take up a row even when no messages
|
||||
-- drawMessages msgs = vLimit 1 . Widget Greedy Fixed . render $ case msgs of
|
||||
-- NoMessageHistory -> padTop (Pad 2) $ str " "
|
||||
-- (MessageHistory _ False) -> padTop (Pad 2) $ str " "
|
||||
-- (MessageHistory (lastMessage :| _) True) -> txt lastMessage
|
||||
drawPromptState :: GamePromptState m -> Widget Name
|
||||
drawPromptState NoPrompt = emptyWidget
|
||||
drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) =
|
||||
case (pt, ps) of
|
||||
(SStringPrompt, StringPromptState edit) ->
|
||||
txt msg <+> renderEditor (txt . fold) True edit
|
||||
_ -> undefined
|
||||
|
||||
drawEntities
|
||||
:: Set Position
|
||||
|
|
@ -61,8 +68,8 @@ drawEntities visiblePositions allEnts
|
|||
|
||||
drawMap :: GameState -> Widget Name
|
||||
drawMap game
|
||||
= viewport MapViewport Both
|
||||
. showCursor Character (game ^. characterPosition . loc)
|
||||
= viewport Resource.MapViewport Both
|
||||
. showCursor Resource.Character (game ^. characterPosition . loc)
|
||||
$ drawEntities
|
||||
(game ^. revealedPositions)
|
||||
(game ^. entities)
|
||||
|
|
@ -72,4 +79,5 @@ drawGame game
|
|||
= pure
|
||||
. withBorderStyle unicode
|
||||
$ drawMessages (game ^. messageHistory)
|
||||
<=> drawPromptState (game ^. promptState)
|
||||
<=> border (drawMap game)
|
||||
|
|
|
|||
117
src/Xanthous/Game/Prompt.hs
Normal file
117
src/Xanthous/Game/Prompt.hs
Normal file
|
|
@ -0,0 +1,117 @@
|
|||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Game.Prompt
|
||||
( PromptType(..)
|
||||
, SPromptType(..)
|
||||
, SingPromptType(..)
|
||||
, PromptCancellable(..)
|
||||
, PromptResult(..)
|
||||
, PromptState(..)
|
||||
, Prompt(..)
|
||||
, mkPrompt
|
||||
, isCancellable
|
||||
, submitPrompt
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
import Brick.Widgets.Edit (Editor, editorText, getEditContents)
|
||||
import Test.QuickCheck
|
||||
import Test.QuickCheck.Arbitrary.Generic
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Data (Direction, Position)
|
||||
import Xanthous.Resource (Name)
|
||||
import qualified Xanthous.Resource as Resource
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data PromptType where
|
||||
StringPrompt :: PromptType
|
||||
Confirm :: PromptType
|
||||
Menu :: Type -> PromptType
|
||||
DirectionPrompt :: PromptType
|
||||
PointOnMap :: PromptType
|
||||
deriving stock (Generic)
|
||||
|
||||
instance Show PromptType where
|
||||
show StringPrompt = "StringPrompt"
|
||||
show Confirm = "Confirm"
|
||||
show (Menu _) = "Menu"
|
||||
show DirectionPrompt = "DirectionPrompt"
|
||||
show PointOnMap = "PointOnMap"
|
||||
|
||||
data SPromptType :: PromptType -> Type where
|
||||
SStringPrompt :: SPromptType 'StringPrompt
|
||||
SConfirm :: SPromptType 'Confirm
|
||||
SMenu :: forall a. SPromptType ('Menu a)
|
||||
SDirectionPrompt :: SPromptType 'DirectionPrompt
|
||||
SPointOnMap :: SPromptType 'PointOnMap
|
||||
|
||||
class SingPromptType pt where singPromptType :: SPromptType pt
|
||||
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
|
||||
|
||||
instance Show (SPromptType pt) where
|
||||
show SStringPrompt = "SStringPrompt"
|
||||
show SConfirm = "SConfirm"
|
||||
show SMenu = "SMenu"
|
||||
show SDirectionPrompt = "SDirectionPrompt"
|
||||
show SPointOnMap = "SPointOnMap"
|
||||
|
||||
data PromptCancellable
|
||||
= Cancellable
|
||||
| Uncancellable
|
||||
deriving stock (Show, Eq, Ord, Enum, Generic)
|
||||
deriving anyclass (NFData, CoArbitrary, Function)
|
||||
|
||||
instance Arbitrary PromptCancellable where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
data PromptResult (pt :: PromptType) where
|
||||
StringResult :: Text -> PromptResult 'StringPrompt
|
||||
ConfirmResult :: Bool -> PromptResult 'Confirm
|
||||
MenuResult :: forall a. a -> PromptResult ('Menu a)
|
||||
DirectionResult :: Direction -> PromptResult 'DirectionPrompt
|
||||
PointOnMapResult :: Position -> PromptResult 'PointOnMap
|
||||
|
||||
data PromptState pt where
|
||||
StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
|
||||
|
||||
deriving stock instance Show (PromptState pt)
|
||||
|
||||
data Prompt (m :: Type -> Type) where
|
||||
Prompt
|
||||
:: forall (pt :: PromptType)
|
||||
(m :: Type -> Type).
|
||||
PromptCancellable
|
||||
-> SPromptType pt
|
||||
-> PromptState pt
|
||||
-> (PromptResult pt -> m ())
|
||||
-> Prompt m
|
||||
|
||||
instance Show (Prompt m) where
|
||||
show (Prompt c pt ps _)
|
||||
= "(Prompt "
|
||||
<> show c <> " "
|
||||
<> show pt <> " "
|
||||
<> show ps
|
||||
<> " <function> )"
|
||||
|
||||
mkPrompt :: PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
|
||||
mkPrompt c pt@SStringPrompt cb =
|
||||
let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
|
||||
in Prompt c pt ps cb
|
||||
mkPrompt _ _ _ = undefined
|
||||
|
||||
isCancellable :: Prompt m -> Bool
|
||||
isCancellable (Prompt Cancellable _ _ _) = True
|
||||
isCancellable (Prompt Uncancellable _ _ _) = False
|
||||
|
||||
submitPrompt :: Prompt m -> m ()
|
||||
submitPrompt (Prompt _ pt ps cb) =
|
||||
case (pt, ps) of
|
||||
(SStringPrompt, StringPromptState edit) ->
|
||||
cb . StringResult . mconcat . getEditContents $ edit
|
||||
_ -> undefined
|
||||
|
||||
-- data PromptInput :: PromptType -> Type where
|
||||
-- StringInput :: PromptInput 'StringPrompt
|
||||
|
|
@ -17,24 +17,6 @@ import Data.Aeson
|
|||
import Xanthous.Game
|
||||
import Xanthous.Messages (message)
|
||||
|
||||
newtype AppT m a
|
||||
= AppT { unAppT :: StateT GameState m a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadState GameState
|
||||
)
|
||||
via (StateT GameState m)
|
||||
|
||||
instance MonadTrans AppT where
|
||||
lift = AppT . lift
|
||||
|
||||
instance (Monad m) => MonadRandom (AppT m) where
|
||||
getRandomR rng = randomGen %%= randomR rng
|
||||
getRandom = randomGen %%= random
|
||||
getRandomRs rng = uses randomGen $ randomRs rng
|
||||
getRandoms = uses randomGen randoms
|
||||
|
||||
runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState)
|
||||
runAppT appt initialState = flip runStateT initialState . unAppT $ appt
|
||||
|
||||
|
|
@ -44,19 +26,12 @@ halt = lift . Brick.halt =<< get
|
|||
continue :: AppT (EventM n) (Next GameState)
|
||||
continue = lift . Brick.continue =<< get
|
||||
|
||||
-- say :: [Text] -> AppT m ()
|
||||
-- say :: [Text] -> params -> AppT m ()
|
||||
|
||||
class SayR a where
|
||||
say :: [Text] -> a
|
||||
|
||||
instance Monad m => SayR (AppT m ()) where
|
||||
say msgPath = say msgPath $ object []
|
||||
|
||||
instance (Monad m, ToJSON params) => SayR (params -> AppT m ()) where
|
||||
say msgPath params = do
|
||||
say :: (MonadRandom m, ToJSON params, MonadState GameState m)
|
||||
=> [Text] -> params -> m ()
|
||||
say msgPath params = do
|
||||
msg <- message msgPath params
|
||||
messageHistory %= pushMessage msg
|
||||
|
||||
say_ :: Monad m => [Text] -> AppT m ()
|
||||
say_ = say
|
||||
say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m ()
|
||||
say_ msgPath = say msgPath $ object []
|
||||
|
|
|
|||
|
|
@ -10,4 +10,5 @@ data Name = MapViewport
|
|||
-- ^ The character
|
||||
| MessageBox
|
||||
-- ^ The box where we display messages to the user
|
||||
| Prompt
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside?
|
||||
welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside?
|
||||
items:
|
||||
pickUp: You pick up the {{item.itemType.name}}
|
||||
nothingToPickUp: There's nothing here to pick up
|
||||
character:
|
||||
namePrompt: "What's your name? "
|
||||
|
|
|
|||
|
|
@ -15,7 +15,10 @@ test = localOption (QuickCheckTests 20)
|
|||
$ testGroup "Xanthous.Data.EntityMap"
|
||||
[ testBatch $ monoid @(EntityMap Int) mempty
|
||||
, testGroup "Deduplicate"
|
||||
[ testBatch $ monoid @(Deduplicate Int) mempty
|
||||
[ testGroup "Semigroup laws"
|
||||
[ testProperty "associative" $ \(a :: Deduplicate (EntityMap Int)) b c ->
|
||||
a <> (b <> c) === (a <> b) <> c
|
||||
]
|
||||
]
|
||||
, testGroup "Eq laws"
|
||||
[ testProperty "reflexivity" $ \(em :: EntityMap Int) ->
|
||||
|
|
|
|||
|
|
@ -27,4 +27,7 @@ test = testGroup "Xanthous.Game"
|
|||
, testGroup "characterPosition"
|
||||
[ testProperty "lens laws" $ isLens characterPosition
|
||||
]
|
||||
, testGroup "character"
|
||||
[ testProperty "lens laws" $ isLens character
|
||||
]
|
||||
]
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 78a45f3d5eb8c2993c219fd4214f61e9842177fa4d97667aeaedbfe3d0842165
|
||||
-- hash: 40187d0301465905043b8caafec5465e644f711620c9fc1cfc57af4105ebe08c
|
||||
|
||||
name: xanthous
|
||||
version: 0.1.0.0
|
||||
|
|
@ -46,6 +46,7 @@ library
|
|||
Xanthous.Entities.RawTypes
|
||||
Xanthous.Game
|
||||
Xanthous.Game.Draw
|
||||
Xanthous.Game.Prompt
|
||||
Xanthous.Generators
|
||||
Xanthous.Generators.CaveAutomata
|
||||
Xanthous.Generators.LevelContents
|
||||
|
|
@ -118,6 +119,7 @@ executable xanthous
|
|||
Xanthous.Entities.RawTypes
|
||||
Xanthous.Game
|
||||
Xanthous.Game.Draw
|
||||
Xanthous.Game.Prompt
|
||||
Xanthous.Generators
|
||||
Xanthous.Generators.CaveAutomata
|
||||
Xanthous.Generators.LevelContents
|
||||
|
|
|
|||
Loading…
Reference in a new issue