34cabba896
Add a very basic, naive auto-move command, which just steps the player in a direction until they collide with something, regardless of any surrounding beasties who might want to eat them. There's a lot of other stuff going on here - in order to get this working the way I wanted with a slight (I settled on 50ms) delay between every step in these autocommands while still redrawing in between I had to do all the extra machinery for custom Brick events with a channel, and then at the same time adding the bits for actually executing autocommands in a general fashion (because there will definitely be more!) hit my threshold for size for App.hs which sent me on a big journey to break it up into smaller files -- which seems actually like it was quite successful. Hopefully this will help with compile times too, though App.hs is still pretty slow (maybe more to do here).
289 lines
9.7 KiB
Haskell
289 lines
9.7 KiB
Haskell
{-# LANGUAGE DeriveFunctor #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
--------------------------------------------------------------------------------
|
|
module Xanthous.Game.Prompt
|
|
( PromptType(..)
|
|
, SPromptType(..)
|
|
, SingPromptType(..)
|
|
, PromptCancellable(..)
|
|
, PromptResult(..)
|
|
, PromptState(..)
|
|
, MenuOption(..)
|
|
, mkMenuItems
|
|
, PromptInput
|
|
, Prompt(..)
|
|
, mkPrompt
|
|
, mkMenu
|
|
, mkPointOnMapPrompt
|
|
, isCancellable
|
|
, submitPrompt
|
|
) where
|
|
--------------------------------------------------------------------------------
|
|
import Xanthous.Prelude
|
|
--------------------------------------------------------------------------------
|
|
import Brick.Widgets.Edit (Editor, editorText, getEditContents)
|
|
import Test.QuickCheck
|
|
import Test.QuickCheck.Arbitrary.Generic
|
|
--------------------------------------------------------------------------------
|
|
import Xanthous.Util (smallestNotIn)
|
|
import Xanthous.Data (Direction, Position)
|
|
import Xanthous.Data.App (ResourceName)
|
|
import qualified Xanthous.Data.App as Resource
|
|
--------------------------------------------------------------------------------
|
|
|
|
data PromptType where
|
|
StringPrompt :: PromptType
|
|
Confirm :: PromptType
|
|
Menu :: Type -> PromptType
|
|
DirectionPrompt :: PromptType
|
|
PointOnMap :: PromptType
|
|
Continue :: PromptType
|
|
deriving stock (Generic)
|
|
|
|
instance Show PromptType where
|
|
show StringPrompt = "StringPrompt"
|
|
show Confirm = "Confirm"
|
|
show (Menu _) = "Menu"
|
|
show DirectionPrompt = "DirectionPrompt"
|
|
show PointOnMap = "PointOnMap"
|
|
show Continue = "Continue"
|
|
|
|
data SPromptType :: PromptType -> Type where
|
|
SStringPrompt :: SPromptType 'StringPrompt
|
|
SConfirm :: SPromptType 'Confirm
|
|
SMenu :: SPromptType ('Menu a)
|
|
SDirectionPrompt :: SPromptType 'DirectionPrompt
|
|
SPointOnMap :: SPromptType 'PointOnMap
|
|
SContinue :: SPromptType 'Continue
|
|
|
|
instance NFData (SPromptType pt) where
|
|
rnf SStringPrompt = ()
|
|
rnf SConfirm = ()
|
|
rnf SMenu = ()
|
|
rnf SDirectionPrompt = ()
|
|
rnf SPointOnMap = ()
|
|
rnf SContinue = ()
|
|
|
|
class SingPromptType pt where singPromptType :: SPromptType pt
|
|
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
|
|
instance SingPromptType 'Confirm where singPromptType = SConfirm
|
|
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
|
|
instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap
|
|
instance SingPromptType 'Continue where singPromptType = SContinue
|
|
|
|
instance Show (SPromptType pt) where
|
|
show SStringPrompt = "SStringPrompt"
|
|
show SConfirm = "SConfirm"
|
|
show SMenu = "SMenu"
|
|
show SDirectionPrompt = "SDirectionPrompt"
|
|
show SPointOnMap = "SPointOnMap"
|
|
show SContinue = "SContinue"
|
|
|
|
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
|
|
ContinueResult :: PromptResult 'Continue
|
|
|
|
instance Arbitrary (PromptResult 'StringPrompt) where
|
|
arbitrary = StringResult <$> arbitrary
|
|
|
|
instance Arbitrary (PromptResult 'Confirm) where
|
|
arbitrary = ConfirmResult <$> arbitrary
|
|
|
|
instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where
|
|
arbitrary = MenuResult <$> arbitrary
|
|
|
|
instance Arbitrary (PromptResult 'DirectionPrompt) where
|
|
arbitrary = DirectionResult <$> arbitrary
|
|
|
|
instance Arbitrary (PromptResult 'PointOnMap) where
|
|
arbitrary = PointOnMapResult <$> arbitrary
|
|
|
|
instance Arbitrary (PromptResult 'Continue) where
|
|
arbitrary = pure ContinueResult
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
data PromptState pt where
|
|
StringPromptState
|
|
:: Editor Text ResourceName -> 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
|
|
|
|
instance Arbitrary (PromptState 'DirectionPrompt) where
|
|
arbitrary = pure DirectionPromptState
|
|
|
|
instance Arbitrary (PromptState 'Continue) where
|
|
arbitrary = pure ContinuePromptState
|
|
|
|
instance Arbitrary (PromptState ('Menu a)) where
|
|
arbitrary = pure MenuPromptState
|
|
|
|
instance CoArbitrary (PromptState 'StringPrompt) where
|
|
coarbitrary (StringPromptState ed) = coarbitrary ed
|
|
|
|
instance CoArbitrary (PromptState 'DirectionPrompt) where
|
|
coarbitrary DirectionPromptState = coarbitrary ()
|
|
|
|
instance CoArbitrary (PromptState 'Continue) where
|
|
coarbitrary ContinuePromptState = coarbitrary ()
|
|
|
|
instance CoArbitrary (PromptState ('Menu a)) where
|
|
coarbitrary MenuPromptState = coarbitrary ()
|
|
|
|
deriving stock instance Show (PromptState pt)
|
|
|
|
data MenuOption a = MenuOption Text a
|
|
deriving stock (Eq, Generic, Functor)
|
|
deriving anyclass (NFData, CoArbitrary, Function)
|
|
|
|
instance Comonad MenuOption where
|
|
extract (MenuOption _ x) = x
|
|
extend cok mo@(MenuOption text _) = MenuOption text (cok mo)
|
|
|
|
mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a))
|
|
=> f
|
|
-> Map Char (MenuOption a)
|
|
mkMenuItems = flip foldl' mempty $ \items (chr, option) ->
|
|
let chr' = if has (ix chr) items
|
|
then smallestNotIn $ keys items
|
|
else chr
|
|
in items & at chr' ?~ option
|
|
|
|
instance Show (MenuOption a) where
|
|
show (MenuOption m _) = show m
|
|
|
|
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
|
|
Prompt
|
|
:: forall (pt :: PromptType)
|
|
(m :: Type -> Type).
|
|
PromptCancellable
|
|
-> SPromptType pt
|
|
-> PromptState pt
|
|
-> PromptInput pt
|
|
-> (PromptResult pt -> m ())
|
|
-> Prompt m
|
|
|
|
instance Show (Prompt m) where
|
|
show (Prompt c pt ps pri _)
|
|
= "(Prompt "
|
|
<> show c <> " "
|
|
<> show pt <> " "
|
|
<> show ps <> " "
|
|
<> showPri
|
|
<> " <function>)"
|
|
where showPri = case pt of
|
|
SMenu -> show pri
|
|
_ -> "()"
|
|
|
|
instance NFData (Prompt m) where
|
|
rnf (Prompt c SMenu ps pri cb)
|
|
= c
|
|
`deepseq` ps
|
|
`deepseq` pri
|
|
`seq` cb
|
|
`seq` ()
|
|
rnf (Prompt c spt ps pri cb)
|
|
= c
|
|
`deepseq` spt
|
|
`deepseq` ps
|
|
`deepseq` pri
|
|
`seq` cb
|
|
`seq` ()
|
|
|
|
instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where
|
|
coarbitrary (Prompt c SStringPrompt ps pri cb) =
|
|
variant @Int 1 . coarbitrary (c, ps, pri, cb)
|
|
coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state
|
|
variant @Int 2 . coarbitrary (c, pri, cb)
|
|
coarbitrary (Prompt c SMenu _ps _pri _cb) =
|
|
variant @Int 3 . coarbitrary c {-, ps, pri, cb -}
|
|
coarbitrary (Prompt c SDirectionPrompt ps pri cb) =
|
|
variant @Int 4 . coarbitrary (c, ps, pri, cb)
|
|
coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state
|
|
variant @Int 5 . coarbitrary (c, pri, cb)
|
|
coarbitrary (Prompt c SContinue ps pri cb) =
|
|
variant @Int 6 . coarbitrary (c, ps, pri, cb)
|
|
|
|
-- instance Function (Prompt m) where
|
|
-- function = functionMap toTuple _fromTuple
|
|
-- where
|
|
-- toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb)
|
|
|
|
|
|
mkPrompt :: (PromptInput pt ~ ()) => 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 c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
|
|
mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
|
|
mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb
|
|
|
|
mkMenu
|
|
:: forall a m.
|
|
PromptCancellable
|
|
-> Map Char (MenuOption a) -- ^ Menu items
|
|
-> (PromptResult ('Menu a) -> m ())
|
|
-> 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
|
|
|
|
submitPrompt :: Applicative m => Prompt m -> m ()
|
|
submitPrompt (Prompt _ pt ps _ cb) =
|
|
case (pt, ps) of
|
|
(SStringPrompt, StringPromptState edit) ->
|
|
cb . StringResult . mconcat . getEditContents $ edit
|
|
(SDirectionPrompt, DirectionPromptState) ->
|
|
pure () -- Don't use submit with a direction prompt
|
|
(SContinue, ContinuePromptState) ->
|
|
cb ContinueResult
|
|
(SMenu, MenuPromptState) ->
|
|
pure () -- Don't use submit with a menu prompt
|
|
(SPointOnMap, PointOnMapPromptState pos) ->
|
|
cb $ PointOnMapResult pos
|
|
(SConfirm, ConfirmPromptState) ->
|
|
cb $ ConfirmResult True
|