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] 
  
show_map :: RMap -> String
show_map rmap = 
  unlines $ map (foldl (\line title -> line ++ show title) "") rmap

make_map :: Coord -> RMap
make_map (x,y) = replicate y (replicate x TWall)

split_gap :: Int -> Int -> [a] -> ([a],[a],[a])
split_gap start size lst = (before, middle, after)
  where 
    (before,rest) = splitAt start lst
    (middle,after) = splitAt (abs size) rest

dig_row :: Range -> MRow -> MRow
dig_row (start,end) row = 
  before ++ replicate size TFloor ++ after
  where
    size = end - start + 1
    (before,_,after) = split_gap start size row

dig_room :: RMap -> Area -> RMap
dig_room rmap ((x,y),(u,v)) =
  ybefore ++ map (dig_row (x,u)) rows ++ yend
  where 
    (ybefore,rows,yend) = split_gap y (v-y+1) rmap

random_room :: (RandomGen r) => r -> Coord -> Area
random_room gen (w,h) = 
  ((x',y'),(u',v')) -- Note the reordering of xuyv to xyuv.
  where 
    (x,g')    = next gen
    (y,g'')   = next g'
    (u,g''')  = next g''
    (v,g'''') = next g'''
    (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

random_rooms :: (Num a, RandomGen r) => a -> r -> (Coord) -> [Area]
random_rooms n gen dims = random_rooms' n gen dims []

random_rooms' :: (Num a, RandomGen r) => 
                 a -> r -> (Coord) -> [Area] -> [Area]
random_rooms' 0 gen dims rooms = rooms
random_rooms' n gen dims rooms = 
  random_rooms' (n-1) g2 dims (room:rooms)
  where 
    (g1,g2) = split gen 
    room = random_room g1 dims
        
dig_hallway :: RMap -> Area -> RMap
dig_hallway m ((x,y),(u,v)) = 
  -- Dig from (x,y) to (u,y) to (u,v).
  dig_room (dig_room m ((u,min y v),(u,max y v))) 
           ((min x u,y),(max x u,y))
  
dig_random_hallways :: RandomGen r => 
                       RMap -> r -> [Coord] -> RMap
dig_random_hallways m gen centers 
  | length centers < 2 = m
  | otherwise = 
    dig_random_hallways m' g'  (tail centers)
  where 
    m' = dig_hallway m (centers!!0,centers!!n)
    (n',g') = next gen
    n = n' `mod` (length centers - 1) + 1
    
splatter :: (Num a, RandomGen r) => a -> r -> RMap -> RMap
-- Splatter n random rooms onto m.
splatter n gen m = 
  dig_random_hallways 
     (foldl dig_room m rooms) 
     g2 
     (map center rooms)
  where 
    (g1,g2) = split gen
    rooms = random_rooms n g1 (length m,length (m!!0))
    center ((x,y),(u,v)) = ((x+u) `quot` 2, (y+v) `quot` 2)
    
data Options = Options {optRooms::Integer,optDimensions::Coord}

defaults :: Options
defaults = Options {optRooms=5,optDimensions=(80,60)}

options = 
  [Option ['n'] ["rooms"] 
      (ReqArg (\s op-> return op{optRooms=read s::Integer}) "ROOMS")
      "Number of rooms to dig.",
   Option ['d'] ["dimensions"]
      (ReqArg (\s op-> case reads s :: [(Coord,String)] of
                  ((dims,_):_) -> 
                    return op { optDimensions = dims }
                  otherwise -> 
                    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 . show_map . splatter rooms gen $ make_map dimensions