Advgame-0.1.2: Advgame.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Main where

import Char (toUpper, toLower)
import Control.Monad (mapM_)
import Control.Monad.State (get, gets, StateT(..), evalStateT, 
                            liftIO, put, MonadState(..), MonadIO(..))
import Data.List (delete)
import Text.Printf (printf)
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)

-- Entryways
data Entryway = Door | Stairway
    deriving (Eq)
instance Show Entryway where
    show Door = "door"
    show Stairway = "stairway"

-- A Path from one place to another, and the entryway
data Path = Path {
    dir :: Direction,
    entryway :: Entryway,
    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 different results that an action can have
data Result = Won | Lost | Continue | QuitGame
    deriving (Eq)

-- the type of an 'action' (weld, dunk, etc.)
type GameAction = Object -> Object -> GameState Result

-- define a datatype to hold the game information
data GS = GS { worldMap :: [Location], currentLocation :: 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 objects that can be picked up
pickupable = flip elem [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 = []}

-- the winning and losing messages
winString = "the wizard awakens from his slumber and greets you warmly. he hands you the magic low-carb donut- you win! the end"
loseString = "the wizard awakens and sees that you stole his frog. he is so upset he banishes you to the netherworlds- you lose! the end"

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

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

-- 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 pickupable . 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 = maybeRead (caps input) >>= return
    where caps = unwords . map capitalize . words

-- typing shortcut
io = liftIO
write = io . putStrLn

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

-- is the object in the inventory ?
haveObject :: Object -> GameState Bool
haveObject obj = gets worldMap >>= \w ->
                 let inv = (getLoc InventoryRoom w) in
                 return $ isAt obj inv

-- is the current room the given one ?
currentRoomIs :: Room -> GameState Bool
currentRoomIs room = gets currentLocation >>= return . ((== room) . name)

continue :: (Monad m) => m Result
continue = return Continue

-- user is walking
walk :: Direction -> GameState Result
walk di = ableToWalk di >>= \able ->
  if able
    then newLocation di >>= setLocation >> (write $ printf "Walking %s " (show di)) >> continue
    else write "I can't walk that way" >> continue
  where ableToWalk d = gets currentLocation >>= \l -> return (viableDir d l)
        newLocation d = get >>= \t -> return ((flip getLoc (worldMap t)) . to . head $ filter (( == d) . dir) (paths (currentLocation t)))
        setLocation l = get >>= \t -> put t{ currentLocation = l }

-- user picking up an object
pickup :: Object -> GameState Result
pickup obj = ableToPickup obj >>= \able ->
             if able
               then storeObject obj >> (write $ printf "Picking up %s" (show obj)) >> continue 
               else write "I can't pick that up" >> continue
  where ableToPickup obj = get >>= \t -> return $ isAt obj (currentLocation t) && pickupable obj
        storeObject obj = get >>= \t ->
                          let c = currentLocation t
                              w = worldMap t
                              newl = c{ objects = (delete obj (objects c)) }
                              inv = getLoc InventoryRoom w
                              newInv = inv { objects = obj : (objects inv) } in
                          put t{ currentLocation = newl, worldMap = (newl : newInv : (delete inv (delete c w))) }

-- run a game action (i.d. weld, dunk, splash)
-- I know the type signature is unwieldy, but you can't say that I didn't refactor ;)

-- have = list of objects the player must have
-- room = the room the user must be in
-- obj1, obj2 = the objects the user typed in
-- spec1, spec2 = the specified objects needed to complete the action
-- effect = an effect to carry out if the action succeeds
-- misc = any other miscellaneous items that must be true to succeed
-- string1,string2 = the success string (including two %s's for the object names), and the failure string, respectively
gameAction :: [Object] -> Room -> Object -> Object -> Object -> Object -> 
              GameState () -> [GameState Bool] -> String -> String -> GameState Bool
gameAction have room obj1 obj2 spec1 spec2 effect misc string1 string2 = do
  haveAll <- return . and =<< mapM haveObject have
  inRoom <- currentRoomIs room
  allMisc <- return . and =<< if null misc then return [True] else sequence misc
  let correctObjects = (obj1 == spec1 && obj2 == spec2)
      result = and [haveAll, inRoom, correctObjects, allMisc]
  if result then effect >> write (printf string1 (show obj1) (show obj2)) >> return True else write string2 >> return False

-- weld two objects together
weld :: GameAction
weld obj1 obj2 = gameAction [Chain,Bucket] Attic Chain Bucket obj1 obj2
                 (get >>= \t -> put t{ welded = True }) []
                 "Welding the %s to the %s" 
                 "I can't weld like that" >> return Continue
-- dunk one object in another
dunk :: GameAction
dunk obj1 obj2 = gameAction [Chain,Bucket] Garden Bucket Well obj1 obj2 
                 (get >>= \t -> put t{ bucketFull = True }) [gets welded] 
                 "Dunking the %s in the %s" "I can't dunk like that" >> return Continue
-- splash one object on another
splash :: GameAction
splash obj1 obj2 = gameAction [Bucket] LivingRoom Bucket Wizard obj1 obj2 
                   (return ()) [gets welded, gets bucketFull]
                   "Splashing the %s on the %s" "I can't splash like that" >>= \result ->
                   if result then haveObject Frog >>= return . (?) Won Lost
                             else return Continue

(?) :: a -> a -> Bool -> a
(?) true false test = if test then true else false

help :: GameState Result
help = mapM_ write 
       ["", "  Available commands are:",
        "   - Walk [Direction]",
        "   - Pickup [Object]",
        "   - Splash [Object] [Object]",
        "   - Weld [Object] [Object]",
        "   - Dunk [Object] [Object]",
        "   - Inventory",
        "   - Look",
        "   - Quit",
        "   - Help", ""] >> continue

getInventory :: GameState [Object]
getInventory = return . objects . getLoc InventoryRoom =<< gets worldMap

-- run the game
run :: GameState Result
run =  do
  t <- get
  -- read a command from the user
  io . putStr $ "> "
  io . hFlush $ stdout
  line <- io getLine
  result <- case parseCommand line of
    Nothing -> write "Invalid command!" >> continue
    Just cmd -> do
         case cmd of
           Walk dir -> walk dir
           Pickup o -> pickup o
           Splash o1 o2 -> splash o1 o2
           Weld o1 o2 -> weld o1 o2
           Dunk o1 o2 -> dunk o1 o2
           Inventory -> getInventory >>= io . print >> continue
           Look -> io (look (currentLocation t)) >> continue
           Quit -> return QuitGame
           Help -> help
  case result of
    Continue -> run
    x -> return x

-- run the thing already!
main :: IO ()
main = do
    look livingRoom
    won <- evalStateT (runGameState run) initialMap
    case won of
      Won -> putStrLn winString 
      Lost -> putStrLn loseString
      QuitGame -> putStrLn "Goodbye!"