remove world and add proper collision

This commit is contained in:
nek0 2018-02-25 02:03:25 +01:00
parent 2c6ac33e44
commit efc3a2f7d8
3 changed files with 35 additions and 29 deletions

View file

@ -39,14 +39,13 @@ load = do
subs <- Subsystems subs <- Subsystems
<$> (Window <$> newTVarIO []) <$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO []) <*> (Mouse <$> newTVarIO [])
(ws, w) <- yieldSystemT (0, defWorld) (getWorld) (ws, _) <- yieldSystemT (0, defWorld) (return ())
return UserData return UserData
{ state = Menu { state = Menu
, subsystems = subs , subsystems = subs
, assetImages = M.empty -- FILLME! , assetImages = M.empty -- FILLME!
, nano = nvg , nano = nvg
, uuid = [] , uuid = []
, world = w
, worldState = ws , worldState = ws
, stateData = None , stateData = None
} }

View file

@ -30,17 +30,15 @@ loadMap = do
let fc = FloorConfig (20, 20) [(5,5), (45, 75)] (80,80) let fc = FloorConfig (20, 20) [(5,5), (45, 75)] (80,80)
(Subsystems _ m) = subsystems ud (Subsystems _ m) = subsystems ud
matrix <- liftIO $ buildHallFloorIO fc matrix <- liftIO $ buildHallFloorIO fc
(nws, nworld) <- yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT (worldState ud) $ do
void $ newEntity $ defEntity void $ newEntity $ defEntity
{ pos = Just (V2 20 20) { pos = Just (V2 20 20)
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
, player = Just True , player = Just True
} }
getWorld
uu <- partSubscribe m movePlayer uu <- partSubscribe m movePlayer
putAffection ud putAffection ud
{ world = nworld { worldState = nws
, worldState = nws
, stateData = MenuData , stateData = MenuData
{ mapMat = matrix { mapMat = matrix
, initCoords = (0, 500) , initCoords = (0, 500)
@ -65,16 +63,14 @@ mouseToPlayer mv2 = do
rela@(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2 rela@(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
let dr = (ry / sin (atan (1/2)) / 2) + rx let dr = (ry / sin (atan (1/2)) / 2) + rx
dc = rx - (ry / sin (atan (1/2)) / 2) dc = rx - (ry / sin (atan (1/2)) / 2)
(nws, nworld) <- yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT (worldState ud) $ do
emap $ do emap $ do
with player with player
pure $ defEntity' pure $ defEntity'
{ vel = Set $ V2 dr dc { vel = Set $ V2 dr dc
} }
getWorld
putAffection ud putAffection ud
{ world = nworld { worldState = nws
, worldState = nws
} }
movePlayer :: MouseMessage -> Affection UserData () movePlayer :: MouseMessage -> Affection UserData ()
@ -83,16 +79,14 @@ movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
mouseToPlayer m mouseToPlayer m
movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ m) = do movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ m) = do
ud <- getAffection ud <- getAffection
(nws, nw) <- yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT (worldState ud) $ do
emap $ do emap $ do
with player with player
pure $ defEntity' pure $ defEntity'
{ vel = Set $ V2 0 0 { vel = Set $ V2 0 0
} }
getWorld
putAffection ud putAffection ud
{ world = nw { worldState = nws
, worldState = nws
} }
movePlayer _ = return () movePlayer _ = return ()
@ -106,18 +100,32 @@ drawMap = do
updateMap :: Double -> Affection UserData () updateMap :: Double -> Affection UserData ()
updateMap dt = do updateMap dt = do
ud <- getAffection ud <- getAffection
(nws, nw) <- yieldSystemT (worldState ud) $ do let matrix = mapMat $ stateData ud
(nws, _) <- yieldSystemT (worldState ud) $ do
emap $ do emap $ do
with player with vel
pos' <- E.get pos with pos
pos'@(V2 or oc) <- E.get pos
vel' <- E.get vel vel' <- E.get vel
pure $ defEntity' let npos@(V2 nr nc) = pos' + fmap (* (4 * dt)) vel'
{ pos = Set $ pos' + fmap (* (4 * dt)) vel' let ent
} | Wall /= matrix M.! (floor nr, floor nc) =
getWorld defEntity'
{ pos = Set npos
}
| Wall /= matrix M.! (floor nr, floor oc) =
defEntity'
{ pos = Set (V2 nr oc)
}
| Wall /= matrix M.! (floor or, floor nc) =
defEntity'
{ pos = Set (V2 or nc)
}
| otherwise =
defEntity'
pure ent
putAffection ud putAffection ud
{ world = nw { worldState = nws
, worldState = nws
} }
drawTile :: Int -> Int -> TileState -> Affection UserData () drawTile :: Int -> Int -> TileState -> Affection UserData ()
@ -136,10 +144,10 @@ drawTile row col tile = do
liftIO $ do liftIO $ do
save ctx save ctx
beginPath ctx beginPath ctx
let x = realToFrac $ (640 + tileWidth / 2) + ((fromIntegral col - pc) + let x = realToFrac $ 640 + ((fromIntegral col - pc + 1) +
(fromIntegral row - pr)) * (tileWidth / 2) (fromIntegral row - pr + 1)) * (tileWidth / 2)
y = realToFrac $ 360 + ((fromIntegral row - pr) - y = realToFrac $ 360 + ((fromIntegral row - pr + 1) -
(fromIntegral col - pc)) * (tileHeight / 2) (fromIntegral col - pc + 1)) * (tileHeight / 2)
fillColor ctx (case tile of fillColor ctx (case tile of
Wall -> rgba 128 128 128 255 Wall -> rgba 128 128 128 255
Door -> rgba 255 128 128 255 Door -> rgba 255 128 128 255
@ -156,7 +164,7 @@ drawTile row col tile = do
lineTo ctx (x + realToFrac tileWidth / 2) (y - realToFrac tileHeight / 2) lineTo ctx (x + realToFrac tileWidth / 2) (y - realToFrac tileHeight / 2)
closePath ctx closePath ctx
fill ctx fill ctx
when (floor pr + 1 == row && floor pc + 1 == col) $ do when (floor pr + 1 == row && floor pc - 1 == col) $ do
beginPath ctx beginPath ctx
circle ctx 640 360 5 circle ctx 640 360 5
closePath ctx closePath ctx

View file

@ -21,7 +21,6 @@ data UserData = UserData
, assetImages :: M.Map ImgId Image , assetImages :: M.Map ImgId Image
, nano :: Context , nano :: Context
, uuid :: [UUID] , uuid :: [UUID]
, world :: Entity 'WorldOf
, worldState :: SystemState Entity , worldState :: SystemState Entity
, stateData :: StateData , stateData :: StateData
} }