gistfile1.hs

module Main where

import Control.Monad.State
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.List (isPrefixOf, intercalate)
import Data.Char (toLower)

main :: IO ()
main =  mapM_ putStrLn $ runSample

runSample = reverse . snd $ execState (beginGame sampleGame) (sampleScript, [])

sampleScript = ["go n", "go n", "i", "take fork", "go e", "go e", "score"]

{- Abstracted game logic -}

beginGame :: Game -> GameUI ()
beginGame game = do say $ describeLocation game
                    newCommand game

handleCmd :: [String] -> Game -> GameUI ()
handleCmd ["go", d] game = case parseDir d of
    Nothing  -> do complain "I don't know that direction."
                   newCommand game
    Just dir -> case lookupExit dir (currentRoomId game) game of
                    Nothing -> do complain "You can't go that way."
                                  newCommand game
                    Just ri -> let game' = onPlayer (setLocation ri) game
                               in do say $ describeLocation game'
                                     newCommand game'
handleCmd ["take", o] game | S.member obj locObs = do say "Ok."
                                                      newCommand (moveObj game)
                           | otherwise           = do complain "That's not here."
                                                      newCommand game
  where obj = Object o
        locObs = localObjects game
        moveObj = onPlayer (onInventory (S.insert obj) . onScore (+ 1)) 
                . onCurrentRoom (onContents $ S.delete obj)
handleCmd ["look"] game = do say $ describeLocation game
                             newCommand game
handleCmd ["inventory"] game = do say $ "You are carrying: " ++ describeObjs (inventory . player $ game)
                                  newCommand game
handleCmd ["score"] game = do say $ "Your score is: " ++ (show . score . player $ game)
                              newCommand game
handleCmd ["quit"] game = do say "Ok, bye."
                             say $ "Final score: " ++ (show . score . player $ game)
                             return ()
handleCmd _ game = do complain "I don't know how to do that."
                      newCommand game

tidy :: [String] -> [String]
tidy [] = []
tidy (w:ws) = expandAbbr w : filter (`notElem` junk) ws
  where junk = ["a", "an", "the", "to", "at"]

expandAbbr :: String -> String
expandAbbr word = case filter (isPrefixOf word) abbrs of
    [fullWord] -> fullWord
    _          -> word
  where abbrs = [ "go", "take", "look", "inventory", "quit", "score" ]

{- Command script stuff -} 

type GameUI = State ([String], [String])

nextInput :: GameUI (Maybe String)
nextInput = do (input, output) <- get
               case input of
                   []     -> return Nothing
                   (c:cs) -> do put (cs, output)
                                writeOutput c
                                return (Just c)

writeOutput :: String -> GameUI ()
writeOutput str = do (input, output) <- get
                     put (input, str:output)

newCommand :: Game -> GameUI ()
newCommand game = do str <- nextInput
                     case str of
                         Nothing  -> writeOutput "-- End of Input --"
                         Just cmd -> handleCmd (tidy . words $ map toLower cmd) game

say, complain :: String -> GameUI ()
complain msg = writeOutput $ "  *** " ++ msg
say msg = writeOutput msg

{- Game world data types -} 

type RoomId = Int
type Message = String

data Game = Game { rooms  :: Map RoomId Room
                 , player :: Player
                 } deriving (Eq, Ord, Read, Show)

data Player = Player { location  :: RoomId
                     , score     :: Int
                     , inventory :: Set Object
                     } deriving (Eq, Ord, Read, Show)

data Dir = N | S | E | W deriving (Eq, Ord, Read, Show)

data Room = Room { roomDesc :: String 
                 , exits    :: Map Dir RoomId
                 , contents :: Set Object
                 } deriving (Eq, Ord, Read, Show)

data Object = Object { objName :: String } deriving (Eq, Ord, Read, Show)

displayExit :: Dir -> String
displayExit N = "north"
displayExit S = "south"
displayExit E = "east"
displayExit W = "west"

