Advgame-0.1: Advgame.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Main where

import Char (toUpper, toLower)
import Control.Monad (mapM_)
import Control.Monad.State hiding (forever)
import Control.Monad.Cont (runContT, callCC, ContT(..))
import Data.List (delete)
import Text.Printf (printf)
import qualified Control.Exception as E (catch, throw)
import System.IO (hFlush, stdout)

-- Objects in the game
data Object = Whiskeybottle | Bucket | Chain | Frog | Wizard | Well
    deriving (Eq, Show, Read)

-- Directions you can walk
data Direction = West | East | Upstairs | Downstairs
    deriving (Eq, Show, Read)

-- Rooms in the game
data Room = Garden | Attic | LivingRoom | InventoryRoom
    deriving (Eq, Show, Read)

-- A Path from one place to another, and the entryway
data Path = Path {
    dir :: Direction,
    entryway :: String,
    to :: Room
} deriving (Eq, Show)

-- a location: name, description, a list of paths to other Locations, and objects in that location
data Location = Location {
    name :: Room,
    desc :: String,
    paths :: [Path],
    objects :: [Object]
} deriving (Eq)

-- User commands
data Command = Walk Direction | 
               Pickup Object | 
               Splash Object Object | 
               Inventory | 
               Look | 
               Dunk Object Object | 
               Weld Object Object |
               Quit |
               Help
    deriving (Eq, Show, Read)

-- default show instance for a Location is to show the description
instance Show Location where
    show = show . desc

-- the objects that can be picked up
pickupable = [Whiskeybottle, Bucket, Chain, Frog]

-- locations
livingRoom = Location { name = LivingRoom,
    desc = "You are in the living-room of a wizard's house.  There is a wizard snoring loudly on the couch.",
    paths = [Path West "door" Garden, Path Upstairs "stairway" Attic],
    objects = [Whiskeybottle, Bucket, Wizard]}
garden = Location { name = Garden,
    desc = "You are in a beautiful garden.  There is a well in front of you.",
    paths = [Path East "door" LivingRoom],
    objects = [Chain, Frog, Well]}
attic = Location { name = Attic,
    desc = "You are in the attic of the wizard's house.  There is a giant welding torch in the corner.",
    paths = [Path Downstairs "stairway" LivingRoom],
    objects = []}
inventory = Location { name = InventoryRoom,
    desc = "",
    paths = [],
    objects = []}

-- define a datatype to hold the game information
data GS = GS {dt :: [Location], curloc :: Location, welded :: Bool, bucketFull :: Bool} deriving (Show)
-- and a state transformer monad to automagically thread the state for us
newtype GameState a = GameState { runGameState :: StateT GS IO a }
    deriving (Monad, MonadIO, MonadState GS)

-- the "world map"
worldMap :: GS
worldMap = GS { dt = [livingRoom, garden, attic, inventory], curloc = livingRoom, welded = False, bucketFull = False }

-- return a description of a path
describePath :: Path -> String
describePath p = "There is a " ++ (entryway p) ++ " going " ++ (show . dir $ p) ++ " from here."

-- print out a description of the location
describeLocation :: Location -> IO ()
describeLocation = putStrLn . desc

-- print out all the paths leading out of the current location
describePaths :: Location -> IO ()
describePaths = mapM_ (putStrLn . describePath) . paths

-- print out object descriptions at the current location
describeFloor :: Location -> IO ()
describeFloor = mapM_ putStrLn . map (printf "You see a %s on the floor." . show) . filter (flip elem pickupable) . objects

-- is an object at the specified location?
isAt :: Object -> Location -> Bool
isAt obj = elem obj . objects

-- print out location, path and object info
look :: Location -> IO ()
look loc = do
  describeLocation loc
  describePaths loc
  describeFloor loc

-- is there a path leading *d* from *loc* ?
viableDir :: Direction -> Location -> Bool
viableDir d = or . map ((== d) . dir) . paths

-- given the name of a location, return the location object
getLoc :: Room -> [Location] -> Location
getLoc x = head . filter ((== x) . name)

-- capitalize a word
capitalize :: String -> String
capitalize word = (toUpper . head) word : (map toLower (tail word))

-- better version of read, returns Maybe instead of blowing up
maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
                [(x,"")] -> Just x
                _ -> Nothing

-- check if the command the user entered is valid
parseCommand :: String -> Maybe Command
parseCommand input = 
    case maybeRead (caps input) of
      Just x -> return x
      _ -> Nothing
    where
      caps = unwords . map capitalize . words

-- typing shortcut
io = liftIO

