diff --git a/Advgame.cabal b/Advgame.cabal --- a/Advgame.cabal +++ b/Advgame.cabal @@ -1,6 +1,6 @@ Name: Advgame -Version: 0.1.1 -Description: Lisperati's adventure game in Lisp translated to Haskell +Version: 0.1.2 +Description: Dr. Conrad Barski's (Lisperati) adventure game in Lisp translated to Haskell (http://www.lisperati.com/casting.html) License: BSD3 License-file: LICENSE Author: Tim Wawrzynczak @@ -14,4 +14,3 @@ Executable advgame Main-is: Advgame.hs Build-Depends: base >= 3 && <= 4.1, mtl, haskell98 - diff --git a/Advgame.hs b/Advgame.hs --- a/Advgame.hs +++ b/Advgame.hs @@ -4,11 +4,10 @@ import Char (toUpper, toLower) import Control.Monad (mapM_) -import Control.Monad.State hiding (forever) -import Control.Monad.Cont (runContT, callCC, ContT(..)) +import Control.Monad.State (get, gets, StateT(..), evalStateT, + liftIO, put, MonadState(..), MonadIO(..)) 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 @@ -23,10 +22,17 @@ 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 :: String, + entryway :: Entryway, to :: Room } deriving (Eq, Show) @@ -54,40 +60,55 @@ 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 = [Whiskeybottle, Bucket, Chain, Frog] +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], + 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], + 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], + 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 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" -worldMap :: GS -worldMap = GS { dt = [livingRoom, garden, attic, inventory], curloc = livingRoom, welded = False, bucketFull = False } +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 = "There is a " ++ (entryway p) ++ " going " ++ (show . dir $ p) ++ " from here." +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 () @@ -99,11 +120,7 @@ -- 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 +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 () @@ -132,135 +149,144 @@ -- 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 +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 -> 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" +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 -> 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" +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))) } --- 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" +-- 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 ;) --- 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" +-- 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 --- 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" +-- 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 -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" +(?) :: a -> a -> Bool -> a +(?) true false test = if test then true else false --- 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... +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 - runStateT (runGameState run) worldMap - putStrLn "Goodbye!" + won <- evalStateT (runGameState run) initialMap + case won of + Won -> putStrLn winString + Lost -> putStrLn loseString + QuitGame -> putStrLn "Goodbye!"