implemented controller input for game
This commit is contained in:
nek0
parent
dc91005dee
commit
4c0910f640
3 changed files with 236 additions and 131 deletions
|
|
@ -45,18 +45,22 @@ loadMap :: Affection UserData ()
|
|||
loadMap = do
|
||||
ud <- getAffection
|
||||
ad <- get
|
||||
let (Subsystems _ m k _ _) = subsystems ud
|
||||
let (Subsystems _ m k j t) = subsystems ud
|
||||
uu1 <- partSubscribe m movePlayer
|
||||
uu2 <- partSubscribe k changeMaps
|
||||
uu3 <- partSubscribe m playerInteract
|
||||
uu4 <- partSubscribe j emitActionMessage
|
||||
uu5 <- partSubscribe t movePlayer2
|
||||
uu6 <- partSubscribe t playerInteract2
|
||||
future <- liftIO newEmptyMVar
|
||||
progress <- liftIO $ newMVar (0, "Ohai!")
|
||||
_ <- liftIO $ forkIO $ loadMapFork ud ad future progress
|
||||
putAffection ud
|
||||
{ stateData = None
|
||||
, uuid = [uu1, uu2, uu3]
|
||||
, uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
|
||||
, stateMVar = future
|
||||
, stateProgress = progress
|
||||
, state = Main WorldMap
|
||||
}
|
||||
|
||||
changeMaps :: KeyboardMessage -> Affection UserData ()
|
||||
|
|
@ -190,6 +194,7 @@ loadMapFork ud ad future progress = do
|
|||
{ pos = Just (V2 10.5 10.5)
|
||||
, mmpos = mmmpos
|
||||
, vel = Just (V2 0 0)
|
||||
, xyvel = Just (V2 0 0)
|
||||
, mmvel = Just (V2 0 0)
|
||||
, player = Just ()
|
||||
, rot = Just SE
|
||||
|
|
@ -266,7 +271,7 @@ movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
|
|||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
pure $ unchanged
|
||||
return $ unchanged
|
||||
{ vel = Set $ V2 0 0
|
||||
}
|
||||
putAffection ud
|
||||
|
|
@ -274,6 +279,35 @@ movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
|
|||
}
|
||||
movePlayer _ = return ()
|
||||
|
||||
movePlayer2 :: ActionMessage -> Affection UserData ()
|
||||
movePlayer2 (ActionMessage (UpDown f) _) = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
V2 vx _ <- query xyvel
|
||||
let ry = fromIntegral f / 32768 :: Double
|
||||
return $ unchanged
|
||||
{ xyvel = Set $ V2 vx ry
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
movePlayer2 (ActionMessage (LeftRight f) _) = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
V2 _ vy <- query xyvel
|
||||
let rx = fromIntegral f / 32768 :: Double
|
||||
return $ unchanged
|
||||
{ xyvel = Set $ V2 rx vy
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
movePlayer2 _ = return ()
|
||||
|
||||
playerInteract :: MouseMessage -> Affection UserData ()
|
||||
playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
|
||||
ud <- getAffection
|
||||
|
|
@ -324,6 +358,44 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
|
|||
}
|
||||
playerInteract _ = return ()
|
||||
|
||||
playerInteract2 :: ActionMessage -> Affection UserData ()
|
||||
playerInteract2 (ActionMessage Activate _) = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $ do
|
||||
[(ppos, pdir, pent)] <- efor allEnts $ do
|
||||
with player
|
||||
with pos
|
||||
with rot
|
||||
pos' <- query pos
|
||||
rot' <- query rot
|
||||
ent <- queryEnt
|
||||
return (pos', rot', ent)
|
||||
mrelEnts <- efor allEnts $ do
|
||||
with pos
|
||||
with objAccess
|
||||
with objType
|
||||
with objState
|
||||
(rel, dir) <- query objAccess
|
||||
pos' <- query pos
|
||||
otype <- query objType
|
||||
ostate <- query objState
|
||||
ent <- queryEnt
|
||||
if ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
|
||||
(fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
|
||||
pdir == dir
|
||||
then return $ Just (otype, ostate, ent)
|
||||
else return Nothing
|
||||
let relEnts = catMaybes mrelEnts
|
||||
liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts)
|
||||
-- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
|
||||
mapM_ (\(t, s, e) ->
|
||||
setEntity e =<< objectTransition t s True e (Just pent)
|
||||
) relEnts
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
playerInteract2 _ = return ()
|
||||
|
||||
drawMap :: Affection UserData ()
|
||||
drawMap = do
|
||||
ud <- getAffection
|
||||
|
|
@ -529,6 +601,7 @@ updateMap dt = do
|
|||
putAffection ud
|
||||
{ worldState = nws
|
||||
, stateData = mendat
|
||||
, state = Main WorldMap
|
||||
}
|
||||
updateMap 0.1
|
||||
updateMap 0.1
|
||||
|
|
@ -538,6 +611,16 @@ updateMap dt = do
|
|||
Nothing -> return ()
|
||||
else do
|
||||
(nws, _) <- yieldSystemT (worldState ud) $ do
|
||||
emap allEnts $ do
|
||||
with player
|
||||
with xyvel
|
||||
with vel
|
||||
V2 rx ry <- query xyvel
|
||||
let dr = (ry / sin (atan (1/2)) / 2) + rx
|
||||
dc = rx - (ry / sin (atan (1/2)) / 2)
|
||||
return $ unchanged
|
||||
{ vel = Set $ 2 * V2 dr dc
|
||||
}
|
||||
emap allEnts $ do
|
||||
with anim
|
||||
stat <- query anim
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ import Control.Monad
|
|||
import Types
|
||||
import Util
|
||||
import Menu.Adjust
|
||||
import MainGame.WorldMap
|
||||
|
||||
loadMenu :: Affection UserData ()
|
||||
loadMenu = do
|
||||
|
|
@ -95,6 +96,7 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
|
|||
when (arrowUp rels || arrowDown rels) (adjustUpDown rels)
|
||||
when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
|
||||
when (buttonActivate rels) (adjustActivate)
|
||||
when (buttonPlay rels) (enterGame)
|
||||
where
|
||||
adjustUpDown rels = do
|
||||
if arrowUp rels
|
||||
|
|
@ -115,6 +117,9 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
|
|||
adjustActivate = do
|
||||
fullClean
|
||||
loadAdjust Activate loadMenu
|
||||
enterGame = do
|
||||
fullClean
|
||||
loadMap
|
||||
arrowUp (V2 rx ry) =
|
||||
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
|
||||
arrowDown (V2 rx ry) =
|
||||
|
|
@ -125,146 +130,162 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
|
|||
rx > 430 / 1280 && rx < 530 / 1280 && ry > 310 / 720 && ry < 410 / 720
|
||||
buttonActivate (V2 rx ry) =
|
||||
rx > 650 / 1280 && rx < 800 / 1280 && ry > 160 / 720 && ry < 210 / 720
|
||||
buttonPlay (V2 rx ry) =
|
||||
rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
|
||||
handleClicks _ = return ()
|
||||
|
||||
updateMenu :: Double -> Affection UserData ()
|
||||
updateMenu dt = do
|
||||
ud <- getAffection
|
||||
putAffection ud
|
||||
{ stateData = MenuData
|
||||
(velocity $ stateData ud)
|
||||
(rotation $ stateData ud)
|
||||
(max 0 ((activate $ stateData ud) - dt))
|
||||
}
|
||||
case stateData ud of
|
||||
MenuData _ _ _ ->
|
||||
putAffection ud
|
||||
{ stateData = MenuData
|
||||
(velocity $ stateData ud)
|
||||
(rotation $ stateData ud)
|
||||
(max 0 ((activate $ stateData ud) - dt))
|
||||
}
|
||||
_ -> return ()
|
||||
|
||||
drawMenu :: Affection UserData ()
|
||||
drawMenu = do
|
||||
ud <- getAffection
|
||||
liftIO $ do
|
||||
let ctx = nano ud
|
||||
controller = joystick ud
|
||||
save ctx
|
||||
beginPath ctx
|
||||
paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
|
||||
if isNothing controller
|
||||
then IconContrBlue
|
||||
else IconContrGreen
|
||||
) 1
|
||||
rect ctx 600 620 80 80
|
||||
fillPaint ctx paint
|
||||
fill ctx
|
||||
when (isJust controller) $ do
|
||||
let V2 vx vy = velocity $ stateData ud
|
||||
beginPath ctx
|
||||
roundedRect ctx 140 110 1000 500 25
|
||||
strokeWidth ctx 5
|
||||
fillColor ctx (rgba 255 255 255 64)
|
||||
strokeColor ctx (rgb 255 255 255)
|
||||
stroke ctx
|
||||
fill ctx
|
||||
mapM_ (\deg -> do
|
||||
let V2 px py = fmap realToFrac $
|
||||
V2 360 360 - V2 50 50 + fmap realToFrac rot
|
||||
rot@(V2 rx ry) = fmap (fromIntegral . floor) $
|
||||
V2 0 120 `rotVec` deg :: V2 Int
|
||||
case stateData ud of
|
||||
MenuData _ _ _ ->
|
||||
liftIO $ do
|
||||
let ctx = nano ud
|
||||
controller = joystick ud
|
||||
save ctx
|
||||
translate ctx (px + 50) (py + 50)
|
||||
rotate ctx (dtor deg)
|
||||
translate ctx (-50) (-50)
|
||||
case deg of
|
||||
0 -> do
|
||||
when (vy < 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust (UpDown _)) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
90 -> do
|
||||
when (vx > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust (LeftRight _)) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
180 -> do
|
||||
when (vy > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust (UpDown _)) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
270 -> do
|
||||
when (vx < 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust (LeftRight _)) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
beginPath ctx
|
||||
paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
|
||||
rect ctx 0 0 100 100
|
||||
paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
|
||||
if isNothing controller
|
||||
then IconContrBlue
|
||||
else IconContrGreen
|
||||
) 1
|
||||
rect ctx 600 620 80 80
|
||||
fillPaint ctx paint
|
||||
closePath ctx
|
||||
fill ctx
|
||||
restore ctx
|
||||
) [0, 90, 180, 270]
|
||||
beginPath ctx
|
||||
when (activate (stateData ud) > 0) $ do
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 650 160 150 50 10
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust Activate) -> do
|
||||
when (isJust controller) $ do
|
||||
let V2 vx vy = velocity $ stateData ud
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 650 160 150 50 10
|
||||
closePath ctx
|
||||
roundedRect ctx 140 110 1000 500 25
|
||||
strokeWidth ctx 5
|
||||
fillColor ctx (rgba 255 255 255 64)
|
||||
strokeColor ctx (rgb 255 255 255)
|
||||
stroke ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
roundedRect ctx 650 160 150 50 10
|
||||
strokeWidth ctx 2
|
||||
stroke ctx
|
||||
fontSize ctx 25
|
||||
fontFace ctx "bedstead"
|
||||
textAlign ctx (S.fromList [AlignCenter, AlignTop])
|
||||
fillColor ctx (rgba 255 255 255 255)
|
||||
textBox ctx 650 175 150 "Activate"
|
||||
closePath ctx
|
||||
restore ctx
|
||||
mapM_ (\deg -> do
|
||||
let V2 px py = fmap realToFrac $
|
||||
V2 360 360 - V2 50 50 + fmap realToFrac rot
|
||||
rot@(V2 rx ry) = fmap (fromIntegral . floor) $
|
||||
V2 0 120 `rotVec` deg :: V2 Int
|
||||
save ctx
|
||||
translate ctx (px + 50) (py + 50)
|
||||
rotate ctx (dtor deg)
|
||||
translate ctx (-50) (-50)
|
||||
case deg of
|
||||
0 -> do
|
||||
when (vy < 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust (UpDown _)) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
90 -> do
|
||||
when (vx > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust (LeftRight _)) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
180 -> do
|
||||
when (vy > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust (UpDown _)) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
270 -> do
|
||||
when (vx < 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust (LeftRight _)) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
beginPath ctx
|
||||
paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
|
||||
rect ctx 0 0 100 100
|
||||
fillPaint ctx paint
|
||||
closePath ctx
|
||||
fill ctx
|
||||
restore ctx
|
||||
) [0, 90, 180, 270]
|
||||
beginPath ctx
|
||||
when (activate (stateData ud) > 0) $ do
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 650 160 150 50 10
|
||||
fill ctx
|
||||
case state ud of
|
||||
Menu (Adjust Activate) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
roundedRect ctx 650 160 150 50 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
_ ->
|
||||
return ()
|
||||
roundedRect ctx 650 160 150 50 10
|
||||
strokeWidth ctx 2
|
||||
stroke ctx
|
||||
fontSize ctx 25
|
||||
fontFace ctx "bedstead"
|
||||
textAlign ctx (S.fromList [AlignCenter, AlignTop])
|
||||
fillColor ctx (rgba 255 255 255 255)
|
||||
textBox ctx 650 175 150 "Activate"
|
||||
closePath ctx
|
||||
roundedRect ctx 650 560 150 50 10
|
||||
strokeWidth ctx 5
|
||||
stroke ctx
|
||||
fontSize ctx 25
|
||||
fontFace ctx "bedstead"
|
||||
textAlign ctx (S.fromList [AlignCenter, AlignTop])
|
||||
fillColor ctx (rgba 255 255 255 255)
|
||||
textBox ctx 650 575 150 "Play"
|
||||
restore ctx
|
||||
_ -> return ()
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@ data Entity f = Entity
|
|||
, mmpos :: Component f 'Field (V2 Double)
|
||||
, gridPos :: Component f 'Field (V2 Int)
|
||||
, vel :: Component f 'Field (V2 Double)
|
||||
, xyvel :: Component f 'Field (V2 Double)
|
||||
, mmvel :: Component f 'Field (V2 Double)
|
||||
, velFact :: Component f 'Field Double
|
||||
, rot :: Component f 'Field Direction
|
||||
|
|
|
|||
Loading…
Reference in a new issue