module Floorplan where import Data.Matrix (Matrix(..)) import qualified Data.Matrix as M import qualified Data.Vector as V import Data.Maybe (isJust) import System.Random import Debug.Trace data TileState = Wall | Wind | Door | Hall | Offi | Toil | Kitc | Elev | Unde deriving (Eq) instance Show TileState where show Wall = "#" show Wind = "~" show Door = "+" show Hall = "_" show Offi = "." show Toil = "o" show Kitc = "k" show Elev = "x" show Unde = " " data FloorConfig = FloorConfig { elevator :: (Int, Int) , facilities :: [(Int, Int)] , size :: (Int, Int) } deriving (Show) data Boundaries = Boundaries { matmin :: (Int, Int) , matmax :: (Int, Int) } deriving (Show) buildHallFloorIO :: FloorConfig -> IO (Matrix TileState) buildHallFloorIO fc = do rand <- newStdGen return $ buildHallFloor fc rand buildHallFloor :: FloorConfig -> StdGen -> Matrix TileState buildHallFloor fc gen = let empty = emptyFloor fc (g1, withElv) = buildElevator fc (placeHalls gen fc empty) (g2, withIW) = buildInnerWalls g1 withElv withOW = buildOuterWalls withIW closed = closeOffices withOW (g3, doors) = buildDoors g2 closed (g4, facils) = buildFacilities g3 fc (trace "doors finished" doors) in facils emptyFloor :: FloorConfig -> Matrix TileState emptyFloor fc = let (rows, cols) = size fc in M.matrix rows cols (const Unde) buildElevator :: FloorConfig -> (StdGen, Matrix TileState) -> (StdGen, Matrix TileState) buildElevator fc (gen, empty) = let (row, col) = elevator fc boxCoord x = (,) <$> [row - x .. row + x] <*> [col - x .. col + x] buildShaft = foldl (\acc coord -> M.setElem (replaceTile (acc M.! coord) Hall) coord acc) (foldl (\acc coord -> M.setElem Wall coord acc) empty (boxCoord 2)) (boxCoord 5) elvDoor = M.setElem Door (row + 2, col) buildShaft in (gen, foldl (\acc coord -> M.setElem Elev coord acc) elvDoor (boxCoord 1)) placeHalls :: StdGen -> FloorConfig -> Matrix TileState -> (StdGen, Matrix TileState) placeHalls rng fc input = doHalls rng [(Boundaries (1,1) (nrows input, ncols input))] (elevator fc) 5 input where doHalls rand bounds cross wmax mat = foldl (\(agen, amat) b -> let (row, g1) = randomR (fst (matmin b), fst (matmax b)) agen (col, g2) = randomR (snd (matmin b), snd (matmax b)) g1 (nw, g3) = randomR (2, wmax) g2 (nbs, nmat) = buildHall cross nw b amat in if hallRatio nmat < 0.175 && wmax - 1 > 2 then doHalls g3 nbs (row, col) (wmax -1) nmat else (g3, nmat) ) (rand, mat) bounds boundSize :: Boundaries -> Int boundSize (Boundaries mi ma) = (fst ma - fst mi) * (snd ma - snd mi) buildHall :: (Int, Int) -> Int -> Boundaries -> Matrix TileState -> ([Boundaries], Matrix TileState) buildHall coord@(row, col) width bounds mat = let vertHalls = foldl (\acc c -> M.mapCol (\r cur -> if r >= fst (matmin bounds) && r <= fst (matmax bounds) then replaceTile cur Hall else cur ) c acc) mat [col - (width `div` 2) .. col + (width `div` 2)] horzHalls = foldl (\acc r -> M.mapRow (\c cur -> if c >= snd (matmin bounds) && c <= snd (matmax bounds) then replaceTile cur Hall else cur ) r acc) vertHalls [row - (width `div` 2) .. row + (width `div` 2)] in ( [ Boundaries (matmin bounds) coord , Boundaries (fst (matmin bounds), col) (row, snd (matmax bounds)) , Boundaries (row, snd (matmin bounds)) (fst (matmax bounds), col) , Boundaries coord (matmax bounds) ] , horzHalls ) replaceTile :: TileState -> TileState -> TileState replaceTile cur new | cur == Unde = new | otherwise = cur hallRatio :: Matrix TileState -> Double hallRatio mat = let hs = foldl (\acc a -> if a == Hall then acc + 1 else acc) 0 mat :: Int in fromIntegral hs / fromIntegral (nrows mat * ncols mat) buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState) buildInnerWalls rng input = let floodSearchReplace :: StdGen -> (Int, Int) -> Matrix TileState -> (StdGen, Matrix TileState) floodSearchReplace gn coord@(row, col) mat | mat M.! coord == Unde = let maxRow = doRow row doRow r | M.safeGet (r + 1) col mat == Just Unde = doRow (r + 1) | otherwise = r maxCol = doCol col doCol c | M.safeGet row (c + 1) mat == Just Unde = doCol (c + 1) | otherwise = c (cr, g1) = randomR ( if maxRow - 3 < row + 3 then (row + 2, row + 2) else (row + 3, maxRow - 3) ) gn (cc, g2) = randomR ( if maxCol - 3 < col + 3 then (col + 2, col + 2) else (col + 3,maxCol - 3) ) g1 (nngen, nnmat) = if (cr - 2 > row && cr + 2 < maxRow) && (cc - 2 > col && cc + 2 < maxCol) then doCross g2 (cr, cc) (Boundaries coord (maxRow, maxCol)) mat else let btups = (,) <$> [fst (coord) .. maxRow] <*> [snd (coord) .. maxCol] in ( g2 , foldl (\acc coords -> M.setElem (replaceTile (acc M.! coords) Offi) coords acc ) mat btups ) doCross :: StdGen -> (Int, Int) -> Boundaries -> Matrix TileState -> (StdGen, Matrix TileState) doCross gen cd@(xr, xc) b imat = let nbs = map (\(mi, ma) -> Boundaries mi ma) bounds bounds = [ (matmin b, cd) , ((fst (matmin b), col), (row, snd (matmax b))) , ((row, snd (matmin b)), (fst (matmax b), col)) , (cd, matmax b) ] (ngen, crosses) = foldl (\(agen, acc) (minb, maxb) -> let (fc, gg1) = randomR (fst minb, fst maxb) agen (fr, gg2) = randomR (snd minb, snd maxb) gg1 in (gg2, acc ++ [(fc, fr)]) ) (gen, []) bounds horz = M.mapRow (\icol cur -> if icol >= snd (matmin b) && icol <= snd (matmax b) then replaceTile cur Wall else cur ) xr imat vert = M.mapCol (\irow cur -> if irow >= fst (matmin b) && irow <= fst (matmax b) then replaceTile cur Wall else cur ) xc horz omat = foldl (\acc coords -> M.setElem (replaceTile (acc M.! coords) Offi) coords acc ) vert btups btups = (,) <$> [fst (matmin b) .. fst (matmax b)] <*> [snd (matmin b) .. snd (matmax b)] in if boundSize b >= 16 then foldl (\(agen, amat) (acr, nb) -> doCross agen acr nb amat) (ngen, omat) (zip crosses nbs) else (gen, omat) in (nngen, nnmat) | otherwise = (gn, mat) tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat] in foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat) (rng, input) (tups input) closeOffices :: Matrix TileState -> Matrix TileState closeOffices input = let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1] isNeighbor (row, col) = let subm = M.submatrix (row -1) (row + 1) (col - 1) (col + 1) input in any (== Hall) (M.toList subm) in foldl (\acc coord -> if input M.! coord == Offi && isNeighbor coord then M.setElem Wall coord acc else acc ) input (tups input) buildOuterWalls :: Matrix TileState -> Matrix TileState buildOuterWalls input = let horz :: Matrix TileState horz = foldl (\amat r -> M.mapRow (\_ _ -> Wall) r amat) input [ 1 , nrows input ] vert = foldl (\amat c -> M.mapCol (\_ _ -> Wall) c amat) horz [ 1 , ncols horz ] in vert buildFacilities :: StdGen -> FloorConfig -> Matrix TileState -> (StdGen, Matrix TileState) buildFacilities gen fc input = let flood ts mat coords@(cr, cc) = let cur = mat M.! coords altered = M.setElem ts coords mat in if cur == ts || cur /= Offi then mat else foldl (\acc cs -> flood ts acc cs) altered [ (cr + 1, cc) , (cr - 1, cc) , (cr, cc + 1) , (cr, cc - 1) ] nearests = map (findNearestOffice input) (facilities fc) in (foldl (\(agen, acc) x -> let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen facil = if numfac == 1 then Kitc else Toil in (ngen, flood facil acc x) ) (gen, input) nearests) findNearestOffice :: Matrix TileState -> (Int, Int) -> (Int, Int) findNearestOffice mat (rrr, ccc) = let matcoord = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat] distance :: (Int, Int) -> Int distance (ar, ac) = (ar - rrr) ^ (2 :: Int) + (ac - ccc) ^ (2 :: Int) inlist = zip matcoord (M.toList mat) in foldl (\acc (xc, ts) -> if ts == Offi && distance acc > distance xc then xc else acc ) (fst $ head inlist) inlist buildDoors :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState) buildDoors rand mat = let maxRow r c | M.safeGet (r + 1) c mat == Just Offi = maxRow (r + 1) c | otherwise = r maxCol r c | M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1) | otherwise = c minRow r c | M.safeGet (r + 1) c mat == Just Offi = minRow (r + 1) c | otherwise = r minCol r c | M.safeGet r (c + 1) mat == Just Offi = minCol r (c + 1) | otherwise = c matcoord = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1] inbounds (qr, qc) fg | fg == Hall = Nothing | otherwise = Just fg buildGraph amat rnd coord@(br, bc) | bc > ncols amat - 1 = buildGraph amat rnd (br + 1, 1) | br > nrows amat - 1 = (rnd, amat) | M.safeGet br bc amat == Just Offi = let b = Boundaries (minRow br bc, minCol br bc) (maxRow br bc, maxCol br bc) neighs = [ (North, M.safeGet (minRow br bc - 2) bc amat) , (South, M.safeGet (maxRow br bc + 2) bc amat) , (East, M.safeGet br (minCol br bc - 2) amat) , (West, M.safeGet br (maxCol br bc + 2) amat) ] (namat, rnd2) = if Just Hall `elem` map snd neighs then let halls = filter ((== Just Hall) . snd) neighs (rh, r1) = randomR (0, length halls - 1) rnd (dir, _) = halls !! rh (dp , r2) | dir == North = let (col, rr) = randomR (minCol br bc, maxCol br bc) r1 doorpos = ((minRow br bc) - 1, col) in (doorpos, rr) | dir == South = let (col, rr) = randomR (minCol br bc, maxCol br bc) r1 doorpos = ((maxRow br bc) + 1, col) in (doorpos, rr) | dir == East = let (row, rr) = randomR (minRow br bc, maxRow br bc) r1 doorpos = (row, (minCol br bc) - 1) in (doorpos, rr) | dir == West = let (row, rr) = randomR (minRow br bc, maxRow br bc) r1 doorpos = (row, (maxCol br bc) + 1) in (doorpos, rr) in if any (== Door) (M.toList $ M.submatrix ((fst $ matmin b) - 1) ((fst $ matmax b) + 1) ((snd $ matmin b) - 1) ((snd $ matmax b) + 1) amat) then (amat, rnd) else ( if amat M.! dp == Hall || amat M.! dp == Offi then amat else M.setElem Door dp amat , r2 ) else let others = filter ((== Just Offi) . snd) neighs (ro, r1) = randomR (0, length others - 1) rnd (dir, _) = others !! ro (dp, r2) | dir == North = let (col, rr) = randomR (minCol br bc, maxCol br bc) r1 doorpos = ((minRow br bc) - 1, col) in (doorpos, rr) | dir == South = let (col, rr) = randomR (minCol br bc, maxCol br bc) r1 doorpos = ((maxRow br bc) + 1, col) in (doorpos, rr) | dir == East = let (row, rr) = randomR (minRow br bc, maxRow br bc) r1 doorpos = (row, (minCol br bc) - 1) in (doorpos, rr) | dir == West = let (row, rr) = randomR (minRow br bc, maxRow br bc) r1 doorpos = (row, (maxCol br bc) + 1) in (doorpos, rr) in if any (== Door) (M.toList $ M.submatrix ((fst $ matmin b) - 1) ((fst $ matmax b) + 1) ((snd $ matmin b) - 1) ((snd $ matmax b) + 1) amat) then (amat, rnd) else ( if amat M.! dp == Hall || amat M.! dp == Offi then amat else M.setElem Door dp amat , r2 ) in buildGraph namat rnd2 (br, bc + 1) | otherwise = buildGraph amat rnd (br, maxCol br (bc + 1)) in foldl (\(aar, aam) c -> buildGraph aam aar c) (rand, mat) matcoord data GraphDirection = North | South | East | West deriving (Eq)