diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Game/Prompt.hs')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Prompt.hs | 359 |
1 files changed, 0 insertions, 359 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs deleted file mode 100644 index 2d6c0a280f41..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Prompt - ( PromptType(..) - , SPromptType(..) - , SingPromptType(..) - , PromptCancellable(..) - , PromptResult(..) - , PromptState(..) - , promptStatePosition - , MenuOption(..) - , mkMenuItems - , PromptInput - , Prompt(..) - , mkPrompt - , mkStringPrompt - , mkStringPromptWithDefault - , mkMenu - , mkPointOnMapPrompt - , mkFirePrompt - , 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, AlphaChar (..)) -import Xanthous.Data (Direction, Position, Tiles) -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 - -- | Throw an item or fire a projectile weapon. Prompt is to select the - -- direction - Fire :: 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" - show Fire = "Fire" - -data SPromptType :: PromptType -> Type where - SStringPrompt :: SPromptType 'StringPrompt - SConfirm :: SPromptType 'Confirm - SMenu :: SPromptType ('Menu a) - SDirectionPrompt :: SPromptType 'DirectionPrompt - SPointOnMap :: SPromptType 'PointOnMap - SContinue :: SPromptType 'Continue - SFire :: SPromptType 'Fire - -instance NFData (SPromptType pt) where - rnf SStringPrompt = () - rnf SConfirm = () - rnf SMenu = () - rnf SDirectionPrompt = () - rnf SPointOnMap = () - rnf SContinue = () - rnf SFire = () - -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 SingPromptType 'Fire where singPromptType = SFire - -instance Show (SPromptType pt) where - show SStringPrompt = "SStringPrompt" - show SConfirm = "SConfirm" - show SMenu = "SMenu" - show SDirectionPrompt = "SDirectionPrompt" - show SPointOnMap = "SPointOnMap" - show SContinue = "SContinue" - show SFire = "SFire" - -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 - FireResult :: Position -> PromptResult 'Fire - 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 - -instance Arbitrary (PromptResult 'Fire) where - arbitrary = FireResult <$> arbitrary - --------------------------------------------------------------------------------- - -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 - FirePromptState :: Position -> PromptState 'Fire - -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` () - rnf fps@(FirePromptState pos) = fps `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 Arbitrary (PromptState 'Fire) where - arbitrary = FirePromptState <$> arbitrary - -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 () - -instance CoArbitrary (PromptState 'Fire) where - coarbitrary (FirePromptState pos) = coarbitrary pos - -deriving stock instance Show (PromptState pt) - --- | Traversal over the position for the prompt types with positions in their --- prompt state (currently 'Fire' and 'PointOnMap') -promptStatePosition :: forall pt. Traversal' (PromptState pt) Position -promptStatePosition _ ps@(StringPromptState _) = pure ps -promptStatePosition _ DirectionPromptState = pure DirectionPromptState -promptStatePosition _ ContinuePromptState = pure ContinuePromptState -promptStatePosition _ ConfirmPromptState = pure ConfirmPromptState -promptStatePosition _ MenuPromptState = pure MenuPromptState -promptStatePosition f (PointOnMapPromptState p) = PointOnMapPromptState <$> f p -promptStatePosition f (FirePromptState p) = FirePromptState <$> f p - -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 getAlphaChar . smallestNotIn . map AlphaChar $ 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 'Fire = (Position, Tiles) -- Nearest enemy, range - PromptInput 'StringPrompt = Maybe Text -- Default value - 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) - coarbitrary (Prompt c SFire ps pri cb) = - variant @Int 7 . 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 -- ^ Is the prompt cancellable or not? - -> SPromptType pt -- ^ The type of the prompt - -> (PromptResult pt -> m ()) -- ^ Function to call when the prompt is complete - -> Prompt m -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 - -mkStringPrompt - :: PromptCancellable -- ^ Is the prompt cancellable or not? - -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete - -> Prompt m -mkStringPrompt c = - let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" - in Prompt c SStringPrompt ps Nothing - -mkStringPromptWithDefault - :: PromptCancellable -- ^ Is the prompt cancellable or not? - -> Text -- ^ Default value for the prompt - -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete - -> Prompt m -mkStringPromptWithDefault c def = - let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" - in Prompt c SStringPrompt ps (Just def) - -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 - -mkFirePrompt - :: PromptCancellable - -> Position -- ^ Initial position - -> Tiles -- ^ Range - -> (PromptResult 'Fire -> m ()) - -> Prompt m -mkFirePrompt c pos range = Prompt c SFire (FirePromptState pos) (pos, range) - -isCancellable :: Prompt m -> Bool -isCancellable (Prompt Cancellable _ _ _ _) = True -isCancellable (Prompt Uncancellable _ _ _ _) = False - -submitPrompt :: Applicative m => Prompt m -> m () -submitPrompt (Prompt _ pt ps pri cb) = - case (pt, ps, pri) of - (SStringPrompt, StringPromptState edit, mDef) -> - let inputVal = mconcat . getEditContents $ edit - val | null inputVal, Just def <- mDef = def - | otherwise = inputVal - in cb $ StringResult val - (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 - (SFire, FirePromptState pos, _) -> - cb $ FireResult pos |