implemented controller input for game

This commit is contained in:
nek0 2018-10-13 00:07:19 +02:00
parent dc91005dee
commit 4c0910f640
3 changed files with 236 additions and 131 deletions

View file

@ -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

View file

@ -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 ()

View file

@ -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