public
Created — forked from splinterofchaos/mapgen.hs

A simple roguelike map generator. Uses naiive splatter pattern to create rooms.

  • Download Gist
mapgen.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
-- based on https://gist.github.com/2874811
import System.Random
 
import System.Console.GetOpt
import System.Environment(getArgs, getProgName)
import Control.Monad.State
 
type Rand = State StdGen
rand m = do a <- state next
return (a `mod` m)
 
type Coord = (Int,Int)
type Range = (Int,Int)
type Area = (Coord,Coord) -- Upper-left and lower-right bounds.
 
data Tile = TFloor | TWall
instance Show Tile where
show TFloor = "."
show TWall = "#"
 
type MRow = [Tile]
type RMap = [MRow]
showMap :: RMap -> String
showMap = unlines . map (>>= show)
 
makeMap :: Coord -> RMap
makeMap (x,y) = replicate y (replicate x TWall)
 
splitGap :: Int -> Int -> [a] -> ([a],[a],[a])
splitGap start size lst = (before, middle, after)
where
(before,rest) = splitAt start lst
(middle,after) = splitAt (abs size) rest
 
digRow :: Range -> MRow -> MRow
digRow (start,end) row =
before ++ replicate size TFloor ++ after
where
size = end - start + 1
(before,_,after) = splitGap start size row
 
digRoom :: RMap -> Area -> RMap
digRoom rmap ((x,y),(u,v)) =
ybefore ++ map (digRow (x,u)) rows ++ yend
where
(ybefore,rows,yend) = splitGap y (v-y+1) rmap
 
randomRoom :: Coord -> Rand Area
randomRoom (w,h) = do
(x,u) <- gen_range w
(y,v) <- gen_range h
return ((x,y),(u,v)) -- Note the reordering of xuyv to xyuv.
where
minlen = 3
gen_range m = do
a <- rand (m-minlen-1)
let a' = a + 1
brange = m - a' - minlen
b <- rand (max 1 brange)
let b' = b + a' + minlen - 1
return (a',b')
randomPoint :: Area -> Rand Coord
randomPoint ((x,y),(u,v)) =
do x' <- rand (u-x+1)
y' <- rand (v-y+1)
return (x' + x, y' + y)
 
digHallway :: RMap -> Area -> RMap
digHallway m ((x,y),(u,v)) = foldl digRoom m
-- Dig from (x,y) to (u,y) to (u,v).
[((u,min y v),(u,max y v)),((min x u,y),(max x u,y))]
 
digRandomHallways :: RMap -> [Area] -> Rand RMap
digRandomHallways m rooms
| length rooms < 2 = return m
| otherwise =
do n <- rand (length $ tail rooms)
end1 <- randomPoint (head rooms)
end2 <- randomPoint (tail rooms!!n)
let m' = digHallway m (end1, end2)
digRandomHallways m' (tail rooms)
splatter :: Int -> RMap -> Rand RMap
-- Splatter n random rooms onto m.
splatter n m =
do rooms <- replicateM n $ randomRoom (length (head m),length m)
digRandomHallways (foldl digRoom m rooms) rooms
where
center ((x,y),(u,v)) = ((x+u) `quot` 2, (y+v) `quot` 2)
data Options = Options {optRooms::Int,optDimensions::Coord}
 
defaults :: Options
defaults = Options {optRooms=5,optDimensions=(80,60)}
 
options =
[Option "n" ["rooms"]
(ReqArg (\s op-> return op{optRooms=read s::Int}) "ROOMS")
"Number of rooms to dig.",
Option "d" ["dimensions"]
(ReqArg (\s op-> case reads s :: [(Coord,String)] of
((dims,_):_) ->
return op { optDimensions = dims }
_ -> error "Dimensions must be in format (width,height)")
"DIMENSIONS")
"Dimensions of map."]
 
main = do
-- Parse command line.
argv <- getArgs
let (actions,noops,msgs) = getOpt RequireOrder options argv
ops <- foldl (>>=) (return defaults) actions
let Options { optRooms=rooms, optDimensions=dimensions } = ops
gen <- newStdGen
putStrLn . showMap $ evalState (splatter rooms $ makeMap dimensions) gen

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.