Re: An interesting monad: "Prompt"

> (This message is a literate haskell file.  Code for the "Prompt" monad is
> preceded by ">"; code for my examples is preceded by "]" and isn't complete,
> but intended for illustration.)
>
> I've been trying to implement a few rules-driven board/card games in Haskell
> and I always run into the ugly problem of "how do I get user input"?
>
> The usual technique is to embed the game in the IO Monad:
>
> ] type Game = IO
> ] -- or
> ] type Game = StateT GameState IO
>
> The problem with this approach is that now arbitrary IO computations are
> expressible as part of a game action, which makes it much harder to
> implement
> things like replay, undo, and especially testing!
>
> The goal was to be able to write code like this:
>
> ] takeTurn :: Player -> Game ()
> ] takeTurn player = do
> ]     piece  <- action (ChoosePiece player)
> ]     attack <- action (ChooseAttack player piece)
> ]     bonusTurn <- executeAttack piece attack
> ]     when bonusTurn $ takeTurn player
>
> but be able to script the code for testing, allow undo, automatically
> be able to save replays, etc.
>
> While thinking about this problem earlier this week, I came up with the
> following solution:
>
> > {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances
>  #-}
> > -- undecidable instances is only needed for the MonadTrans instance below
> >
> > module Prompt where
> > import Control.Monad.Trans
> > import Control.Monad.Identity
>
> > class Monad m => MonadPrompt p m | m -> p where
> >    prompt :: p a -> m a
>
> "prompt" is an action that takes a prompt type and gives you a result.
>
> A simple example:
> ] prompt [1,3,5] :: MonadPrompt [] m => m Int
>
> This prompt would ask for someone to pick a value from the list and return
> it.
> This would be somewhat useful on its own; you could implement a "choose"
> function that picked randomly from a list of options and gave
> non-deterministic (or even exhaustive) testing, but on its own this wouldn't
> be much better than the list monad.
>
> What really made this click for me was that the prompt type could be built
> on a GADT:
>
> ] newtype GamePrompt a = GP (GameState, GameChoice a)
> ] data GameChoice a where
> ]    -- pick a piece to act with
> ]    ChoosePiece :: Player -> GameChoice GamePiece
> ]    -- pick how they should attack
> ]    ChooseAttack :: Player -> GamePiece -> GameChoice AttackType
> ]    -- etc.
>
> Now you can use this type information as part of a "handler" function:
> ] gameIO :: GamePrompt a -> IO a
>  ] gameIO (GP (state, ChoosePiece player)) = getPiece state player
> ] gameIO (GP (state, ChooseAttack player piece)) = attackMenu player piece
> ] -- ...
>
> The neat thing here is that the GADT specializes the type of "IO a" on the
> right hand side.  So, "getPiece state player" has the type "IO GamePiece",
> not
> the general "IO a".  So the GADT is serving as a witness of the type of
> response wanted by the game.
>
> Another neat things is that, you don't need to embed this in the IO monad at
> all; you could instead run a pure computation to do AI, or even use it for
> unit testing!
>
> > -- unit testing example
> > data ScriptElem p where SE :: p a -> a -> ScriptElem p
> > type Script p = [ScriptElem p]
> >
> > infix 1 -->
> > (-->) = SE
>
>
> ] gameScript :: ScriptElem GameChoice -> GameChoice a -> Maybe a
> ] gameScript (SE (ChoosePiece _)    piece)  (ChoosePiece _)    = Just piece
> ] gameScript (SE (ChooseAttack _ _) attack) (ChooseAttack _ _) = Just attack
> ] gameScript _                              _
>    = Nothing
> ]
> ] testGame :: Script GameChoice
> ] testGame =
> ]   [ ChoosePiece  P1        --> Knight
> ]   , ChooseAttack P1 Knight --> Charge
> ]   , ChoosePiece  P2        --> FootSoldier
> ]   , ...
> ]   ]
>
> So, how to implement all of this?
>
> > data Prompt (p :: * -> *) :: (* -> *) where
> >     PromptDone :: result -> Prompt p result
> >     -- a is the type needed to continue the computation
> >     Prompt :: p a -> (a -> Prompt p result) -> Prompt p result
>
> This doesn't require GADT's; it's just using existential types, but I like
> the aesthetics better this way.
>
> Intuitively, a (Prompt p result) either gives you an immediate result
> (PromptDone), or gives you a prompt which you need to reply to in order to
> continue the computation.
>
> This type is a MonadPrompt:
>
> > instance Functor (Prompt p) where
> >    fmap f (PromptDone r) = PromptDone (f r)
> >    fmap f (Prompt p cont) = Prompt p (fmap f . cont)
> >
> > instance Monad (Prompt p) where
> >    return = PromptDone
> >    PromptDone r  >>= f = f r
> >    Prompt p cont >>= f = Prompt p ((>>= f) . cont)
> >
> > instance MonadPrompt p (Prompt p) where
> >    prompt p = Prompt p return
> >
> > -- Just for fun, make it work with StateT as well
> > -- (needs -fallow-undecidable-instances)
> > instance (Monad (t m), MonadTrans t, MonadPrompt p m) => MonadPrompt p (t
> m) where
> >    prompt = lift . prompt
>
> The last bit to tie it together is an observation function which allows you
> to
> run the game:
>
> > runPromptM :: Monad m => (forall a. p a -> m a) -> Prompt p r -> m r
> > runPromptM _ (PromptDone r) = return r
> > runPromptM f (Prompt pa c)  = f pa >>= runPromptM f . c
> >
> > runPrompt :: (forall a. p a -> a) -> Prompt p r -> r
> > runPrompt f p = runIdentity $ runPromptM (Identity . f) p
> >
> > runScript :: (forall a. ScriptElem p -> p a -> Maybe a)
> >               -> Script p -> Prompt p r -> Maybe r
> > runScript _ []     (PromptDone r) = Just r
> > runScript s (x:xs) (Prompt pa c)  = case s x pa of
> >    Nothing -> Nothing
> >    Just a  -> runScript s xs (c a)
> > runScript _ _      _              = Nothing
> >    -- script & computation out of sync
>
> My original goal is now achievable:
>
> ] type Game = StateT GameState (Prompt GamePrompt)
> ]
> ] action :: GameChoice a -> Game a
> ] action p = do
> ]    state <- get
> ]    prompt $ GP (state, p)
>
> ] runGameScript :: Script GameChoice -> GameState -> Game a -> Maybe
> (GameState, a)
> ] runGameScript script initialState game
> ]    = runScript scriptFn script' (runStateT game initialState)
> ]    where
> ]       script' = map sEmbed script
> ]       scriptFn s (GP (s,p)) = gameScript (sExtract s) p
> ]       sEmbed   (SE p a) = SE (GP (undefined, p)) a
> ]       sExtract (SE (GP (_,p)) a) = SE p a
>
> Any comments are welcome!  Thanks for reading this far.
>
>   -- ryan
>
>
> _______________________________________________
> Haskell-Cafe mailing list
> Haskell-Cafe@...
> http://www.haskell.org/mailman/listinfo/haskell-cafe
>
>