A simple guess-a-number game in MonadPrompt 

> {-# LANGUAGE GADTs, RankNTypes #-}
> module Main where
> import Prompt
> import Control.Monad.State
> import Control.Monad.Error
> import System.Random (randomRIO)
> import System.IO
> import Control.Exception (assert)

Minimalist "functional references" implementation.
In particular, for this example, we skip the really interesting thing: composability.

See http://luqui.org/blog/archives/2007/08/05/ for a real implementation.

> data FRef s a = FRef
>   { frGet :: s -> a
>   , frSet :: a -> s -> s
>   }

> fetch :: MonadState s m => FRef s a -> m a
> fetch ref = get >>= return . frGet ref

> infix 1 =:
> infix 1 =<<:
> (=:) :: MonadState s m => FRef s a -> a -> m ()
> ref =: val = modify $ frSet ref val
> (=<<:) :: MonadState s m => FRef s a -> m a -> m ()
> ref =<<: act = act >>= modify . frSet ref
> update :: MonadState s m => FRef s a -> (a -> a) -> m ()
> update ref f = fetch ref >>= \a -> ref =: f a

Interactions that a user can have with the game:

> data GuessP a where
>    GetNumber :: GuessP Int
>    Guess :: GuessP Int
>    Print :: String -> GuessP ()

Game state.

We could do this with a lot less state, but I'm trying to show what's possible here.  In fact, for this example it's probably easier to just thread the state through the program directly, but bigger games want real state, so I'm showing how to do that.

> data GuessS = GuessS
>   { gsNumGuesses_ :: Int
>   , gsTargetNumber_ :: Int
>   }

> -- a real implementation wouldn't do it this way :)
> initialGameState :: GuessS
> initialGameState = GuessS undefined undefined

> gsNumGuesses, gsTargetNumber :: FRef GuessS Int
> gsNumGuesses   = FRef gsNumGuesses_   $ \a s -> s { gsNumGuesses_   = a }
> gsTargetNumber = FRef gsTargetNumber_ $ \a s -> s { gsTargetNumber_ = a }

Game monad with some useful helper functions

> type Game = StateT GuessS (Prompt GuessP)

> gPrint :: String -> Game ()
> gPrint = prompt . Print

> gPrintLn :: String -> Game ()
> gPrintLn s = gPrint (s ++ "\n")

Implementation of the game:

> gameLoop :: Game Int
> gameLoop = do
>    update gsNumGuesses (+1)
>    guessNum <- fetch gsNumGuesses
>    gPrint ("Guess #" ++ show guessNum ++ ":")
>    guess <- prompt Guess
>    answer <- fetch gsTargetNumber
>
>    if guess == answer
>      then do
>        gPrintLn "Right!"
>        return guessNum
>      else do
>        gPrintLn $ concat
>            [ "You guessed too "
>            , if guess < answer then "low" else "high"
>            , "! Try again."
>            ]
>        gameLoop

> game :: Game ()
> game = do
>    gsNumGuesses =: 0
>    gsTargetNumber =<<: prompt GetNumber
>    gPrintLn "I'm thinking of a number.  Try to guess it!"
>    numGuesses <- gameLoop
>    gPrintLn ("It took you " ++ show numGuesses ++ " guesses!")

Simple unwrapper for StateT that launches the game.

> runGame :: Monad m => (forall a. GuessP a -> m a) -> m ()
> runGame f = runPromptM f (evalStateT game initialGameState)

Here is the magic function for interacting with the player in IO.  Exercise for the reader: make this more robust.

> gameIOPrompt :: GuessP a -> IO a
> gameIOPrompt GetNumber = randomRIO (1, 100)
> gameIOPrompt (Print s) = putStr s
> gameIOPrompt Guess     = fmap read getLine

If you wanted to add undo, all you have to do is save off the current Prompt in the middle of runPromptM; you can return to the old state at any time.

> gameIO :: IO ()
> gameIO = do
>     hSetBuffering stdout NoBuffering
>     runGame gameIOPrompt

Here's a scripted version.

> type GameScript = State [Int]
> 
> scriptPrompt :: Int -> GuessP a -> GameScript a
> scriptPrompt n GetNumber = return n
> scriptPrompt _ (Print _) = return ()
> scriptPrompt _ Guess     = do
>     (x:xs) <- get -- fails if script runs out of answers
>     put xs
>     return x
>
> scriptTarget :: Int
> scriptTarget = 23
> scriptGuesses :: [Int]
> scriptGuesses = [50, 25, 12, 19, 22, 24, 23]

gameScript is True if the game ran to completion successfully, and False or bottom otherwise.
Try adding or removing numbers from scriptGuesses above and re-running the program.

> validGameScript :: Bool
> validGameScript = null $ execState (runGame (scriptPrompt scriptTarget)) scriptGuesses

> main = do
>    assert validGameScript $ return ()
>    gameIO

I've been playing with more interesting ways of scripting, using prompt to represent coroutines.
Here's the way you would write a script with coroutines:

> data ScriptPrompt a where
>     ScriptNumber :: Int -> ScriptPrompt ()
>     ScriptGuess :: Int -> ScriptPrompt ()

> gameScript :: Prompt ScriptPrompt ()
> gameScript = do
>     prompt $ ScriptNumber scriptTarget
>     let doGuess x = prompt $ ScriptGuess x
>     mapM_ doGuess scriptGuesses

"match" & "matchComplete" handle the communications between the coroutines.  The third case
    match _ (Print _) = (Nothing, Just ())
says to consume the "Print _" and return () to the game, but not consume anything from the script.

"matchComplete" eats any remaining "Print" messages from the game before the script completes.

> match :: ScriptPrompt a -> GuessP b -> (Maybe a, Maybe b)
> match (ScriptNumber x) (GetNumber) = (Just (), Just x)
> match (ScriptGuess x)  (Guess)     = (Just (), Just x)
> match _                (Print _)   = (Nothing, Just ())
> match _                _           = (Nothing, Nothing)

> matchComplete :: GuessP a -> Maybe a
> matchComplete (Print x) = Just ()
> matchComplete _         = Nothing

Here's the "interpretation" guts which allow two coroutine prompts to execute and pass information back and forth.  There's probably a better way of representing this, but I came up with this pretty quickly.

(Either String) is just a simple error monad so that "fail x" turns into "Left x".

> type ScriptRun promptScript b a = StateT (Prompt promptScript b) (Either String) a
> scriptRun ::
>       (promptGame a -> Maybe a) 
>    -> (forall x. promptScript x -> promptGame a -> (Maybe x, Maybe a))
>    -> promptGame a
>    -> ScriptRun promptScript b a
>
> scriptRun matchComplete match guess = do
>    state <- get
>    case state of
>        PromptDone _  -> 
>            case matchComplete guess of
>                 Nothing -> fail "script out of answers"
>                 Just x -> return x
>        Prompt script cont ->
>            case (match script guess) of
>                (_, Nothing) -> fail "script/game don't match"
>                (Just scriptAns, Just guessAns) -> do
>                    put (cont scriptAns)
>                    return guessAns
>                (_, Just guessAns) -> return guessAns

> scriptRunTest :: String
> scriptRunTest = case execStateT (runGame (scriptRun matchComplete match)) gameScript of
>        Left error -> error
>        Right (PromptDone ()) -> "ok!"
>        _ -> "game finishes before script!"