Advgame 0.1.1 → 0.1.2
raw patch · 2 files changed
+164/−139 lines, 2 files
Files
- Advgame.cabal +2/−3
- Advgame.hs +162/−136
Advgame.cabal view
@@ -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-
Advgame.hs view
@@ -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!"