Monad levelgen-bench

{-# LANGUAGE BangPatterns #-}
module Main where

import Random.Xorshift
import Control.Monad.State

import Text.Printf
import Data.List.Split (chunksOf)
import Data.Ord (comparing)
import qualified Data.Vector as V

import Debug.Trace

type Pos = (Int, Int)

data Tile = Wall | Space
          deriving (Show)

data Room = Room { rPos :: !Pos
                 , rw, rh :: !Int
                 } deriving(Show)

data Lev = Lev { lRooms :: !(V.Vector Room)
               , lTiles :: [Tile]
                 }

levDim, minWid, maxWid :: Int
levDim = 50
minWid = 2
maxWid = 8

checkBound :: Room -> Bool
checkBound Room { rPos = (x,y), rw = w, rh = h } =
    x<=0 || y<=0 || x+w >= levDim || y+h >= levDim

checkColl :: Room -> V.Vector Room -> Bool
checkColl room = V.any (roomHitRoom room)

roomHitRoom :: Room -> Room -> Bool
roomHitRoom Room {rPos=(x,y), rw= w, rh= h} Room {rPos=( x2, y2), rw= w2, rh= h2}
    = not ((x2+w2+1) < x || x2 > (x+w+1)
        || (y2+h2+1) < y || y2 > (y+h+1))

inRoom :: Pos -> Room -> Bool
inRoom (x, y) (Room (rx, ry) rw rh) =
        (rx <= x) && (x < rx + rw)
    &&  (ry <= y) && (y < ry + rh)

showTiles :: [Tile] -> String
showTiles = unlines . chunksOf levDim . map toChar
  where
    toChar t = case t of
        Wall  -> '0'
        Space -> '1'

type MyRandomGen = State Xorshift

genRandom :: MyRandomGen Int
genRandom = do
  gen <- get
  let (rv, gen') = next gen
  put gen'
  return rv

myRandList :: Xorshift -> ([Int], Xorshift)
myRandList g =
  let (i, g') = next g
      (rest, g'') = myRandList g'
  in ((i : rest), g'')

genRooms :: Int -> V.Vector Room -> MyRandomGen (V.Vector Room)
genRooms 0 done = return done
genRooms !n rsDone = do
  [r1,r2] <- sequence $ replicate 2 genRandom
  let x = r1 `rem` levDim
      y = r2 `rem` levDim
      w = r1 `rem` maxWid + minWid
      h = r2 `rem` maxWid + minWid
      tr = Room {rPos=(x,y), rw= w, rh= h}
  if (checkBound tr) || (checkColl tr rsDone)
    then genRooms (n-1) rsDone
    else genRooms (n-1) (V.cons tr rsDone)


genLevs' :: Int -> V.Vector Lev -> MyRandomGen (V.Vector Lev)
genLevs' 0 done = return done
genLevs' n ldone = do
  rs <- genRooms 50000 V.empty
  let tiles = map (toTile rs) [1 .. levDim ^ 2] in
    genLevs' (n-1) ( V.cons Lev{lRooms = rs, lTiles = tiles} ldone)
  where
    toTile rs n = if (V.any (toPos n `inRoom`) rs) then Space else Wall
    toPos n = let (y, x) = quotRem n levDim in (x, y)


biggestLev :: V.Vector Lev -> Lev
biggestLev = V.maximumBy (comparing (V.length . lRooms))

main :: IO ()
main = do
  gen <- newXorshift
  let levs = evalState (genLevs' 100 V.empty) gen
  putStr $ showTiles $ lTiles $ biggestLev levs