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

mapgen.hs

import System.Random

import System.Console.GetOpt
import System.Environment(getArgs, getProgName)

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 :: (RandomGen r) => r -> Coord -> Area
randomRoom gen (w,h) = 
  ((x',y'),(u',v')) -- Note the reordering of xuyv to xyuv.
  where 
    -- Here, x = n, so start with a random n.
    [x,y,u,v] = take 4 . map fst $ iterate (next.snd) (n,g)
    (n,g) = next gen

    (x',u') = to_range x u w
    (y',v') = to_range y v h
    to_range a b max = (a',b')
      where 
        minlen = 3
        a' = a `mod` (max-minlen-1) + 1
        brange = max - a' - minlen
        b' = (if brange > 0 then b `mod` brange else 0)
             + a' + minlen - 1
    
randomPoint :: RandomGen r => Area -> r -> Coord
randomPoint ((x,y),(u,v)) gen = 
  (x' `mod` (u-x+1) + x, y' `mod` (v-y+1) + y)
  where (x',g) = next gen
        (y',_) = next g

randomRooms :: RandomGen r => r -> Coord -> [Area]
randomRooms gen dims = randomRoom g1 dims : randomRooms g2 dims
  where (g1,g2) = split gen

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 :: RandomGen r => 
                     RMap -> r -> [Area] -> RMap
digRandomHallways m gen rooms
  | length rooms < 2 = m
  | otherwise = 
    digRandomHallways m' g4  (tail rooms)
  where 
    (g1, gx) = split gen
    (g2, g3) = split gx
    ends = (randomPoint (rooms!!0) g1, randomPoint (tail rooms!!n) g2)
    m' = digHallway m ends
    (n',g4) = next g3
    n = n' `mod` (length $ tail rooms)
    
splatter :: RandomGen r => Int -> r -> RMap -> RMap
-- Splatter n random rooms onto m.
splatter n gen m = 
  digRandomHallways (foldl digRoom m rooms) g2 rooms
  where 
    (g1,g2) = split gen
    rooms = take n $ randomRooms g1 (length (m!!0),length m)
    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 . splatter rooms gen $ makeMap dimensions