parseDir :: String -> Maybe Dir
parseDir str | isPrefixOf str "north" = Just N
             | isPrefixOf str "south" = Just S
             | isPrefixOf str "east"  = Just E
             | isPrefixOf str "west"  = Just W
             | otherwise              =Nothing

describeRoom :: Room -> String
describeRoom room = unlines [ roomDesc room
                            , "Exits are: " ++ describeExits (exits room)
                            , "Items here: " ++ describeObjs (contents room)
                            ]

describeExits :: Map Dir RoomId -> String
describeExits exs = intercalate ", " $ map displayExit (M.keys exs)

describeObjs :: Set Object -> String
describeObjs cs | S.null cs = "nothing"
                | otherwise = intercalate ", " $ map objName (S.toList cs)

{- Game world lookup functions -} 

lookupRoom :: RoomId -> Game -> Maybe Room
lookupRoom roomid game = M.lookup roomid (rooms game)

lookupExit :: Dir -> RoomId -> Game -> Maybe RoomId
lookupExit d roomid game = case lookupRoom roomid game of
    Just r  -> M.lookup d (exits r)
    Nothing -> Nothing

lookupExitRoom :: Dir -> RoomId -> Game -> Maybe Room
lookupExitRoom d roomid game = case lookupExit d roomid game of
    Just ri -> lookupRoom ri game
    Nothing -> Nothing


currentRoomId :: Game -> RoomId
currentRoomId = location . player

currentRoom :: Game -> Maybe Room
currentRoom game = lookupRoom (currentRoomId game) game

describeLocation :: Game -> String
describeLocation game = case currentRoom game of
    Nothing -> "You are... nowhere?"
    Just r  -> describeRoom r

localObjects :: Game -> Set Object
localObjects game = maybe S.empty contents (currentRoom game)

{- Game world upate functions -} 

onPlayer :: (Player -> Player) -> Game -> Game
onPlayer f game = game { player = f $ player game }

onInventory :: (Set Object -> Set Object) -> Player -> Player
onInventory f plr = plr { inventory = f $ inventory plr }

onScore :: (Int -> Int) -> Player -> Player
onScore f plr = plr { score = f $ score plr}

setLocation :: RoomId -> Player -> Player
setLocation loc plr = plr { location = loc }

onRooms :: (Map RoomId Room -> Map RoomId Room) -> Game -> Game
onRooms f game = game { rooms = f $ rooms game }

onContents :: (Set Object -> Set Object) -> Room -> Room
onContents f room = room { contents = f $ contents room }

onRoom :: (Room -> Room) -> RoomId -> Game -> Game
onRoom f roomid game = case lookupRoom roomid game of
    Nothing -> game
    Just r  -> onRooms (M.insert roomid $ f r) game

onCurrentRoom :: (Room -> Room) -> Game -> Game
onCurrentRoom f game = onRoom f (currentRoomId game) game

{- Sample game -} 

room0 = Room (unlines [ "You stand at the southern edge of a peaceful forest."
                      , "A break in the underbrush reveals a trail leading into the woods."
                      ])
             (M.fromList [(N, 1)])
             S.empty

room1 = Room "You are on a trail leading north through the forest."
             (M.fromList [(S, 0), (N, 2)])
             S.empty

room2 = Room "You find a fork in the path, figuratively speaking. Or maybe literally."
             (M.fromList [(S, 1), (E, 3), (W, 4)])
             (S.fromList [Object "fork"])

room3 = Room (unlines [ "You are on a trail leading east. A small river flows to the north."
                      , "A fallen tree blocks your way."
                      ])
             (M.fromList [(W, 2)])
             S.empty

room4 = Room "The trail ends here. A sign says 'ok, you get the idea'. Huh?"
             (M.fromList [(E,2)])
             S.empty

sampleRooms = M.fromList (zip [0..] [room0, room1, room2, room3, room4])

sampleGame = Game sampleRooms (Player 0 0 S.empty)