-- user is walking
walk :: Direction -> ContT () GameState ()
walk di = do
  c <- gets curloc
  t <- get
  d <- gets dt
  if viableDir di c 
    then do
      io . putStrLn $ "Walking " ++ (show di)
      put t{curloc = ((flip getLoc d). to . head $ filter ((== di) . dir) (paths c))}
    else do
      io . putStrLn $ "I can't walk that way"

-- user picking up an object
pickup :: Object -> ContT () GameState ()
pickup obj = do
  c <- gets curloc
  d <- gets dt
  t <- get
  if isAt obj c && obj `elem` pickupable 
    then do
      let newl = c{objects = (delete obj (objects c))}
          inv = getLoc InventoryRoom d
          ninv = inv{objects = obj : (objects inv)}
      put t{curloc = newl, dt = (newl : ninv : (delete inv (delete c d)))}
      io . putStrLn $ "Picking up " ++ (show obj)
    else do
      io . putStrLn $ "I can't pick that up"

-- user splashing one object onto another
splash :: (Monad m) => (m () -> ContT () GameState ()) -> Object -> Object -> ContT () GameState ()
splash exit obj1 obj2 = do
  d <- gets dt
  w <- gets welded
  b <- gets bucketFull
  c <- gets curloc
  let inv = getLoc InventoryRoom d
  if and [name c == LivingRoom, w, b, obj1 == Bucket, obj2 == Wizard] 
    then do
      io . putStrLn $ "Splashing the " ++ (show obj1) ++ " on " ++ (show obj2)
      if not (isAt Frog inv) 
        then do io . putStrLn $ "the wizard awakens from his slumber and greets you warmly. he hands you the magic low-carb donut- you win! the end"
        else do io . putStrLn $ "the wizard awakens and sees that you stole his frog. he is so upset he banishes you to the netherworlds- you lose! the end"
      exit $ return ()
    else do io . putStrLn $ "I can't splash like that"

-- user welding one onto another
weld :: Object -> Object -> ContT () GameState ()
weld obj1 obj2 = do
  t <- get
  d <- gets dt
  c <- gets curloc
  let inv = getLoc InventoryRoom d
  if and [isAt Chain inv, isAt Bucket inv, name c == Attic, obj1 == Chain, obj2 == Bucket] 
    then do
      io . putStrLn $ "Welding the " ++ (show obj1) ++ " to the " ++ (show obj2)
      put t { welded = True }
    else do io . putStrLn $ "I can't weld like that"

-- user dunking one object into another
dunk :: Object -> Object -> ContT () GameState ()
dunk obj1 obj2 = do
  d <- gets dt
  w <- gets welded
  t <- get
  c <- gets curloc
  let inv = getLoc InventoryRoom d
  if and [w, name c == Garden, obj1 == Bucket, obj2 == Well] 
    then do
      io . putStrLn $ "Dunking the " ++ (show obj1) ++ " in the " ++ (show obj2)
      put t { bucketFull = True }
    else do io . putStrLn $ "I can't dunk like that"

help :: ContT () GameState ()
help = do
  io . putStrLn $ "Available commands are:"
  io . putStrLn $ "Walk [Direction]"
  io . putStrLn $ "Pickup [Object]"
  io . putStrLn $ "Splash [Object] [Object]"
  io . putStrLn $ "Weld [Object] [Object]"
  io . putStrLn $ "Dunk [Object] [Object]"
  io . putStrLn $ "Inventory"
  io . putStrLn $ "Look"
  io . putStrLn $ "Quit"
  io . putStrLn $ "Help\n"

-- run the "game"
run :: GameState ()
run = (`runContT` id) $ do
    dummy <- callCC $ \exit -> forever $ do
      t <- get -- the whooole thing
      d <- gets dt -- world map
      c <- gets curloc -- current location
      -- read a command from the user
      io . putStr $ "> "
      io . hFlush $ stdout
      line <- io getLine
      case parseCommand line of
        Nothing -> io . putStrLn $ "Invalid command!"
        Just cmd -> do
          case cmd of
            Walk dir -> walk dir
            Pickup o -> pickup o
            Splash o1 o2 -> splash exit o1 o2
            Weld o1 o2 -> weld o1 o2
            Dunk o1 o2 -> dunk o1 o2
            Inventory -> io . print . objects . getLoc InventoryRoom $ d
            Look -> io . look $ c
            Quit -> exit $ return ()
            Help -> help
    -- and shove the () back into the monad
    return dummy
    -- lather, rinse, repeat
    where
      forever a = a >> forever a -- forever and ever and ever and ever...

-- run the thing already!
main :: IO ()
main = do
    look livingRoom
    runStateT  (runGameState run) worldMap
    putStrLn "Goodbye!"