placing objects

This commit is contained in:
nek0 2018-03-03 17:03:17 +01:00
parent 061d5c3ede
commit c3f561bfcd
11 changed files with 208 additions and 36 deletions

BIN
assets/misc/box1.kra Normal file

Binary file not shown.

BIN
assets/misc/box1.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 575 B

View file

@ -12,7 +12,7 @@ import Types.Map
import Debug.Trace
buildHallFloorIO :: FloorConfig -> IO (Matrix TileState)
buildHallFloorIO :: FloorConfig -> IO (Matrix TileState, [Graph])
buildHallFloorIO fc = do
rand <- newStdGen
let empty = emptyFloor fc
@ -23,11 +23,11 @@ buildHallFloorIO fc = do
doorgraph = buildDoorsGraph closed
doors <- buildDoors closed doorgraph
let (_, facils) = buildFacilities g2 fc doors
return facils
return (facils, doorgraph)
emptyFloor :: FloorConfig -> Matrix TileState
emptyFloor fc =
let (rows, cols) = size fc
let (rows, cols) = fcSize fc
in M.matrix rows cols (const Unde)
buildElevator
@ -35,7 +35,7 @@ buildElevator
-> (StdGen, Matrix TileState)
-> (StdGen, Matrix TileState)
buildElevator fc (gen, empty) =
let (row, col) = elevator fc
let (row, col) = fcElevator fc
boxCoord x = (,) <$> [row - x .. row + x] <*> [col - x .. col + x]
buildShaft = foldl
(\acc coord -> M.setElem (replaceTile (acc M.! coord) Hall) coord acc)
@ -52,7 +52,7 @@ placeHalls
placeHalls rng fc input =
doHalls rng
[Boundaries (1,1) (nrows input, ncols input)]
(elevator fc) 5 input
(fcElevator fc) 5 input
where
doHalls rand bs cross wmax mat =
foldl (\(agen, amat) b ->
@ -66,16 +66,16 @@ placeHalls rng fc input =
else (g3, nmat)
) (rand, mat) bs
boundSize :: Boundaries -> Int
boundSize :: Boundaries Int -> Int
boundSize (Boundaries mi ma) =
(fst ma - fst mi) * (snd ma - snd mi)
buildHall
:: (Int, Int)
-> Int
-> Boundaries
-> Boundaries Int
-> Matrix TileState
-> ([Boundaries], Matrix TileState)
-> ([Boundaries Int], Matrix TileState)
buildHall coord@(row, col) width bs mat =
let vertHalls = foldl (flip (M.mapCol
(\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs)
@ -159,7 +159,7 @@ buildInnerWalls rng input =
doCross
:: StdGen
-> (Int, Int)
-> Boundaries
-> Boundaries Int
-> Matrix TileState
-> (StdGen, Matrix TileState)
doCross gen cd@(xr, xc) b imat =
@ -256,7 +256,7 @@ buildFacilities gen fc input =
, (cr, cc + 1)
, (cr, cc - 1)
]
nearests = map (findNearestOffice input) (facilities fc)
nearests = map (findNearestOffice input) (fcFacilities fc)
in foldl (\(agen, acc) x ->
let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
facil = if numfac == 1 then Kitc else Toil

View file

@ -55,21 +55,23 @@ load = do
mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
_ <- createFont nvg "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
let mwalls = [ mwallasc, mwalldesc,
let mimgs = [ mwallasc, mwalldesc,
mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
mwalltne, mwalltse, mwalltsw, mwalltnw,
mwallcross ]
when (any isNothing mwalls) $ do
mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,
mmiscbox1
]
when (any isNothing mimgs) $ do
logIO Error "Failed to load walls"
exitFailure
let walls = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mwalls
let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs
return UserData
{ state = Menu
, subsystems = subs
, assetImages = M.fromList
walls
imgs
, assetFonts = M.fromList
[ (FontBedstead, "bedstead")
]

106
src/Interior.hs Normal file
View file

@ -0,0 +1,106 @@
module Interior where
import Affection as A
import Data.Matrix as M
import qualified Data.Map.Strict as Map
import Data.List as L
import Data.Maybe (isNothing, isJust)
import System.Random
-- internal imports
import Types.Interior
import Types.Map
import Types.UserData
placeInteriorIO :: Matrix TileState -> [Graph] -> IO (Matrix (Maybe ImgId))
placeInteriorIO imat graph =
do
rnd <- newStdGen
let (_, mat) =
foldl
traverseGraph
(rnd, M.fromList (nrows imat) (ncols imat) (repeat Nothing))
graph
return mat
where
traverseGraph
:: (StdGen, Matrix (Maybe ImgId))
-> Graph
-> (StdGen, Matrix (Maybe ImgId))
traverseGraph acc (GHall sub) =
foldl traverseGraph acc sub
traverseGraph put@(rng, mat) (GRoom _ bnds) =
let applicable =
reverse (L.sortBy (\a b -> size a `compare` size b) (
L.filter
(\a -> clusterRoom a == roomType && size a < size bnds)
[minBound .. maxBound] :: [Cluster])
)
roomType = fst (head $ reverse $ L.sortBy
(\a b -> snd a `compare` snd b) $ Map.toList $ foldl
(\acc a -> if a `Map.member` acc
then Map.insert a (acc Map.! a + 1) acc
else Map.insert a 1 acc
)
Map.empty
(M.submatrix
(fst $ matmin bnds) (fst $ matmax bnds)
(snd $ matmin bnds) (snd $ matmax bnds)
imat
)
)
in
foldl (\(orng, omat) -> placeCluster orng bnds 1 omat) put applicable
placeCluster rng bnds try mat appl =
let (pr, g1) = randomR (fst (matmin bnds), fst (matmax bnds)) rng
(pc, g2) = randomR (snd (matmin bnds), snd (matmax bnds)) g1
freeRoom = foldl
(\acc a -> if a == Nothing then acc + 1 else acc)
0
(M.toList $ M.submatrix
(fst $ matmin bnds) (fst $ matmax bnds)
(snd $ matmin bnds) (snd $ matmax bnds)
mat
)
cmat = clusterMat appl
in
if try > 100 || fromIntegral freeRoom < size appl
then (g2, mat)
else
if pr - 1 + nrows cmat > fst (matmax bnds) ||
pc - 1 + ncols cmat > snd (matmax bnds) ||
any (/= clusterRoom appl)
(M.toList (M.submatrix
(pr - 1) (pr + nrows cmat - 1)
(pc - 1) (pc + ncols cmat - 1)
imat
)) ||
any isJust
(M.toList (M.submatrix
(pr - 1) (pr + nrows cmat - 1)
(pc - 1) (pc + ncols cmat - 1)
mat
))
then placeCluster g2 bnds (try + 1) mat appl
else A.log A.Debug ("Placing stuff at: " ++ show (pr - 1, pc - 1)) (placeCluster
g2 bnds (try + 1) (insertMat cmat mat (pr - 1, pc - 1)) appl)
insertMat
:: Matrix (Maybe a)
-> Matrix (Maybe a)
-> (Int, Int)
-> Matrix (Maybe a)
insertMat i into (roffs, coffs) =
if roffs + nrows i > nrows into || coffs + ncols i > ncols into
then error "insertMat: matrix to be inserted does not fit!"
else foldl
(\mat (ir, ic) ->
if isNothing (mat M.! (ir + roffs, ic + coffs))
then M.setElem (i M.! (ir, ic)) (ir + roffs, ic + coffs) mat
else mat
)
into
((,) <$> [1 .. nrows i] <*> [1 .. ncols i])

View file

@ -30,6 +30,7 @@ import Debug.Trace
-- internal imports
import Interior
import Util
loadMap :: Affection UserData ()
@ -37,7 +38,8 @@ loadMap = do
ud <- getAffection
let fc = FloorConfig (20, 20) [(5,5), (35, 35)] (50,75)
(Subsystems _ m) = subsystems ud
matrix <- liftIO $ buildHallFloorIO fc
(matrix, gr) <- liftIO $ buildHallFloorIO fc
inter <- liftIO $ placeInteriorIO matrix gr
(nws, _) <- yieldSystemT (worldState ud) $ do
void $ newEntity $ defEntity
{ pos = Just (V2 20.5 20.5)
@ -49,7 +51,7 @@ loadMap = do
{ worldState = nws
, stateData = MenuData
{ mapMat = matrix
, imgMat = convertTileToImg matrix
, imgMat = insertMat inter (convertTileToImg matrix) (0, 0)
, initCoords = (0, 500)
}
, uuid = [uu]
@ -124,7 +126,7 @@ drawMap = do
fill ctx
mapM_ (\(i, ls) -> mapM_
(\(j, t) -> drawTile
((mapMat $ stateData ud) M.! (i, j)) (assetImages ud) ctx pr pc i j t)
(assetImages ud) ctx pr pc i j t)
(reverse $ zip [1..] ls))
(zip [1..] (toLists matrix))
fontSize ctx 20
@ -164,8 +166,16 @@ updateMap dt = do
{ worldState = nws
}
drawTile :: TileState -> Map ImgId Image -> Context -> Double -> Double -> Int -> Int -> Maybe ImgId -> IO ()
drawTile tile ai ctx pr pc row col img = do
drawTile
:: Map ImgId Image
-> Context
-> Double
-> Double
-> Int
-> Int
-> Maybe ImgId
-> IO ()
drawTile ai ctx pr pc row col img = do
let tileWidth = 64 :: Double
tileHeight = 32 :: Double
save ctx
@ -176,11 +186,13 @@ drawTile tile ai ctx pr pc row col img = do
unless (img == Nothing) $ do
let dist = distance (V2 (fromIntegral row) (fromIntegral col))
(V2 (realToFrac pr - 0.5) (realToFrac pc + 0.5)) / 4
fact = if floor pr <= row && floor pc >= col
fact = if (floor pr <= row && floor pc >= col) && isWall (fromJust img)
then min 1 dist
else 1
paint <- imagePattern
ctx x (y - (74 * fact - realToFrac tileHeight)) 64 74 0
ctx x (y - (74 * fact - realToFrac tileHeight))
(realToFrac tileWidth) 74
0
(ai Map.! fromJust img)
fact
beginPath ctx

View file

@ -4,3 +4,4 @@ module Types
import Types.UserData as T
import Types.Map as T
import Types.Interior as T

31
src/Types/Interior.hs Normal file
View file

@ -0,0 +1,31 @@
module Types.Interior where
import Data.Matrix as M
-- internal imports
import Types.Map
import Types.UserData
data Cluster
= ClusterBox1
deriving (Enum, Bounded)
clusterMat :: Cluster -> Matrix (Maybe ImgId)
clusterMat ClusterBox1 =
M.fromLists
[ [Nothing, Nothing, Nothing]
, [Nothing, Just ImgMiscBox1, Nothing]
, [Nothing, Nothing, Nothing]
]
clusterRoom :: Cluster -> TileState
clusterRoom ClusterBox1 = Offi
instance Size Cluster where
size c =
let mat = clusterMat c
in fromIntegral ((nrows mat) * (ncols mat))
-- class ClusterData c where
-- clusterMat :: c -> Matrix (Maybe ImgId)

View file

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleInstances #-}
module Types.Map where
data TileState
@ -10,7 +11,7 @@ data TileState
| Kitc
| Elev
| Unde
deriving (Eq)
deriving (Ord, Eq)
instance Show TileState where
show Wall = "#"
@ -24,16 +25,24 @@ instance Show TileState where
show Unde = " "
data FloorConfig = FloorConfig
{ elevator :: (Int, Int)
, facilities :: [(Int, Int)]
, size :: (Int, Int)
{ fcElevator :: (Int, Int)
, fcFacilities :: [(Int, Int)]
, fcSize :: (Int, Int)
} deriving (Show)
data Boundaries = Boundaries
{ matmin :: (Int, Int)
, matmax :: (Int, Int)
data Boundaries a = Boundaries
{ matmin :: (a, a)
, matmax :: (a, a)
} deriving (Show, Eq)
instance Size (Boundaries Int) where
size (Boundaries (minr, minc) (maxr, maxc)) =
fromIntegral ((maxr - minr) * (maxc - minc))
instance Size (Boundaries Double) where
size (Boundaries (minr, minc) (maxr, maxc)) =
(maxr - minr) * (maxc - minc)
data GraphDirection = North | South | East | West
deriving (Show, Eq)
@ -43,6 +52,9 @@ data Graph
}
| GRoom
{ neighbs :: [(GraphDirection, TileState)]
, bounds :: Boundaries
, bounds :: Boundaries Int
}
deriving (Show, Eq)
class Size a where
size :: a -> Double

View file

@ -51,8 +51,13 @@ data ImgId
| ImgWallTSW
| ImgWallTNW
| ImgWallCross
| ImgMiscBox1
deriving (Show, Eq, Ord, Enum)
isWall :: ImgId -> Bool
isWall ImgMiscBox1 = False
isWall _ = True
data FontId
= FontBedstead
deriving (Show, Eq, Ord, Enum)
@ -68,11 +73,12 @@ data Direction
| SE
data Entity f = Entity
{ pos :: Component f 'Field (V2 Double)
, gridPos :: Component f 'Field (V2 Int)
, vel :: Component f 'Field (V2 Double)
, rot :: Component f 'Field Direction
, player :: Component f 'Unique Bool
{ pos :: Component f 'Field (V2 Double)
, gridPos :: Component f 'Field (V2 Int)
, vel :: Component f 'Field (V2 Double)
, rot :: Component f 'Field Direction
, obstacle :: Component f 'Field (Boundaries Double)
, player :: Component f 'Unique Bool
}
deriving (Generic)

View file

@ -20,8 +20,10 @@ executable tracer-game
other-modules: Types
, Types.UserData
, Types.Map
, Types.Interior
, StateMachine
, Floorplan
, Interior
, Init
, Test
, Util