RCRPG/Haskell

From Rosetta Code
RCRPG/Haskell is part of RCRPG. You may find other members of RCRPG at Category:RCRPG.

This Haskell version of RCRPG is based on the Python implementation, and is undoubtedly ugly. Someone should probably clean it up.

Code

import Char (toLower)
import qualified Data.Map as Map
import qualified Data.List as List
import qualified System.Random as Random
import Data.Maybe (fromJust, isJust, isNothing)

strToLower :: String -> String
strToLower = map toLower

join :: [String] -> String
join [] = ""
join [x] = x
join (x:xs) = x ++ ", " ++ join xs

maybeToList :: Maybe a -> [a]
maybeToList Nothing = []
maybeToList (Just a) = [a]

addTripple :: (Int,Int,Int) -> (Int,Int,Int) -> (Int,Int,Int)
addTripple (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)

directions = Map.fromList [
				("north", (0,-1,0)),
				("east",  (1,0,0) ),
				("south", (0,1,0) ),
				("west",  (-1,0,0)),
				("up",    (0,0,1) ),
				("down",  (0,0,-1))]
				
directionOpposites = Map.fromList [
				("north", "south"),
				("east",  "west" ),
				("south", "north"),
				("west",  "east" ),
				("up",    "down" ),
				("down",  "up"   )]

data World = World {
	aliases :: AliasMap,
	roomNames :: RoomNameMap,
	rooms :: RoomMap,
	currentPos :: (Int,Int,Int),
	inventory :: [String],
	equipped :: String,
	itemGen :: ItemGenerator
	}
newWorld x = World {aliases = newAliasMap, roomNames = newRoomNameMap, rooms = newRooms, currentPos = (0,0,0), inventory = [], equipped = "", itemGen = x}
instance Show World where
	show world = let
		thisRoom = fromJust $ Map.lookup (currentPos world) (rooms world); --Potential error point
		locationName = if (isNothing $ Map.lookup (currentPos world) (roomNames world))
			then show (currentPos world)
			else fromJust $ Map.lookup (currentPos world) (roomNames world);
		itemsText = if (null $ roomItems thisRoom) then "" else "\nOn the ground you can see: "++join (roomItems thisRoom);
		exits = map (fst) $ filter (snd) (Map.toList $ passages thisRoom);
		exitsText = if (null exits) then "None" else join exits;
		in "\nYou are at " ++ locationName ++ itemsText ++ "\nExits are: " ++ exitsText

data Room = Room { passages :: PassageMap, roomItems :: [String] } deriving Show
newRoom x = Room {passages = Map.fromList(zip (Map.keys directions) (take 6 $ repeat False)), roomItems = x}

data ItemGenerator = ItemGenerator Random.StdGen
instance Show ItemGenerator where show gen = "ItemGen"
generateItems :: ItemGenerator -> ([String], ItemGenerator)
generateItems (ItemGenerator rand) = let results = Random.randomR (0,3) rand in (itemList !! (fst results), ItemGenerator (snd results))
itemList = [[],["sledge"],["ladder"],["gold"]]

type PassageMap = Map.Map String Bool

type RoomMap = Map.Map (Int,Int,Int) Room
newRooms = Map.fromList [((0,0,0), newRoom ["sledge"])]

type AliasMap = Map.Map String [String]
newAliasMap = Map.fromList [
	("north", ["move","north"]),
	("south", ["move","south"]),
	("east",  ["move","east"]),
	("west",  ["move","west"]),
	("up",    ["move","up"]),
	("down",  ["move","down"])
	]
	
type RoomNameMap = Map.Map (Int,Int,Int) String
newRoomNameMap = Map.fromList [((0,0,0),"the starting room"),((1,1,5),"the prize room")]

replaceAliases :: [String] -> World -> [String]
replaceAliases [] world = []
replaceAliases (t:ts) world = let results = Map.lookup t (aliases world)
	in if (isJust results && fromJust results !! 0 /= t)
		then replaceAliases (fromJust results ++ ts) world
		else (t:ts)

changeWorld :: [String] -> World -> (String, World)
changeWorld (t:ts) world = let results = Map.lookup t commandMap 
	in if (isJust results)
		then fromJust results ts world
		else ("Command not found.",world)
	
commandMap :: Map.Map String ([String] -> World -> (String, World))
commandMap = Map.fromList [("move",actMove),("alias", actAlias),("inventory", actInventory),("take", actTake),
	("drop", actDrop),("equip", actEquip),("unequip", actUnequip),("name", actName),("dig", actDig)]
	
actAlias :: [String] -> World -> (String, World)
actAlias (t:ts) world = ("Alias created.", world {aliases = (Map.insert t ts (aliases world))} )
	
actInventory :: [String] -> World -> (String, World)
actInventory tokens world = let
	carry = if (null $ inventory world)
		then "You aren't carrying anything."
		else "Carrying: " ++ join (inventory world);
	hold = if (null $ equipped world)
		then ""
		else "\nHolding: " ++ equipped world
	in (carry ++ hold, world)
	
actTake :: [String] -> World -> (String, World)
actTake tokens world = let
	oldRoom = fromJust $ Map.lookup (currentPos world) (rooms world); --Potential error point
	grabbed = if (tokens == ["all"])
		then roomItems oldRoom
		else maybeToList $ List.find (==(unwords tokens)) (roomItems oldRoom);
	changedInventory = (inventory world) ++ grabbed;
	changedRoom = Room (passages oldRoom) ((roomItems oldRoom) List.\\ grabbed);
	changedRooms = Map.insert (currentPos world) changedRoom (rooms world);
	changedWorld = if (null grabbed) then world else world{rooms = changedRooms, inventory = changedInventory};
	message = if (null grabbed)
		then if (tokens == ["all"])
			then "There is nothing in the room to take."
			else "Item not found."
		else if (tokens == ["all"])
			then "You now have everything in the room."
			else "Taken.";
	in (message, changedWorld)

