{-
Problem:
Create a map of conencted rooms.
Requirements:
(a) You can get from any room to any other.
(b) Room has between 0 to 4 doors.
(c) No door leads to 'abyss'.
Background:
This project was needed for a simple (up to 16) room-map for a game.
Solution:
The algorithm here would be referred to as 'brute force'.
We solve it recursively, by adding one room at a time.
We start with one room with no doors.
The function that ADDS a room works as follows:
1. enumerate all the possible room locations: Those that are neighbours to existing rooms,
and do not overlap with existing rooms.
2. Randomly choose one of these locations.
3. Add door(s) to conenct it to the rest of the rooms. Right now: Just add a door to the
room itself, and one of it's neighbours.
I also used SVG to demonstrate creating graphics in the browser using text-strings.
----
Note I: This solution is very verbose, including debug statements and all.
It was passed to a student who does-not know Haskell, and was implemented
later on in Objective-C.
Note II: VERY not optimized, nor full. For example, can use list of available spots and update it.
Example: opens only one-door to one neighbour.
-}
module Main where
-- Random
import System.Random (getStdRandom, randomR)
import System.IO.Unsafe (unsafePerformIO)
-- Debug
import Debug.Trace
-- types and data
type Loc = (Int,Int)
data Room = Room {
rId :: Int,
rLoc :: Loc,
rDoors :: [Bool] -- NSEW
}
instance Show Room where
show r = "(" ++ show (rId r) ++ " , Location:" ++ (show (rLoc r) )++
"Doors at (NSEW): " ++ show (rDoors r) ++ ")\n"
-- initlaize and helpers
numberOfRooms = 1000 ::Int
noDoors = [False,False,False,False]
outfln = "rooms.html"
-- main
main :: IO()
main = do
let mapRooms = createMap numberOfRooms []
print mapRooms
let svgImg = roomsToSVG mapRooms
writeFile outfln svgImg
-- functions
-- Create map: how many rooms to add, and current list of rooms. Returns
-- new list of rooms.
createMap :: Int -> [Room] -> [Room]
createMap 0 rs = rs -- no more rooms to add
createMap n [] = createMap (n-1) [Room 0 (0,0) noDoors ] -- Adding first room!
createMap n rs = createMap (n-1) (addRoom rs) -- Adding a room
-- adding a single room:
addRoom :: [Room] -> [Room]
addRoom rs = newRs
where
candidateLocs = freeNeighbours rs
locChosen = chooseOne candidateLocs
newRs = addDoors rs locChosen
freeNeighbours :: [Room] -> [Loc]
freeNeighbours rs = removeExisting rs (allPossibleNeighbours rs)
allPossibleNeighbours :: [Room] -> [Loc]
allPossibleNeighbours [] = []
allPossibleNeighbours (r:rs) = (createFourRooms r ) ++ (allPossibleNeighbours rs)
createFourRooms :: Room -> [Loc]
createFourRooms r = [rN,rS,rE,rW]
where
(x,y) = rLoc r
rN = (x,y+1)
rS = (x,y-1)
rE = (x+1,y)
rW = (x-1,y)
removeExisting :: [Room] -> [Loc] -> [Loc]
removeExisting rs locs = removeExisting' locRooms locs
where
locRooms = map (\x -> (rLoc x)) rs
removeExisting' :: [Loc] -> [Loc] -> [Loc]
removeExisting' locRooms [] = []
removeExisting' locRooms (loc:locs) = ll ++ (removeExisting' locRooms locs)
where
ll = if (loc `elem` locRooms) then [] else [loc]
-- removing duplicate
-- removeExisting rs locs =
-- foldl (\seen x -> if x `elem` seen then seen else seen ++[x]) [] locs
chooseOne :: [Loc] -> Loc
chooseOne locs = locs !! randOne
where
randOne = (dieRoll (length(locs)) ) -1
--chooseOne locs = head (locs)
-- We need to add doors to the current new-room,
-- and to it's neighbour(s) in the already
-- existing list.
-- Right now, only adding one door to one-neighbour.
addDoors :: [Room] -> Loc -> [Room]
addDoors rs loc = rnew' : r1' :rs'
where
rnew = Room 0 loc noDoors
r1 = findNeighbour rnew rs
rnew' = addDoor rnew r1
r1' = addDoor r1 rnew
rs' = removeRoom rs r1
findNeighbour :: Room -> [Room] -> Room
findNeighbour rnew (r:rs) = if (neighbour rnew r) then r else findNeighbour rnew rs
neighbour :: Room -> Room -> Bool
neighbour r1 r2 = if nsew then True else False
where
x1 = fst $ rLoc r1
y1 = snd $ rLoc r1
x2 = fst $ rLoc r2
y2 = snd $ rLoc r2
nsew = (x1==x2 && y1==y2+1) || (x1==x2 && y1==y2-1) ||
(x1==x2+1 && y1==y2) || (x1==x2-1 && y1==y2)
addDoor :: Room -> Room -> Room
addDoor r1 r2
| (x1==x2 && y1==y2+1) = r1 {rDoors = (head iDoors : True : (drop 2 iDoors) )} -- y1 is North
| (x1==x2 && y1==y2-1) = r1 {rDoors = (True : (drop 1 iDoors) ) } -- y1 is South
| (x1==x2+1 && y1==y2) = r1 {rDoors = ((take 3 iDoors) ++ [True] ) } -- x1 is East
| (x1==x2-1 && y1==y2) = r1 {rDoors = ((take 2 iDoors) ++ [True] ++ (drop 3 iDoors)) } --x1 is West
where
x1 = fst $ rLoc r1
y1 = snd $ rLoc r1
x2 = fst $ rLoc r2
y2 = snd $ rLoc r2
iDoors = rDoors r1
removeRoom :: [Room] -> Room -> [Room]
removeRoom rs r = filter (\x -> (rLoc x) /= loc) rs
where
loc = rLoc r
-- Standard way of getting a random integer number in range [1,sides]
dieRoll :: Int -> Int
dieRoll sides =
let retval = unsafePerformIO roll_a_die
roll_a_die = getStdRandom $ randomR (1, sides)
msg = show (sides, retval)
in trace msg retval
roomsToSVG :: [Room] -> String
roomsToSVG rs = headerStr ++ str1 ++ footerStr
where
headerStr = "

Room SVG

"
roomToSVG :: String -> Room -> String
roomToSVG str r = str ++ strC ++ strN ++ strS ++ strE ++ strW
where
x = fst (rLoc r)
y = snd (rLoc r)
rr = rDoors r
strC = svgCircle x y
strN = if (rr!! 0) then (svgLine x y (fromIntegral x) ((fromIntegral y)+0.5)) else ""
strS = if (rr!! 1) then (svgLine x y (fromIntegral x) ((fromIntegral y)-0.5)) else ""
strE = if (rr !! 2) then (svgLine x y ((fromIntegral x)+0.5) (fromIntegral y)) else ""
strW = if (rr !! 3) then (svgLine x y ((fromIntegral x)-0.5) (fromIntegral y)) else ""
scale = 10 :: Double
offset = 300 :: Double
svgCircle :: Int->Int->String
svgCircle x y = ""
where
x'=(fromIntegral x)*scale + offset
y'=(fromIntegral y)*scale + offset
svgLine :: Int -> Int -> Double -> Double -> String
svgLine x y w z = ""
where
x'=(fromIntegral x)*scale + offset
y'=(fromIntegral y)*scale + offset
w'=w*scale + offset
z'=z*scale + offset
-- end