adventure.hs

-- http://svn.pugscode.org/pugs/examples/adventure/adventure.pl

import Data.Char as Char
import Data.List (intercalate)
import Text.ParserCombinators.Parsec
import Control.Monad.State.Lazy
import System.Console.Editline.Readline

--
-- Parser
--

data Command = Quit
             | Go Direction
             | Do Verb Object
               deriving (Show, Eq, Ord)

data Direction = East
               | South
               | West
               | North
                 deriving (Show, Eq, Ord)

data Verb = Look
          | Take
          | Put
            deriving (Show, Eq, Ord)

data Object = Coin
            | Key
            | Sign
            | Vampire
            | Door
            | Cross
            | Around
              deriving (Show, Eq, Ord)

parseCommand = parse command_syntax ""

command_syntax = quit
                 <|> liftM Go direction
                 <|> (do Look <- word [Look]
                         return $ Do Look Around)
                 <|> liftM2 Do verb (char ' ' >> object)
    where word a = try (many alphaNum >>=
                        word2token a)
          quit = word [Quit]
          direction = word [East, South, West, North]
          verb = word [Look, Take, Put]
          object = word [Coin, Key, Sign, Vampire, Door, Cross, Around]

word2token :: (Monad m, Show a) => [a] -> String -> m a
word2token (x:xs) s | x' == s' = return x
                    | otherwise = word2token xs s
    where downcase = map Char.toLower
          x' = downcase $ show x
          s' = downcase s
word2token _ s = fail $ "unrecognized token: " ++ s  -- Parsec monad will try next alternative

--
-- State logic
--

data Location = Chamber
              | ThroneRoom
              | Dungeon
              | Crypt
              | Cell
              deriving (Show, Eq, Ord)
data GameState' = GameState' { stLocation :: Location,
                               stInventory :: [Object],
                               stLocationObjects :: [(Location, [Object])]
                             }
                  deriving (Show, Eq, Ord)
type GameState a = StateT GameState' IO a

say = liftIO . putStrLn

inventoryContains :: Object -> GameState Bool
inventoryContains object = (object `elem`) `liftM`
                           stInventory `liftM`
                           get

goFrom Chamber North = return $ Just ThroneRoom
goFrom Chamber East = return $ Just Dungeon
goFrom ThroneRoom South = return $ Just Chamber
goFrom Dungeon West = return $ Just Chamber
goFrom Dungeon North = return $ Just Crypt
goFrom Dungeon South = do has_key <- inventoryContains Key
                          case has_key of
                            False -> do
                              say "Door is locked"
                              return $ Nothing
                            True -> return $ Just Cell
goFrom Crypt South = return $ Just Dungeon
goFrom Cell North = return $ Just Dungeon
goFrom _ _ = return Nothing

runCommand :: Command -> GameState ()
runCommand (Go direction) = do state <- get
                               let location = stLocation state
                               location' <- goFrom location direction
                               case location' of
                                 Just location'' -> do put state { stLocation = location'' }
                                                       say $ "You entered the " ++ (show location'')
                                 Nothing -> say "You've just hit the wall."
runCommand (Do Look Around) = do location <- stLocation `liftM` get
                                 objects <- maybe [] id `liftM`
                                            lookup location `liftM`
                                            stLocationObjects `liftM`
                                            get
                                 say $ "You are in the " ++ (show location)
                                 say $ "I see here: " ++ (intercalate ", " $ map show objects)
runCommand (Do Look object) = say $ "It's a regular " ++ (show object)
runCommand (Do verb object) = say $ "I cannot " ++ (show verb) ++ " with " ++ (show object) ++ ", you need to implement this first"
runCommand _ = say "I don't understand your utter crap. How was I able to parse it in the first place?"

--
-- Main interface
--

main' :: GameState ()
main' = do input <- liftIO $ readline "> "
           case input of
             Nothing -> return ()
             Just input' -> do
                        let parsed = parseCommand input'
                        case parsed of
                          Left e -> do say $ "Huh?\n" ++ (show e)
                                       main'
                          Right Quit -> say "Bye!"
                          Right command -> do runCommand command
                                              main'

main :: IO ()
main = let state = GameState' { stLocation = Chamber,
                                stInventory = [],
                                stLocationObjects = [(Chamber, [Sign]),
                                                     (Cell, [Coin]),
                                                     (Crypt, [Key, Vampire]),
                                                     (Dungeon, [Door]),
                                                     (ThroneRoom, [Cross])
                                                    ] }
       in fst `liftM` runStateT main' state