remove world and add proper collision
This commit is contained in:
parent
2c6ac33e44
commit
efc3a2f7d8
3 changed files with 35 additions and 29 deletions
|
@ -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
|
||||||
}
|
}
|
||||||
|
|
60
src/Test.hs
60
src/Test.hs
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
}
|
}
|
||||||
|
|
Loading…
Add table
Reference in a new issue