Haskell Text-Adventure Game

Question

I just started making a text adventure game in Haskell. Because this is the largest project I have done in Haskell, I wanted to ask about it here before I got too far on it. I am still pretty new to Haskell, so I would really appreciate any advice at all on how this could be improved.

To compile the game, I just used ghc Main.

Here is my code:

Main.hs

import System.IO (hFlush, stdout)
import Control.Monad (unless, when, guard)
import Control.Applicative ((<|>), (<*>))
import Data.Maybe (fromMaybe, isJust, fromJust)
import Control.Monad.State
import Data.Char (isSpace)

import Room (Room)
import qualified Room as Room
import Game (Game, GameState)
import qualified Game as Game
import Direction

import Item (Item)
import qualified Item as Item

type GameResponse = IO (String, Game)

trim :: String -> String
trim = foldr pickChars []
  where
    pickChars ' ' (' ':xs) = ' ':xs
    pickChars c1 (x:xs)  = c1:x:xs
    pickChars c1 [] = [c1]

travel :: Direction -> GameState
travel d = state $ \g -> fromMaybe ("You can't go that way.", g)
  (flip runState g . Game.enterRoom <$>
    Room.roomInDirection d (Game.currentRoom g))

main = do
  (msg, _) <- play . return $ runState Game.initGame Game.gameData
  putStrLn msg

play :: GameResponse -> GameResponse
play x = do
  (msg, gameData) <- x
  unless (null msg) $ putStrLn msg >> putStrLn ""
  putStr "> "
  hFlush stdout
  response <- trim <$> getLine
  if response `elem` ["q", "quit"]
    then return ("Adiós!", gameData)
    else play . return $ runState (exec response) gameData

exec :: String -> GameState
exec "look" = state $ \g -> (Room.nameWithDescription $ Game.currentRoom g, g)
exec s
  | isJust direction = travel (fromJust direction)
  | take 4 s == "take" || take 3 s == "get" = Game.takeItem s
  | s `elem` ["i", "inv", "inventory"] = Game.displayInv
  | s `elem` [" ", ""] = return ""
  | otherwise = return "What?"
  where
    direction = directionFromString s

Direction.hs

module Direction
( Direction(..)
, directionFromString
) where

import Data.Char (toLower)

data Direction = North | NorthEast | East | SouthEast 
               | South | SouthWest | West | NorthWest
               deriving (Show, Eq, Ord)

directionFromString :: String -> Maybe Direction
directionFromString s
  | d `elem` ["n", "north"] = return North
  | d `elem` ["ne", "northeast", "north east"] = return NorthEast
  | d `elem` ["e", "east"] = return East
  | d `elem` ["se", "southeast", "south east"] = return SouthEast
  | d `elem` ["s", "south"] = return South
  | d `elem` ["sw", "southwest", "south west"] = return SouthWest
  | d `elem` ["w", "west"] = return West
  | d `elem` ["nw", "northwest", "north west"] = return NorthWest
  | otherwise = Nothing
  where d = map toLower s    

Room.hs

module Room
( Room(..)
, roomInDirection
, look
, nameWithDescription
, removeItem
, findItem
) where

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.List (find, isInfixOf, delete)

import Direction

import Item (Item)
import qualified Item as Item

data Room = Room
  { name :: String
  , description :: String
  , directions :: Map Direction String
  , visited :: Bool
  , items :: [Item]
  } deriving (Show, Eq)

roomInDirection :: Direction -> Room -> Maybe String
roomInDirection d r = Map.lookup d (directions r)

nameWithDescription :: Room -> String
nameWithDescription r = name r ++ '\n':(description r)

look :: Room -> IO ()
look = putStrLn . nameWithDescription

findItem :: String -> Room -> Maybe Item
findItem n = find (\i -> isInfixOf (Item.name i) n) . items

removeItem :: Item -> Room -> Room
removeItem i r = r { items = delete i (items r) }

Item.hs

module Item 
( Item(..)
) where

data Item = Item
  { name :: String
  } deriving (Show, Eq)

Game.hs

module Game 
( Game(..)
, GameState
, find
, enterRoom
, gameData
, initGame
, takeItem
, displayInv
) where

