4doors Cells Maze Generator

maze.hs

import Data.List
import System.Random

randomInitNo :: Int
randomInitNo = 1
data Cell = Cell {
              position::(Int,Int),
              east,west,south,north::Bool
            } deriving Eq
instance Show (Cell) where
  show (Cell pos e w s n) =
        "<cell position=\"" ++
        (show pos)
          ++ "\" doors=\""
          ++ "East:" ++ (show e)
          ++ ",West:" ++ (show w)
          ++ ",South:" ++ (show s)
          ++ ",North:" ++ (show n) ++ "\" />"
openCell :: (Int,Int) -> Int -> Cell
openCell (x,y) size = Cell (x,y) (x<size-1) (x>0) (y<size-1) (y>0)
andCells :: Cell -> Cell -> Cell
andCells (Cell p1 e1 w1 s1 n1) (Cell p2 e2 w2 s2 n2)
  | p1 == p2 = Cell p1 (e1 && e2) (w1 && w2) (s1 && s2) (n1 && n2)
  | otherwise = error "both of cells position must be same."
lockLevel :: Cell -> Int
lockLevel (Cell _ e w s n) =
  foldl1 (+) (map (\a->if a then 0 else 1) [e,w,s,n])
createCellById :: Int -> (Int,Int) -> Cell
createCellById id pos
  | id `elem` [0..2^4-1] = Cell pos (i2b 0) (i2b 1) (i2b 2) (i2b 3)
  | otherwise = error ("id must be 0 to "++(show (2^4-1)))
  where
    i2b x = (1==(id `div` (2^x) `mod` 2))

getNeighborPosition :: Cell -> [(Int,Int)]
getNeighborPosition (Cell (x,y) e w s n) =
  snd (unzip (filter (\(tof,_)->tof)
      ([e,w,s,n] `zip`
        (map (\(x0,y0)->(x+x0,y+y0))
             ([1,-1,0,0] `zip` [0,0,1,-1])
        )
      )
  ))
searchCell :: (Cell,[Cell]) -> Cell -> [Cell] -> [Cell]
searchCell (stCell,field) edCell route
  | edCell == stCell = edCell:route
  | edCell `elem` route = route
  | stCell `elem` route = []
  | stCell `elem` field , edCell `elem` field = snb nb
  | otherwise = []
  where
    nb :: [Cell]
    nb = filter
         (\c ->
           any (==(position c))
           (getNeighborPosition stCell))
         field
    snb :: [Cell] -> [Cell]
    snb [] = []
    snb (x:[]) = searchCell (x,field) edCell (stCell:route)
    snb (x:xs) = (\r->case r of [] ->snb xs;_->r) $
                 searchCell (x,field) edCell (stCell:route)
searchCells :: (Cell,[Cell]) -> [Cell] -> Bool
searchCells stPos edCells
  | [] <- edCells = True
  | (edCell:[]) <- edCells = searchCell stPos edCell [] /= []
  | (edCell:xs) <- edCells
    = (\f->f/=[] && searchCells stPos (xs\\f)) $
      searchCell stPos edCell []
gridCells :: Int -> [Cell]
gridCells size = grow (0,0) size [] [] 0
grow :: (Int,Int) -> Int -> [Cell] -> [Cell] -> Int -> [Cell]
grow (x,y) size list faults n
  | y >= size = list
  | otherwise = (\nws dms->
    if head nws `notElem` faults
       &&
      all (\tof->tof)
      (case dms of
        [] -> [searchCells (st,nws) nws|st<-nws]
        dm:_ -> [searchCells (st,nws++dms) (dm:nws)|st<-nws])
    then (grow (sweep1 (x,y)) size nws [] n)
    else (grow (x,y) size list (head nws:faults) (n+1)))
    (newRandomCell (x,y) size (cellNum x y+n):list)
    [openCell pos size|pos<-dummyPos]
  where
    sweep1 :: (Int,Int) -> (Int,Int)
    sweep1 (x,y) = (((x+1) `mod` size),(y+((x+1)`div`size)))
    sweep1_ :: (Int,Int) -> (Int,Int)
    sweep1_ (x,y) = (\p@(_,y)->if y < 0 then (0,0) else p)
                    (((x-1) `mod` size),(y+((x-1)`div`size)))
    cellNum :: Int -> Int -> Int
    cellNum x y
      | x `elem` [0..size-1] && y `elem` [0..size-1]
        = (size * y) + (x `mod` size)
      | otherwise = -1
    dummyPos::[(Int,Int)]
    dummyPos = [(x1,y1)
      |y0<-[0..size-1],x0<-[0..size-1],
       (x1,y1)<-[sweep1(x0,y0)],
       cellNum x y < cellNum x1 y1]
    
newRandomCell :: (Int,Int) -> Int -> Int -> Cell
newRandomCell (x,y) size n
  = (\f->if (lockLevel f) <= 3
         then f
         else (newRandomCell (x,y) size (n+1)) )$
    openCell (x,y) size
    `andCells`
    createCellById (n`mod`(2^4)) (x,y)
  where
    randList :: [Int]
    randList = randomRs (0,2^4-1) (mkStdGen randomInitNo)
    rnd4CellTypeId :: Int -> Int
    rnd4CellTypeId x = randList !! x

