inb4 chopping out

This commit is contained in:
nek0 2018-02-15 19:42:07 +01:00
parent b8028ecd54
commit f09bcfd87e
3 changed files with 158 additions and 36 deletions

View file

@ -2,8 +2,8 @@ module Floorplan where
import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M
import Data.Foldable (find)
import Data.Maybe (fromMaybe)
import qualified Data.Vector as V
import Data.Maybe (isJust)
import System.Random
@ -50,13 +50,14 @@ buildHallFloorIO fc = do
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, facilities) = buildFacilities g2 fc closed
in facilities
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 =
@ -67,12 +68,12 @@ buildElevator
:: FloorConfig
-> (StdGen, Matrix TileState)
-> (StdGen, Matrix TileState)
buildElevator fc (gen, emptyFloor) =
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) emptyFloor (boxCoord 2))
(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))
@ -87,23 +88,21 @@ placeHalls rng fc input =
[(Boundaries (1,1) (nrows input, ncols input))]
(elevator fc) 5 input
where
elPos = elevator fc
doHalls rand bounds cross wmax mat =
let (rnd, gen) = next rand
in 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
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 min max) =
(fst max - fst min) * (snd max - snd min)
boundSize (Boundaries mi ma) =
(fst ma - fst mi) * (snd ma - snd mi)
buildHall
:: (Int, Int)
@ -141,7 +140,7 @@ replaceTile cur new
hallRatio :: Matrix TileState -> Double
hallRatio mat =
let hs = foldl (\acc a -> if a == Hall then acc + 1 else acc) 0 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)
@ -197,19 +196,19 @@ buildInnerWalls rng input =
-> Boundaries
-> Matrix TileState
-> (StdGen, Matrix TileState)
doCross gen coord@(xr, xc) b imat =
let nbs = map (\(min, max) -> Boundaries min max) bounds
doCross gen cd@(xr, xc) b imat =
let nbs = map (\(mi, ma) -> Boundaries mi ma) bounds
bounds =
[ (matmin b, coord)
[ (matmin b, cd)
, ((fst (matmin b), col), (row, snd (matmax b)))
, ((row, snd (matmin b)), (fst (matmax b), col))
, (coord, matmax b)
, (cd, matmax b)
]
(ngen, crosses) = foldl
(\(agen, acc) (minb, maxb) ->
let (fc, g1) = randomR (fst minb, fst maxb) agen
(fr, g2) = randomR (snd minb, snd maxb) g1
in (g2, acc ++ [(fc, fr)])
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)
@ -230,7 +229,7 @@ buildInnerWalls rng input =
<*> [snd (matmin b) .. snd (matmax b)]
in if boundSize b >= 16
then foldl
(\(agen, amat) (cr, nb) -> doCross agen cr nb amat)
(\(agen, amat) (acr, nb) -> doCross agen acr nb amat)
(ngen, omat)
(zip crosses nbs)
else
@ -304,10 +303,124 @@ findNearestOffice
-> (Int, Int)
findNearestOffice mat (rrr, ccc) =
let matcoord = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
distance (ar, ac) = (ar - rrr) ^ 2 + (ac - ccc) ^ 2
distance :: (Int, Int) -> Int
distance (ar, ac) = (ar - rrr) ^ (2 :: Int) + (ac - ccc) ^ (2 :: Int)
inlist = zip matcoord (M.toList mat)
in foldl (\acc@(arow, acol) x@(xc@(crow, ccol), ts) ->
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)

View file

@ -25,6 +25,10 @@ import Foreign.C.Types (CInt(..))
import Types
import Floorplan
import Debug.Trace
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
@ -36,6 +40,9 @@ load = do
<$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO [])
w <- runSystemT defWorld getWorld
let fc = FloorConfig (20, 45) [(5, 5), (30,80)] (40, 90)
floor <- buildHallFloorIO fc
traceIO $ show floor
return UserData
{ state = Menu
, subsystems = subs

View file

@ -38,5 +38,7 @@ executable tracer-game
, linear
, matrix
, random
, vector
hs-source-dirs: src
ghc-options: -Wall -prof
default-language: Haskell2010