inb4 chopping out
This commit is contained in:
nek0
parent
b8028ecd54
commit
f09bcfd87e
3 changed files with 158 additions and 36 deletions
185
src/Floorplan.hs
185
src/Floorplan.hs
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -38,5 +38,7 @@ executable tracer-game
|
|||
, linear
|
||||
, matrix
|
||||
, random
|
||||
, vector
|
||||
hs-source-dirs: src
|
||||
ghc-options: -Wall -prof
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
Loading…
Reference in a new issue