Text exploration game

Adventure.hs

{-# LANGUAGE OverloadedStrings #-}

-- Oh boy did I make a mess of this. Tried to add a way to import an external file of places
-- using JSON (thanks to Zach from Hacker School!!!) but the nested objects make it kind 
-- of difficult. Right now the exits are just a string but I would like it to be a nested
-- JSON object. But I really don't understand how that works, so it's a string of JSON, 
-- which is super ugly. But it compiles!! 

module Main where

import Control.Applicative
import Control.Monad as M
import Data.Graph.Inductive
import Data.Char (toLower)
import Data.Map (Map, fromList, findWithDefault)
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Maybe (fromMaybe)
import qualified Data.Text as T



data Place =  Place String String
instance Show Place where
    show (Place name desc) = name ++ "\n" ++ desc

-- Lets do this JSON style

data JPlace =  JPlace { num   :: Int
                      , name  :: String
                      , desc  :: String
                      , exits :: String
                      }
instance Show JPlace where
    show (JPlace _ name desc _) = name ++ "\n" ++ desc
instance FromJSON JPlace where
    parseJSON (Object v) = JPlace <$>
                           (v .: "num")  <*>
                           (v .: "name") <*>
                           (v .: "desc") <*>
                           (v .: "exits")
    parseJSON _          = M.mzero


defaultPlaces s = [JPlace 1 "Failure" s []]

data JExit = JExit { dir  :: String
                   , node :: Int } deriving Show
instance FromJSON JExit where
    parseJSON (Object v) = JExit <$>
                           (v .: "dir")  <*>
                           (v .: "node")
    parseJSON _          = M.mzero
    
defaultExit = JExit "" 1

jsonFile :: FilePath
jsonFile = "places.json"

listPlaces :: [JPlace] -> [(Int, JPlace)]
listPlaces []     = []
listPlaces (x:xs) = (num x, x) : listPlaces xs

--listExits :: Int -> [JExit] -> [(Int, Int, String)]
--listExits _ []     = []
--listExits p (x:xs) = (p, node x, dir x) : listExits p xs

--SOOOOO we've got a list of Places which contain an !Array which we need to decode

-- We want to end up with a list of all the exits for all the places, in edge format
listAllExits :: [JPlace] -> [[(Int, Int, String)]]
listAllExits x = map listExits x

listExits :: JPlace -> [(Int, Int, String)]
listExits x = map (toLedge (num x)) $ defExits $ maybeExits $ exits x

maybeExits :: String -> Maybe [JExit]
maybeExits x = decode (BS.pack x)

defExits :: Maybe [JExit] -> [JExit]
defExits x = fromMaybe [] x

toLedge :: Int -> JExit -> (Int, Int, String)
toLedge n x = (n, node x, dir x)

--listListsofExits :: [JPlace] -> [[(Int, Int, String)]]
--listListsofExits []     = []
--listListsofExits (x:xs) = listExits (num x) (exits x) : listListsofExits xs

--defaultGraph = (placeGraph [(1, JPlace 1 "" "" [JExit "" 1] )] [], "NOOOOOOO")

initGraph = do
    j <- BS.readFile jsonFile
    putStrLn "Read file okay!"
    let p = eitherDecode j :: Either String [JPlace]
    let makeGraph l = placeGraph (listPlaces l) (concat $ listAllExits l)
    let pl = either (defaultPlaces) (id) p
    let grph = makeGraph pl
    return grph

-- This turns the lists of nodes and list of edges into an inductive graph.
placeGraph :: [(Int, JPlace)] -> [(Int, Int, String)] -> Gr JPlace String
placeGraph = mkGraph

-- this maps all the things the player should be allowed to type in to the
-- directions on the edges
dictDirs :: Data.Map.Map String String
dictDirs =  fromList [("n", "North"),("s", "South"),("e", "East"), ("w", "West"),
                      ("north", "North"),("south", "South"),("east", "East"), ("west", "West"),
                      ("d", "Down"), ("down", "Down"), ("u", "Up"), ("up", "Up"),
                      ("xyzzy", "xyzzy")]
strToDir :: String -> String
strToDir dir = findWithDefault "error" (map toLower dir) dictDirs

-- "out" gives a list of edges that go out from a node. This folds a function
-- over the the list that looks at each edge and sees if it is going in the
-- same direction as the player wanted. If it's going in the right direction,
-- then that exit's node is the new node. Otherwise, it's the node stays the same.
tryExits :: String -> Node -> Gr JPlace String -> Node
tryExits exit node graph = foldr (tryEdge exit) node $ out graph node

tryEdge :: String -> LEdge String -> Node -> Node
tryEdge exit (_, newNode, label) oldNode | label == exit = newNode
                                         | otherwise     = oldNode

-- Shows description of a new place.
showDesc :: Node -> Gr JPlace String -> String
showDesc place graph = "\n" ++ (show $ lab' $ context graph place)

-- Shows why you're in the same place.
showError :: String -> String -> String
showError input dir | input == ""    = "Enter a direction, any direction."
                    | dir == "error" = "I don't know what \"" ++ input ++ "\" means."
                    | otherwise      = "You can't go that way."

loop :: Node -> Gr JPlace String -> IO ()
loop place grph = do
    putStrLn "\nWhere do you want to go? \nEnter a direction (e, w, n, s)"
    inputDir <- getLine
    let direction = strToDir inputDir
    let newPlace = tryExits direction place grph
    putStrLn $
        if place == newPlace then showError inputDir direction
        else                      showDesc newPlace grph
    loop newPlace grph

--main :: IO ()
main = do
    grph <- initGraph
    let startPlace = 1
    print $ lab' $ context grph startPlace
    loop startPlace grph

places.json

[{ "num": 1,
  "name": "A Cave", 
  "desc": "You are inside a deep, dark cave. The cave continues to the east. South is the exit.",
  "exits": "[{\"dir\": \"East\", \"node\": 1}, {\"dir\": \"South\", \"node\":1}]" }]