adventure.hs

{-# 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