Last active
October 1, 2017 18:44
-
-
Save Lifelovinglight/23fe272ac0a9547b806173b38ab93e66 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE TemplateHaskell #-} | |
import System.IO | |
import Text.Parsec | |
import Control.Monad.State | |
import Control.Monad | |
import Control.Monad.Loops | |
import Control.Lens | |
import Data.Maybe | |
import Data.Map.Strict (Map) | |
import qualified Data.Map.Strict as Map | |
import qualified Data.Char as Char | |
voidM :: Monad m => m a -> m () | |
voidM m = m >> return () | |
_if :: a -> a -> Bool -> a | |
_if a b p = if p then a else b | |
eitherMaybe :: Either a b -> Maybe b | |
eitherMaybe (Left _) = Nothing | |
eitherMaybe (Right b) = Just b | |
(<++>) :: Monad m => m [a] -> m [a] -> m [a] | |
a <++> b = liftM2 (++) a b | |
(<||>) :: Monad m => m Bool -> m Bool -> m Bool | |
a <||> b = liftM2 (||) a b | |
(<&&>) :: Monad m => m Bool -> m Bool -> m Bool | |
a <&&> b = liftM2 (&&) a b | |
memptyM :: (Monad m, Monoid a) => m a | |
memptyM = return mempty | |
type Assoc a b = [(a, b)] | |
type NameList a = Assoc [String] a | |
type SimpleGraph = Map Thing Thing | |
type PropertyMap a b = Map (Thing, a) b | |
type PropertyGraph a = PropertyMap a Thing | |
-- Game data. -- | |
data Verb = Exit | |
| Look | |
| Take | |
| Drop | |
| Put | |
| Inventory | |
| Use | |
| Drag | |
| Release | |
| Light | |
| Extinguish | |
| GoEast | |
| GoNorth | |
| GoWest | |
| GoSouth | |
| GoDown | |
| GoUp | |
deriving (Enum, Show, Eq, Ord) | |
data Thing = Player | |
-- Generic items. | |
| Lantern | |
| Sword | |
| Bag | |
| Nixon | |
-- Locations. | |
| Garden | |
| LivingRoom | |
| Basement | |
deriving (Enum, Show, Eq, Ord) | |
data Flag = Touched | |
| Lit | |
| Dark | |
deriving (Enum, Show, Eq, Ord) | |
connectives :: [String] | |
connectives = [ "the", "at", "a", "in", "under", "on", "inside", "with", "using", "from" ] | |
thingNames :: NameList Thing | |
thingNames = [(["me", "myself"], Player) | |
,(["lantern"], Lantern) | |
,(["sword"], Sword) | |
,(["bag"], Bag) | |
,(["richard", "nixon", "corpse", "body"], Nixon) | |
,(["garden"], Garden) | |
,(["livingroom", "living", "room"], LivingRoom) | |
,(["basement"], Basement)] | |
description :: Thing -> String | |
description Player = "You look as healthy as ever." | |
description Lantern = "A brass lantern." | |
description Sword = "A fine longsword of elvish make." | |
description Bag = "A hemp bag with a cord to tie it closed." | |
description Nixon = "The very dead corpse of US ex-president Richard Nixon. A bullet wound is visible near the temple." | |
description Garden = "A lovely garden with trees and topiary. A door leads east into a white house." | |
description LivingRoom = "A furnished living room. A door leads west out of the house. A trapdoor leads down." | |
description Basement = "A basement full of crates and trinkets. A ladder leads up to the living room." | |
name :: Thing -> String | |
name Player = "yourself" | |
name Lantern = "lantern" | |
name Sword = "sword" | |
name Bag = "bag" | |
name Nixon = "corpse of Richard Nixon" | |
name Garden = "A Beautiful Garden" | |
name LivingRoom = "A Living Room" | |
name Basement = "A Dark Basement" | |
articleName :: Thing -> String | |
articleName Nixon = "the " ++ name Nixon | |
articleName a = "a " ++ name a | |
dragMessage :: Thing -> String | |
dragMessage thing = | |
"You effortfully drag the " ++ name thing ++ " along with you." | |
startingLocations :: Assoc Thing Thing | |
startingLocations = [(Player, Garden) | |
,(Sword, LivingRoom) | |
,(Lantern, Garden) | |
,(Bag, Basement)] | |
east :: Thing -> Maybe Thing | |
east Garden = Just LivingRoom | |
east _ = Nothing | |
north :: Thing -> Maybe Thing | |
north _ = Nothing | |
south :: Thing -> Maybe Thing | |
south _ = Nothing | |
west :: Thing -> Maybe Thing | |
west LivingRoom = Just Garden | |
west _ = Nothing | |
down :: Thing -> Maybe Thing | |
down LivingRoom = Just Basement | |
down _ = Nothing | |
up :: Thing -> Maybe Thing | |
up Basement = Just LivingRoom | |
up _ = Nothing | |
container :: Thing -> Bool | |
container Bag = True | |
container _ = False | |
verbNames :: NameList Verb | |
verbNames = [(["quit", "exit"], Exit) | |
,(["look", "examine", "exa", "inspect"], Look) | |
,(["take", "get"], Take) | |
,(["drop"], Drop) | |
,(["put", "insert"], Put) | |
,(["i", "inv", "inventory"], Inventory) | |
,(["use"], Use) | |
,(["drag", "pull"], Drag) | |
,(["release"], Release) | |
,(["light", "ignite"], Light) | |
,(["extinguish"], Extinguish) | |
,(["e", "east"], GoEast) | |
,(["n", "north"], GoNorth) | |
,(["w", "west"], GoWest) | |
,(["s", "south"], GoSouth) | |
,(["d", "down"], GoDown) | |
,(["u", "up"], GoUp)] | |
data GameState = GameState { _exit :: Bool | |
, _locations :: SimpleGraph | |
, _flags :: PropertyMap Flag Bool | |
, _turns :: Integer | |
, _gruesome :: Bool | |
, _endReason :: String | |
, _draggedObject :: Maybe Thing } | |
deriving (Show) | |
makeLenses ''GameState | |
type Game a = StateT GameState IO a | |
initialGameState :: GameState | |
initialGameState = GameState { _exit = False | |
, _locations = Map.fromList startingLocations | |
, _flags = Map.empty | |
, _turns = 0 | |
, _gruesome = False | |
, _endReason = "FOO" | |
, _draggedObject = Nothing } | |
-- Parser logic. -- | |
data Action = Action Verb (Maybe Thing) (Maybe Thing) deriving (Show) | |
filterNamelist :: Eq a => [a] -> NameList a -> NameList a | |
filterNamelist ax ln = filter (\(_, a) -> elem a ax) ln | |
-- Parser state is list of visible/reachable things that can be resolved. | |
type AdventureParser a = Parsec String [Thing] a | |
wordParser :: NameList a -> AdventureParser a | |
wordParser = choice . fmap (uncurry parseNames) | |
where parseNames :: [String] -> a -> AdventureParser a | |
parseNames sln a = choice (try . parseName <$> sln) >> return a | |
parseName :: String -> AdventureParser () | |
parseName str = try (string str) >> lookAhead (try whitespace1 <|> eof) | |
noun :: AdventureParser Thing | |
noun = wordParser . (flip filterNamelist) thingNames =<< stateUser <$> getParserState | |
verb :: AdventureParser Verb | |
verb = wordParser verbNames | |
parseCommand :: AdventureParser Action | |
parseCommand = whitespace >> liftM3 Action verb maybeNoun maybeNoun | |
where maybeNoun :: AdventureParser (Maybe Thing) | |
maybeNoun = optionMaybe (noise >> noun) | |
whitespace1 :: Parsec String u () | |
whitespace1 = skipMany1 (char ' ') | |
whitespace :: Parsec String u () | |
whitespace = skipMany (char ' ') | |
connective :: AdventureParser () | |
connective = voidM (choice (string <$> connectives)) | |
noise :: AdventureParser () | |
noise = whitespace1 >> voidM (endBy connective whitespace1) | |
-- Game logic. -- | |
location :: Thing -> Game Thing | |
location t = uses locations (Map.findWithDefault Garden t) | |
setFlag :: Flag -> Thing -> Game () | |
setFlag flag thing = flags %= Map.insert (thing, flag) True | |
unsetFlag :: Flag -> Thing -> Game () | |
unsetFlag flag thing = flags %= Map.delete (thing, flag) | |
hasFlag :: Flag -> Thing -> Game Bool | |
hasFlag flag thing = uses flags (Map.findWithDefault False (thing, flag)) | |
ifHasFlag :: Flag -> Thing -> Game a -> Game a -> Game a | |
ifHasFlag thing flag t f = _if t f =<< hasFlag thing flag | |
here :: Game Thing | |
here = location Player | |
adjacent :: Thing -> Thing -> Game Bool | |
adjacent thing1 thing2 = liftM2 (==) (location thing1) here | |
ifAdjacent :: Thing -> Thing -> Game a -> Game a -> Game a | |
ifAdjacent thing1 thing2 t f = _if t f =<< adjacent thing1 thing2 | |
whenAdjacent :: Thing -> Thing -> Game () -> Game () | |
whenAdjacent thing1 thing2 fn = (flip when) fn =<< adjacent thing1 thing2 | |
hasLight :: Game Bool | |
hasLight = (not <$> (hasFlag Dark =<< here)) <||> (anyM (hasFlag Lit) =<< ((contents =<< here) <++> inventory)) | |
ifHasLight :: Game a -> Game a -> Game a | |
ifHasLight t f = _if t f =<< hasLight | |
contents :: Thing -> Game [Thing] | |
contents loc = uses locations (Map.keys . Map.filterWithKey (\_ a -> a == loc)) | |
visibility :: Game [Thing] | |
visibility = | |
inventory | |
<++> (fmap concat . mapM contents =<< inventory) | |
<++> ifHasLight (contents =<< here) memptyM | |
whenTurnIs :: Integer -> Game () -> Game () | |
whenTurnIs n fn = (flip when) fn =<< uses turns (== n) | |
ifIsIn :: Thing -> Thing -> Game a -> Game a -> Game a | |
ifIsIn thing loc t f = _if t f . elem thing =<< contents loc | |
whenIsIn :: Thing -> Thing -> Game () -> Game () | |
whenIsIn thing loc fn = ifIsIn thing loc fn (return ()) | |
whenIsAt :: Thing -> Game () -> Game () | |
whenIsAt thing fn = whenIsIn Player thing fn | |
playerHas :: Thing -> Game Bool | |
playerHas thing = ifPlayerHas thing (return True) (return False) | |
ifPlayerHas :: Thing -> Game a -> Game a -> Game a | |
ifPlayerHas thing t f = ifIsIn thing Player t f | |
whenPlayerHas :: Thing -> Game () -> Game () | |
whenPlayerHas thing fn = whenIsIn thing Player fn | |
ifPlayerIsDragging :: Thing -> Game a -> Game a -> Game a | |
ifPlayerIsDragging thing t f = | |
maybe f (_if t f . (thing ==)) =<< use draggedObject | |
whenPlayerIsDragging :: Thing -> Game () -> Game () | |
whenPlayerIsDragging thing fn = | |
(fmap (== thing) <$> use draggedObject) >> fn | |
inventory :: Game [Thing] | |
inventory = contents Player | |
moveTo :: Thing -> Thing -> Game () | |
moveTo x y = locations %= Map.insert x y | |
goto :: Thing -> Game () | |
goto thing = | |
moveTo Player thing | |
>> (mapM_ dragAlong =<< use draggedObject) | |
>> lookAtRoom thing | |
dragAlong :: Thing -> Game () | |
dragAlong thing = | |
output (dragMessage thing) | |
>> (moveTo thing =<< here) | |
pickUp :: Thing -> Game () | |
pickUp thing = moveTo thing Player >> setFlag Touched thing | |
dropThing :: Thing -> Game () | |
dropThing thing = whenPlayerHas thing (moveTo thing =<< here) | |
englishList :: [Thing] -> String | |
englishList [] = "" | |
englishList ([a]) = articleName a | |
englishList ([a,b]) = articleName a ++ " and " ++ articleName b | |
englishList ([a,b,c]) = articleName a ++ ", " ++ articleName b ++ " and " ++ articleName c | |
englishList (a:ax) = articleName a ++ ", " ++ englishList ax | |
actionDescribe :: String -> Thing -> String | |
actionDescribe action thing = "You " ++ action ++ " the " ++ name thing ++ "." | |
lookAtRoom :: Thing -> Game () | |
lookAtRoom loc = do | |
lit <- hasLight | |
if (not lit) | |
then output "It is pitch black. You are likely to be eaten by a grue." | |
else do | |
output (description loc) | |
things <- filter (/= Player) <$> contents loc | |
unless (null things) (output ("You see " ++ englishList things ++ " here.")) | |
tryWalk :: Thing -> (Thing -> Maybe Thing) -> Game () | |
tryWalk loc direction = maybe (output "You cannot go that way.") goto (direction loc) | |
beginDragging :: Thing -> Game () | |
beginDragging thing = | |
stopDragging | |
>> (output (actionDescribe "grab a steady hold of" thing)) | |
>> draggedObject .= (Just thing) | |
stopDragging :: Game () | |
stopDragging = | |
(mapM_ (output . actionDescribe "release your hold on") =<< use draggedObject) | |
>> draggedObject .= Nothing | |
-- Set the exit flag. | |
exitAdventure :: String -> Game () | |
exitAdventure reason = | |
endReason .= reason | |
>> exit .= True | |
-- Things that happen every turn. -- | |
time :: Game () | |
time = do | |
-- Turn-determinate events. | |
whenTurnIs 0 (goto Garden >> setFlag Dark Basement) | |
whenTurnIs 10 (output "The sound of a gunshot echoes through the area.") | |
whenTurnIs 11 (whenIsAt Garden | |
(output "A human body suddenly falls to the ground from somewhere above with a loud thump.") | |
>> moveTo Nixon Garden) | |
-- Grue logic. | |
(flip when) (output "You are eaten by a grue." >> (exitAdventure "Being Eaten by a Ravenous Grue")) | |
=<< (use gruesome <&&> (not <$> hasLight)) | |
(flip when) (gruesome .= True) =<< (not <$> hasLight) | |
(flip when) (gruesome .= False) =<< hasLight | |
turns %= succ | |
(flip unless) (input >>= parser . normalize) =<< use exit | |
-- From a place and an action to a state change. | |
adventure :: Thing -> Action -> Game () | |
adventure _ (Action Exit _ _) = | |
exitAdventure "Quitting the Game" | |
adventure loc (Action Look Nothing Nothing) = | |
lookAtRoom loc | |
adventure _ (Action Look (Just Bag) _) = do | |
bag <- contents Bag | |
output (description Bag) | |
if (null bag) | |
then (output "The bag is empty.") | |
else (output ("The bag contains " ++ englishList bag ++ ".")) | |
adventure _ (Action Look (Just Lantern) _) = | |
output (description Lantern) | |
>> ifHasFlag Lit Lantern | |
(output "The lantern is lit, a flickering flame dancing inside the glass housing.") | |
(output "The lantern is unlit, providing no light.") | |
adventure _ (Action Look (Just thing) _) = output (description thing) | |
adventure _ (Action Drag (Just thing) _) = beginDragging thing | |
adventure _ (Action Release _ _ ) = stopDragging | |
adventure _ (Action Take (Just thing) (Just Bag)) = | |
ifIsIn thing Bag | |
(pickUp thing >> output ("You get the " ++ name thing ++ " from the bag.")) | |
(output "There's nothing like that in the bag.") | |
adventure _ (Action Take (Just _) (Just thing)) = | |
ifPlayerHas thing | |
(output "That's not a container.") | |
(output "You don't see that here.") | |
adventure loc (Action Take (Just Nixon) _) = | |
output "Much too unwieldy and heavy to carry. At most, you could drag it around." | |
adventure loc (Action Take (Just thing) _) = | |
ifIsIn thing loc | |
(pickUp thing >> output (actionDescribe "pick up" thing)) | |
(output "You don't see that here.") | |
adventure _ (Action Drop (Just thing) _) = | |
ifPlayerIsDragging thing | |
stopDragging | |
(ifPlayerHas thing | |
(dropThing thing >> output (actionDescribe "drop" thing)) | |
(output "You are not carrying that.")) | |
adventure _ (Action Put (Just Bag) (Just Bag)) = | |
output "Now that's quite a feat!" | |
adventure _ (Action Put (Just Player) (Just Bag)) = | |
output "The bag is far too small for you to climb inside of it." | |
adventure _ (Action Put (Just Sword) (Just Bag)) = | |
output "You would cut the bag if you put the sword in it." | |
adventure _ (Action Put (Just thing) (Just Bag)) = | |
output ("You toss the " ++ name thing ++ " into the bag.") >> moveTo thing Bag | |
adventure _ (Action Inventory _ _) = do | |
pockets <- inventory | |
if (null pockets) | |
then output "Your pockets are empty." | |
else output ("You are carrying " ++ englishList pockets ++ ".") | |
adventure _ (Action Use (Just Sword) Nothing) = | |
output "You balance the sword in your hand and give it a few light swings." | |
adventure _ (Action Use (Just Sword) (Just Player)) = | |
output "Attacking yourself with the sword would achieve little." | |
adventure _ (Action Use (Just Sword) (Just a)) = | |
output ("Attacking the " ++ name a ++ " with the sword would achieve little.") | |
adventure _ (Action Use (Just Bag) Nothing) = | |
output "A bag is generally used by putting things inside of it." | |
adventure _ (Action Use (Just Lantern) _) = | |
ifHasFlag Lit Lantern | |
(output (actionDescribe "extinguish" Lantern) >> unsetFlag Lit Lantern) | |
(output (actionDescribe "light" Lantern) >> setFlag Lit Lantern) | |
adventure _ (Action Light (Just Lantern) _) = | |
ifHasFlag Lit Lantern | |
(output "The lantern is already lit.") | |
(output (actionDescribe "light" Lantern) >> setFlag Lit Lantern) | |
adventure _ (Action Extinguish (Just Lantern) _) = | |
ifHasFlag Lit Lantern | |
(output (actionDescribe "extinguish" Lantern) >> unsetFlag Lit Lantern) | |
(output "The lantern isn't lit.") | |
-- Generic movement logic. -- | |
adventure loc (Action GoEast _ _) = tryWalk loc east | |
adventure loc (Action GoNorth _ _) = tryWalk loc north | |
adventure loc (Action GoWest _ _) = tryWalk loc west | |
adventure loc (Action GoSouth _ _) = tryWalk loc south | |
adventure loc (Action GoDown _ _) = tryWalk loc down | |
adventure loc (Action GoUp _ _) = tryWalk loc up | |
adventure _ _ = output "I don't know how to do that." | |
-- Init and IO functions. -- | |
output :: String -> Game () | |
output str = liftIO (putStrLn str >> putStrLn "" >> hFlush stdout) | |
input :: Game String | |
input = liftIO (putStr "> " >> hFlush stdout >> getLine) | |
normalize :: String -> String | |
normalize = fmap Char.toLower . filter Char.isAscii | |
parser :: String -> Game () | |
parser str = ((\reach -> eitherMaybe (runParser parseCommand reach "" str)) <$> visibility) >>= tick | |
game :: Game () | |
game = (flip unless) time =<< use exit | |
tick :: Maybe Action -> Game () | |
tick Nothing = output "I don't understand that." >> input >>= parser . normalize | |
tick (Just action) = location Player >>= (flip adventure) action >> game | |
printScore :: GameState -> IO () | |
printScore state = do | |
putStrLn (take 80 $ repeat '+') | |
putStrLn ("ENDED GAME AT TURN " ++ show (_turns state) ++ ".") | |
putStrLn ("DUE TO: " ++ _endReason state ++ ".") | |
putStrLn (take 80 $ repeat '+') | |
main :: IO () | |
main = execStateT game initialGameState >>= printScore |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment