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
<$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO [])
(ws, w) <- yieldSystemT (0, defWorld) (getWorld)
(ws, _) <- yieldSystemT (0, defWorld) (return ())
return UserData
{ state = Menu
, subsystems = subs
, assetImages = M.empty -- FILLME!
, nano = nvg
, uuid = []
, world = w
, worldState = ws
, stateData = None
}

View file

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

View file

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