main = print $ gridCells 5

maze2.hs

import Data.List
import System.Random

-- Setting
randomInitNo = 1 
comp = 70

-- Data Type Definitions
data Cell = Cell {
              position::(Int,Int),
              east,west,south,north::Bool
            } deriving Eq
instance Show (Cell) where
  show (Cell pos e w s n) = 
        "<cell position=\"" ++ (show pos\\"()") ++ "\" "
          ++ "doors=\"" ++  "East:"  ++ (show e)
                        ++ ",West:"  ++ (show w)
                        ++ ",South:" ++ (show s)
                        ++ ",North:" ++ (show n) ++ "\" />"

-- Util
i2b _id _x = 1 == _id `div` 2^_x `mod` 2
rndGen = mkStdGen randomInitNo
randList x = randomRs (0,x) rndGen

-- Utils for Data
openCell (_x,_y) _size = Cell (_x,_y) (_x<_size) (_x>1) (_y<_size) (_y>1)

andCells (Cell p1 e1 w1 s1 n1) (Cell p2 e2 w2 s2 n2)
  | p1 == p2 = Cell p1 (e1 && e2) (w1 && w2) (s1 && s2) (n1 && n2)
  | otherwise = error "both of cells position must be same."

lockLevel (Cell _ e w s n) =
  foldl1 (+) (map (\a->if a then 0 else 1) [e,w,s,n])

getFieldComplex _field _size
  = _complex $ getFieldLockNum _field
  where
    _complex _lockNum = _lockNum * 100 `div` _maxLockNum 
    _maxLockNum = (4*2) + ((_size-2)*4*3) + (((_size-2)^2)*4)
getFieldLockNum _field = foldl1 (+) (map lockLevel _field)
 
hasWay _field (Cell p _ _ _ _)
  = any (\c->p `elem` (getNeighborPosition c)) _field

maxId = 2^4-1
allIdList = [0..maxId]
createCellById _id _pos
  | _id `elem` allIdList = Cell _pos (i2b _id 0)
                                     (i2b _id 1)
                                     (i2b _id 2)
                                     (i2b _id 3)
  | otherwise = error ("id must be 0 to "++(show maxId))
cellList _size _p = [o|i <- allIdList,
                       o <- [openCell _p _size
                             `andCells`
                             createCellById i _p],
                       lockLevel o <= 3]

getNeighborPosition (Cell (x,y) e w s n) =
  snd (unzip (filter (\(tof,_)->tof)
      ([e,w,s,n] `zip`
        (map (\(x0,y0)->(x+x0,y+y0))
             ([1,-1,0,0] `zip` [0,0,1,-1])
        )
      )
  ))
getNeighborCells _cell _field
  = filter (\(Cell p _ _ _ _)->p `elem` getNeighborPosition _cell) _field

getReachableCells _field@(s:_)
  = _search [s] []
  where
  _search _nextCells _mList
    | null _nextCells = nub _mList
    | otherwise
      = (\ns->_search ns (ns++_mList)) $
        [n|x<-_nextCells,
           n<-getNeighborCells x _field,
           n `notElem` _mList]

getRandomField n _size
  = [newRandomCell n (x,y) _size|x<-[1.._size],y<-[1.._size]]

newRandomCell n _p _size = cellList _size _p!!(_randList _p !!(_cellNum _p + n))
  where
    _cellNum (x,y)
      | x `elem` [1.._size] && y `elem` [1.._size]
        = (_size * (y-1)) + ((x-1) `mod` _size)
      | otherwise = -1
    _randList _p = randList $ length (cellList _size _p) - 1

gridField _size
  = head [mField
           |n<-[0..],
            field <- [getRandomField n _size],
            validateField field,
            mField <- [minimize field _size 0],
            mField /= []]
validateField _field
  = all (hasWay _field) _field &&
    all (\c->lockLevel c <= 3) _field &&
    length (getReachableCells _field) == length _field
minimize _field _size i
  | getFieldComplex _field _size <= comp = _field
  | i > _size^2 = [] 
  | otherwise = minimize (sq 0 (sortBy lockOrder _field)) _size (i+1)
  where
    lockOrder c0 c1 
      | lockLevel c0 > lockLevel c1 = LT
      | otherwise = GT
    sq i fd@(x@(Cell p _ _ _ _):xs)
      | i > length fd = fd
      | otherwise 
        = sq (i+1) $
          case [xs++[c] |c <- map (andCells x) (oneLockSet p),
                         c /= x && validateField (xs++[c]) ]
          of fld:_ -> fld
             []    -> xs++[x]
    oneLockSet p = [Cell p False True  True  True ,
                    Cell p True  False True  True ,
                    Cell p True  True  False True ,
                    Cell p True  True  True  False]
    
main = putStrLn $ 
         "<labyrinth>\n"++
         (unlines $ map show (gridField 9))++
         "</labyrinth>"