A minimalist text adventure

Adventure.hs

module Adventure where

import Control.Monad.State
import Data.Char
import Data.List
import System.IO

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

-- TODO (james): newtype wrapper for Room titles
data Exit
  = Exit
  { exitTitle  :: String
  , exitGoesTo :: String
  -- ^ the room title that this leads to
  }
  deriving (Eq, Show)

data Room
  = Room
  { roomTitle       :: String
  , roomDescription :: String
  , roomItems       :: [Item]
  , roomExits       :: [Exit]
  }
  deriving (Eq, Show)

frontHall :: Room
frontHall
  = Room
  { roomTitle       = "Front Hall"
  , roomDescription = "The lights are off and it is dark."
  , roomItems       = [Item "Candle" "An unlit candle", Item "Shoes" "A pair of plain brown shoes"]
  , roomExits       = [Exit "Front Door" "Porch"]
  }

porch :: Room
porch
  = Room
  { roomTitle       = "Porch"
  , roomDescription = "It is dark and rainy but you are safe under the gable."
  , roomItems       = []
  , roomExits       = [Exit "Front Door" "Front Hall"]
  }

type House = [(String, Room)]

house :: House
house = [("Front Hall", frontHall), ("Porch", porch)]

showRoom :: Room -> String
showRoom r =
  "=== " ++ title
  ++ "\n\n\t"
  ++ desc ++ "\n\nYou see here: "
  ++ intercalate ", " (map itemName items)
  ++ "\n\nExits: "
  ++ intercalate ", " (map exitTitle exits)
  where
    title = roomTitle r
    desc = roomDescription r
    items = roomItems r
    exits = roomExits r

findRoom :: String -> House -> Maybe Room
findRoom = lookup

data GameState
  = GameState
  { gameStateRoom          :: String
  , gameStateMap           :: House
  , gameStateErrorMessages :: [String]
  }
  deriving (Eq, Show)

go :: String -> State GameState Room
go exitName = do
  s@(GameState currentRoom gameMap errs) <- get
  let (Just currentRoom') = findRoom currentRoom gameMap
  case find (\e -> exitTitle e == exitName) (roomExits currentRoom') of
    Just (Exit _ roomName) ->
      case findRoom roomName gameMap of
        Just room -> do
          put s { gameStateRoom = roomName }
          pure room
    Nothing -> do
      put s { gameStateErrorMessages = ((gameStateErrorMessages s) ++ ["I can't find that exit..."]) }
      pure currentRoom'

displayErr :: String -> State GameState ()
displayErr err = do
  s@(GameState _ _ errs) <- get
  put $ s { gameStateErrorMessages = err : errs }

render :: GameState -> IO ()
render (GameState roomName gameMap errs) = do
  let (Just room) = findRoom roomName gameMap
  putStrLn $ intercalate "\n" (reverse errs)
  putStrLn $ showRoom room

readInput :: IO String
readInput = do
  putStr "> "
  hFlush stdout
  getLine

data Command
  = Quit
  | Go String
  | Unknown
  deriving (Eq, Show)

parseCommand :: String -> Command
parseCommand "QUIT" = Quit
parseCommand input =
  if isPrefixOf "go " input
  then Go (tail $ snd $ break isSpace input)
  else Unknown

gameLoop :: GameState -> IO ()
gameLoop game = do
  render game
  input <- readInput
  case parseCommand input of
    Quit -> pure ()
    Go exit -> do
      putStrLn exit
      gameLoop $ execState (go exit) game
    Unknown -> gameLoop $ execState (displayErr "What do you mean?") game

main :: IO ()
main = do
  let game = GameState "Front Hall" house []
  gameLoop game