import Data.Map.Strict (Map, (!))
import qualified Data.Map.Strict as Map
import Control.Monad.State
import Data.Maybe (fromMaybe)

import Direction

import Item (Item)
import qualified Item as Item

import Room (Room)
import qualified Room as Room

type GameState = State Game String

data Game = Game
  { currentRoom :: Room
  , roomMap :: Map String Room
  , inventory :: [Item]
  } deriving Show

gameData = Game { roomMap = Map.fromList
  [("corridor",
    Room.Room { Room.name = "Corridor"
         , Room.description = "ayyyy"
         , Room.directions = Map.fromList [
             (North, "dining hall") ]
         , Room.visited = False
         , Room.items = []
        })
  ,("dining hall",
    Room.Room { Room.name = "Dining Hall"
         , Room.description = "good food is here"
         , Room.directions = Map.fromList [
             (South, "corridor") ]
         , Room.visited = False
         , Room.items = [
             Item.Item { Item.name = "apple" } ]
         })
  ]
  , currentRoom = undefined
  , inventory = []
  }

find :: String -> Game -> Room
find n g = (roomMap g) ! n

enterRoom :: String -> GameState
enterRoom n =
  state $ \g ->
    (msg g
    , g { roomMap = Map.update (\x -> Just (x { Room.visited = True })) n (roomMap g),
       currentRoom = r g })
  where 
    r g = find n g
    msg g
      | Room.visited (r g) = Room.name (r g)
      | otherwise = Room.nameWithDescription (r g)

initGame :: GameState
initGame = enterRoom "corridor"

removeItemFromCurrentRoom :: Item -> GameState
removeItemFromCurrentRoom i = state $ \g ->
  ("Taken!", g { currentRoom = Room.removeItem i (currentRoom g), inventory = i:(inventory g) })

takeItem :: String -> GameState
takeItem n = state $ \g -> fromMaybe ("Item not found", g)
  (flip runState g . removeItemFromCurrentRoom
    <$> Room.findItem n (currentRoom g))

displayInv :: GameState
displayInv = state $ \g -> (safeInit . unlines . fmap Item.name . inventory $ g , g)
  where safeInit [] = []
        safeInit xs = init xs

Answer 1

The last two lines of pickChars collapse to pickChars c xs = c:xs. trim = unwords . words may be to your liking.

StateT can handle play's state-passery, but you'll have to redefine GameState as Monad m => StateT Game m String to allow play's IO actions.

main = putStrLn =<< evalStateT (Game.initGame >>= play) Game.gameData

play :: StateT Game IO String
play msg = do
  unless (null msg) $ putStrLn msg >> putStrLn ""
  putStr "> "
  hFlush stdout
  response <- trim <$> getLine
  if response `elem` ["q", "quit"]
    then return "Adiós!"
    else exec response >>= play

exec "look" = gets $ Room.nameWithDescription . Game.currentRoom

| Just direction <- directionFromString s = travel direction

You don't seem to be using State's monad instance. State's purpose is for you to not need to pass gamestates around manually! Doing state $ \s -> runState everywhere misses the point.

lens can help with nested data structures. An example:

data Room = Room
  { _name :: String
  , _description :: String
  , _directions :: Map Direction String
  , _visited :: Bool
  , _items :: [Item]
  } _deriving (Show, Eq)

makeFields ''Room

find :: String -> Lens' Game Room
find n = roomMap . singular (ix n)

enterRoom :: String -> GameState
enterRoom n = do
  r <- use $ find n
  v <- find n . Room.visited <<.= True
  currentRoom .= r
  return $ r ^. if v then Room.name else Room.nameWithDescription

Note that currentRoom is the version of r that does not have its visited set to True yet. This could have been averted if currentRoom merely contained the room's name.

The recommendation to use abstractions theoretically also goes for travel, but what's needed here isn't available in the common libraries. Using my package prototype pointed-alternative and missing StateT combinator getsT:

travel :: Direction -> GameState
travel d = ascertain "You can't go that way."
  $ Game.enterRoom
  =<< getsT (Room.roomInDirection d . Game.currentRoom)