actDrop :: [String] -> World -> (String, World)
actDrop tokens world = let
	oldRoom = fromJust $ Map.lookup (currentPos world) (rooms world); --Potential error point
	dropped = if (tokens == ["all"])
		then inventory world
		else maybeToList $ List.find (==(unwords tokens)) (inventory world);
	changedInventory = (inventory world) List.\\ dropped;
	changedRoom = Room (passages oldRoom) ((roomItems oldRoom) ++ dropped);
	changedRooms = Map.insert (currentPos world) changedRoom (rooms world);
	changedWorld = if (null dropped) then world else world{rooms = changedRooms, inventory = changedInventory};
	message = if (tokens == ["all"])
		then "Everything dropped."
		else if (null dropped)
			then "Could not find item in inventory."
			else "Dropped."
	in (message, changedWorld)

actEquip :: [String] -> World -> (String, World)
actEquip tokens world = let
	actEquipped = List.find (==(unwords tokens)) (inventory world);
	actUnequipped = if (isJust actEquipped && equipped world /= "") then [equipped world] else [];
	changedEquipped = fromJust actEquipped --Potential error point
	changedInventory = ((inventory world) List.\\ [(unwords tokens)]) ++ actUnequipped;
	changedWorld = if (isNothing actEquipped) then world else world{inventory = changedInventory, equipped = changedEquipped};
	message = if (isJust actEquipped)
		then "Equipped "++ fromJust actEquipped ++"."
		else "You aren't carrying that."
	in (message, changedWorld)

actUnequip :: [String] -> World -> (String, World)
actUnequip tokens world = let
	actUnequipped = if (equipped world /= "") then [equipped world] else [];
	changedInventory = (inventory world) ++ actUnequipped;
	changedWorld = if (null actUnequipped) then world else world{inventory = changedInventory, equipped = ""};
	message = if (null actUnequipped)
		then "You aren't equipped with anything."
		else "Unequipped "++ head actUnequipped ++"."
	in (message, changedWorld)

actName :: [String] -> World -> (String, World)
actName tokens world = ( "Room renamed", world{roomNames = (Map.insert (currentPos world) (unwords tokens) (roomNames world))} )

actDig :: [String] -> World -> (String, World)
actDig tokens world = let
	direction = unwords tokens;
	isValidDirection = direction `Map.member` directions;
	thisRoom = fromJust $ Map.lookup (currentPos world) (rooms world); --Potential error point
	potentialExceptions = [
		((equipped world /= "sledge"), "You don't have a digging tool equipped."),
		((not isValidDirection), "That's not a direction."),
		((isValidDirection && fromJust (Map.lookup direction (passages thisRoom))), "Already a tunnel that way.")];
	exception = List.find (fst) potentialExceptions;
	in if (isJust exception)
		then ((snd $ fromJust exception), world)
		else ("You've dug a tunnel.", worldDig world direction)

worldDig :: World -> String -> World
worldDig world direction = let
	newRandom = generateItems $ itemGen world;
	randomItems = fst newRandom;
	newItemGen = snd newRandom;
	oppositeDirection = fromJust $ Map.lookup direction directionOpposites; --Possible error point
	destinationPos = (currentPos world) `addTripple` (fromJust (Map.lookup direction directions));
	currentRoom = fromJust $ Map.lookup (currentPos world) (rooms world);
	destinationLookup = Map.lookup destinationPos (rooms world);
	destinationRoom = if (isNothing destinationLookup)
		then newRoom randomItems
		else fromJust destinationLookup;
	newCurrentRoom = Room (Map.insert direction True (passages currentRoom)) (roomItems currentRoom);
	newDestinationRoom = Room (Map.insert oppositeDirection True (passages destinationRoom)) (roomItems destinationRoom);
	changedRooms = Map.insert (currentPos world) newCurrentRoom (Map.insert destinationPos newDestinationRoom (rooms world))
	in world{rooms = changedRooms, itemGen = newItemGen}
	
actMove :: [String] -> World -> (String, World)
actMove tokens world = let
	direction = unwords tokens;
	isValidDirection = direction `Map.member` directions;
	thisRoom = fromJust $ Map.lookup (currentPos world) (rooms world); --Potential error point
	potentialExceptions = [
		((not isValidDirection), "That's not a direction."),
		((isValidDirection && not (fromJust (Map.lookup direction (passages thisRoom)))), "Can't go that way."),
		((direction == "up" && isNothing (List.find (=="ladder") (roomItems thisRoom))), "You'll need a ladder in this room to go up.")];
	exception = List.find (fst) potentialExceptions;
	destinationPos = (currentPos world) `addTripple` (fromJust (Map.lookup direction directions));
	in if (isJust exception)
		then ((snd $ fromJust exception), world)
		else ("You go "++direction++".", world{currentPos = destinationPos})

takeInput :: World -> IO ()
takeInput world = do
	print world
	input <- getLine
	let tokens = replaceAliases (words $ strToLower input) world
	if (length tokens == 0)
		then takeInput world
		else
			if (tokens !! 0 == "quit")
				then return ()
				else do
					let update = changeWorld tokens world  -- Returns a tupple of the form (String, World)
					putStrLn $ fst update                  -- Report the results of the update
					takeInput (snd update)                 -- Continue game

main = do
	putStrLn "Welcome to the dungeon!\nGrab the sledge and make your way to room 1,1,5 for a non-existant prize!"
	rand <- Random.newStdGen
	takeInput $ newWorld (ItemGenerator rand)
	putStrLn "Thanks for playing!"
	junk <- getLine
	return ()