Advgame (empty) → 0.1

raw patch · 5 files changed

+297/−0 lines, 5 filesdep +basedep +haskell98dep +mtlsetup-changed

Dependencies added: base, haskell98, mtl

Files

• Advgame.cabal +16/−0
• Advgame.hs +266/−0
• LICENSE +12/−0
• README +1/−0
• Setup.hs +2/−0

@@ -0,0 +1,16 @@+Name:			Advgame+Version:		0.1+Description:		Lisperati's adventure game in Lisp translated to Haskell+License:		BSD3+License-file:		LICENSE+Author:			Tim Wawrzynczak+Maintainer:		inforichland@gmail.com+Build-Type:		Simple+Cabal-Version:		>=1.2+Category:		Game+extra-source-files:	README++Executable advgame+  Main-is:		Advgame.hs+  Build-Depends:	base >= 3 && <= 4.1, mtl, haskell98+

@@ -0,0 +1,266 @@+{-# 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!"

@@ -0,0 +1,12 @@+Copyright (c) 2009, Tim Wawrzynczak+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * Neither the name of the <ORGANIZATION> nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++

@@ -0,0 +1,1 @@+A simple translation of the Lisp adventure game on http://lisperati.com to Haskell.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain