A dividing-chamber maze generation program in Haskell

maze-gen.hs

import Data.Matrix
import Data.List --(sortBy, intercalate, minimumBy, maximumBy, filter, nubBy)
import qualified Data.Vector as Vector -- hiding (Vector(++))
import System.Environment (getArgs)
import Data.Bits (xor, rotate, shift, complement)
data Cell = Empty | Wall deriving (Eq)
instance Show Cell where
  show c = case c of
            Empty -> " "
            Wall  -> "#"

type Maze = Matrix Cell
type Coord = (Int, Int) -- basic (x, y) pair
type Line  = (Coord, Coord)

width :: Maze -> Int
width = nrows

height :: Maze -> Int
height = ncols

mazeToString :: Maze -> String
mazeToString maze =
  (prettyMatrix maze) ++ "\nW:\t" ++ sw ++ "\tH:\t" ++ sh
  where sw = show $ width maze
        sh = show $ height maze

placeWall = const $ const Wall
index = zip [0..]
unIndex = map (snd)

vecAppend = Vector.snoc

wallRow = mapRow placeWall
wallCol = mapCol placeWall

addBorders :: Maze -> Maze
addBorders maze =
  let northWalled = mapRow placeWall 1 maze
      southWalled = mapRow placeWall (height maze) northWalled
      westWalled  = mapCol placeWall 1 southWalled
      bordered    = mapCol placeWall (width maze) westWalled
  in  bordered

randoFunc :: Int -> Maze -> Int -> (Int, Coord) -> Int
randoFunc seed maze numPairs (index, (x, y)) =
  ((complement seed) `shift` (index) `rotate` x * y + ((width maze) `xor` (height maze))) `mod` numPairs

generateSplittingPairs :: Int -> Maze -> Int -> [Coord]
generateSplittingPairs seed maze amnt =
  let start = 3
      allCoords = [(x, y) | x <- [start .. (width maze) - 1], y <- [start .. (height maze) - 1]]
      numPairs = length allCoords
      indexedCoords = index allCoords
      randoCurry = randoFunc seed maze numPairs
      randomIndexed = map (\ indexedCoord -> (randoCurry indexedCoord, indexedCoord)) indexedCoords
      randoSort = sortBy (\ (r1, _) (r2, _) -> compare r1 r2) randomIndexed
      justIndexCoords = unIndex randoSort
      justCoords = unIndex justIndexCoords
      nubbedCoords = nubBy (\ (x1, y1) (x2, y2) -> x1 == x2 || y1 == y2) justCoords 
  in take amnt nubbedCoords

isVrtLine :: Line -> Bool
isVrtLine ((x1, _), (x2, _)) = x1 == x2

isHrzLine :: Line -> Bool
isHrzLine ((_, y1), (_, y2)) = y1 == y2

getHrzWalls :: [Line] -> [Line]
getHrzWalls walls = filter (isHrzLine) walls

getVrtWalls :: [Line] -> [Line]
getVrtWalls walls = filter (isVrtLine) walls

getBoundaries :: Coord -> [Line] -> (Coord, Coord, Coord, Coord)
getBoundaries (x, y) walls =
  let northBound  = maximumBy (compareHrzY) $ filter (ineqY (<)) $ getHrzWalls walls
      southBound  = minimumBy (compareHrzY) $ filter (ineqY (>)) $ getHrzWalls walls
      westBound   = maximumBy (compareVrtX) $ filter (ineqX (<)) $ getVrtWalls walls
      eastBound   = minimumBy (compareVrtX) $ filter (ineqX (>)) $ getVrtWalls walls
      
      northY      = snd $ fst northBound
      southY      = snd $ fst southBound
      westX       = fst $ fst westBound
      eastX       = fst $ fst eastBound 

      northCoord  = (x, northY)
      southCoord  = (x, southY)
      westCoord   = (westX, y)
      eastCoord   = (eastX, y)

  in (northCoord, southCoord, westCoord, eastCoord)
  where compareHrzY = (\ ((_, y1), (_, _)) ((_, y2), (_, _)) -> compare y1 y2)
        ineqY       = (\ ineq ((_, y'), (_, _)) -> ineq y' y)
        compareVrtX = (\ ((x1, _), _) ((x2, _), _) -> compare x1 x2)
        ineqX       = (\ ineq ((x', _), _) -> ineq x' x)

buildSection :: Int -> Bool -> Int -> Cell
buildSection doorLoc shouldPlaceThisDoor i = if (i == doorLoc) && (shouldPlaceThisDoor) then Empty else Wall

{-
makeHrzWall :: Line -> Int -> Maze -> Bool -> Int -> [Cell]
makeHrzWall ((x1, x'), (x2, _)) y maze shouldHaveTwoDoors seed =
  let door1 = x1 `rotate` x' * seed `mod` (width maze) `mod` (x' - x1) --TODO door cannot be at x'
      shouldPlaceDoor1 = even seed
      shouldPlaceDoor2 = odd  seed
      door2 = x2 `rotate` x' * seed `mod` (width maze) `mod` (x2 - x')
      origRow = getRow y maze
      beforeSection = fst (Vector.splitAt x1 origRow)
      afterSection  = snd (Vector.splitAt x2 origRow)
      westSection   = Vector.generate (x' - x1) (buildSection door1 (shouldHaveTwoDoors || shouldPlaceDoor1))
      eastSection   = Vector.generate (x2 - x') (buildSection door2 (shouldHaveTwoDoors || shouldPlaceDoor2))
  in  Vector.toList (Vector.concat [beforeSection, westSection, eastSection, afterSection])

makeVrtWall :: Line -> Int -> Maze -> Bool -> Int -> [Cell]
--makeVrtWall (y1, y') (_, y2) x maze shouldHaveTwoDoors seed =
makeVrtWall ((y1, y'), (_, y2)) x maze shouldHaveTwoDoors seed =
  let door1 = y1 `rotate` y' * seed `mod` (height maze) `mod` (y' - y1) --TODO door cannot be at x'
      shouldPlaceDoor1 = even seed
      shouldPlaceDoor2 = odd  seed
      door2 = y2 `rotate` y' * seed `mod` (height maze) `mod` (y2 - y')
      origCol = getCol x maze
      beforeSection = fst (Vector.splitAt y1 origCol)
      afterSection  = snd (Vector.splitAt y2 origCol)
      northSection   = Vector.generate (y' - y1) (buildSection door1 (shouldHaveTwoDoors || shouldPlaceDoor1))
      southSection   = Vector.generate (y2 - y') (buildSection door2 (shouldHaveTwoDoors || shouldPlaceDoor2))
  in  Vector.toList (Vector.concat [beforeSection, northSection, southSection, afterSection])
-}

makeHrzWall :: Line -> Maze -> Bool -> Int -> [Cell]
makeHrzWall hrzLine maze shouldHaveTwoDoors seed = undefined
makeVrtWall :: Line -> Maze -> Bool -> Int -> [Cell]
makeVrtWall vrtLine maze shouldHaveTwoDoors seed = undefined

{-
divide :: Maze -> [Coord] -> [Line] -> Int -> Maze
divide maze [] _ _ = maze
divide maze ((x, y) : pairs) walls seed =
  let (northBound, southBound, westBound, eastBound) = getBoundaries (x, y) walls
      vrtLine   = (northBound, southBound)
      hrzLine   = (westBound, eastBound)
      newWalls  = [vrtLine, hrzLine]
      nonDoor   = (seed `shift` x * y) `mod` 4
      hrzWall   = makeHrzWall hrzLine  y maze (nonDoor >= 2) seed
      vrtWall   = makeVrtWall vrtLine x maze (nonDoor <  2) seed
      maze'     = mapRow (\ col _ -> hrzWall !! col) x maze
      maze''    = mapCol (\ row _ -> vrtWall !! row) y maze
  in divide maze'' pairs (walls ++ newWalls) seed
  {-
   - first fill in row and column corresponding to (x, y)
   - stop filling in a row or col if it runs into a pre-existing wall
   - get a list of the four new walls (return it?)
   - pick 3 of the four walls, and place a random door in each one
   - go to the next pair
   -}
-}

main :: IO ()
main = do
  args <- getArgs
  putStrLn "hello world!"
  let seed = 42069
  let myW = 8
  let myH = 8
  let myMaze = (matrix myW myH (const Empty)) :: Maze
  let pairAmount = 5
  putStrLn $ prettyMatrix $ addBorders myMaze
  let borderedMaze = addBorders myMaze
  --let myRands = genRands seed myMaze 20
  --putStrLn $ show myRands
  let pairs = (generateSplittingPairs seed borderedMaze pairAmount) :: [Coord]
  putStrLn $ show pairs
  let origWalls = [((1, 1), (myW, 1)), ((1, 1), (1, myH)), ((myW, 1), (myW, myH)), ((1, myH), (myW, myH))] :: [Line]
  --let dividedMaze = divide borderedMaze pairs origWalls seed
  --putStrLn $ prettyMatrix dividedMaze
  --let (dividedChamber, printouts) = divideChambers borderedMaze pairs [prettyMatrix borderedMaze]
  --putStrLn $ intercalate "\n\n" printouts
  --putStrLn $ prettyMatrix myMaze
  putStrLn "done"
  -- TODO: random generation