floors can be rudimentaly built
This commit is contained in:
nek0
parent
cffe992041
commit
3526572fdb
4 changed files with 258 additions and 4 deletions
|
|
@ -26,7 +26,7 @@ of account data.
|
|||
|
||||
## View
|
||||
|
||||
Cabinet perspective
|
||||
Isometric perspective
|
||||
|
||||
## Mechanics
|
||||
|
||||
|
|
|
|||
250
src/Floorplan.hs
Normal file
250
src/Floorplan.hs
Normal file
|
|
@ -0,0 +1,250 @@
|
|||
module Floorplan where
|
||||
|
||||
import Data.Matrix (Matrix(..))
|
||||
import qualified Data.Matrix as M
|
||||
import Data.Foldable (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
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
|
||||
in closed
|
||||
|
||||
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, emptyFloor) =
|
||||
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))
|
||||
(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
|
||||
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.5 && 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)
|
||||
|
||||
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
|
||||
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 (row, maxRow) gn
|
||||
(cc, g2) = randomR (col, maxCol) g1
|
||||
(nngen, nnmat) = doCross
|
||||
g2
|
||||
(cr, cc)
|
||||
(Boundaries coord (maxRow, maxCol))
|
||||
mat
|
||||
doCross
|
||||
:: StdGen
|
||||
-> (Int, Int)
|
||||
-> Boundaries
|
||||
-> Matrix TileState
|
||||
-> (StdGen, Matrix TileState)
|
||||
doCross gen coord@(xr, xc) b imat =
|
||||
let nbs = map (\(min, max) -> Boundaries min max) bounds
|
||||
bounds =
|
||||
[ (matmin b, coord)
|
||||
, ((fst (matmin b), col), (row, snd (matmax b)))
|
||||
, ((row, snd (matmin b)), (fst (matmax b), col))
|
||||
, (coord, 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)])
|
||||
) (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 trace ("bs: " ++ show (boundSize b)) (boundSize b) >= 16
|
||||
then foldl
|
||||
(\(agen, amat) (cr, nb) -> doCross agen cr nb amat)
|
||||
(ngen, omat)
|
||||
(zip crosses nbs)
|
||||
else trace
|
||||
("built cross at " ++ show coord ++ " within " ++ show b)
|
||||
(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
|
||||
|
|
@ -44,9 +44,10 @@ data Direction
|
|||
| SE
|
||||
|
||||
data Entity f = Entity
|
||||
{ pos :: Component f 'Field (V2 Float)
|
||||
, vel :: Component f 'Field (V2 Float)
|
||||
, rot :: Component f 'Field Direction
|
||||
{ pos :: Component f 'Field (V2 Float)
|
||||
, vel :: Component f 'Field (V2 Float)
|
||||
, rot :: Component f 'Field Direction
|
||||
, player :: Component f 'Unique Bool
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ executable tracer-game
|
|||
other-modules: Types
|
||||
, Types.UserData
|
||||
, StateMachine
|
||||
, Floorplan
|
||||
, Init
|
||||
default-extensions: OverloadedStrings
|
||||
, DeriveGeneric
|
||||
|
|
@ -35,5 +36,7 @@ executable tracer-game
|
|||
, containers
|
||||
, ecstasy
|
||||
, linear
|
||||
, matrix
|
||||
, random
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
Loading…
Reference in a new issue