implement controller adjustments

This commit is contained in:
nek0 2018-10-12 21:40:16 +02:00
parent a58f415e73
commit dc91005dee
6 changed files with 191 additions and 50 deletions

86
src/Menu/Adjust.hs Normal file
View file

@ -0,0 +1,86 @@
module Menu.Adjust where
import Affection as A
import qualified SDL
import NanoVG
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.List (find)
import Data.Maybe (fromJust, isJust)
-- internal imports
import Types
import Util
loadAdjust :: Action -> Affection UserData () -> Affection UserData ()
loadAdjust sub switchBack = do
ud <- getAffection
let Subsystems w m k j t = subsystems ud
uu1 <- partSubscribe j (listener switchBack)
putAffection ud
{ state = Menu (Adjust sub)
, uuid = [ uu1 ]
}
listener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
listener switchBack (MsgJoystickAxis _ _ axis val) = do
ud <- getAffection
liftIO $ logIO A.Debug ("switching " ++ show (state ud) ++ " to " ++ show axis)
case state ud of
Menu (Adjust (UpDown s)) -> do
let k = fst <$> find (\(_, v) -> v == UpDown 1 || v == UpDown (-1)) (M.assocs $ translation ud)
putAffection ud
{ translation =
M.insert (AxisAction $ fromIntegral axis) (UpDown (fromIntegral $ -signum val)) $
if isJust k then M.delete (fromJust k) (translation ud) else translation ud
}
Menu (Adjust (LeftRight s)) -> do
let k = fst <$> find (\(_, v) -> v == LeftRight 1 || v == LeftRight (-1)) (M.assocs $ translation ud)
putAffection ud
{ translation =
M.insert (AxisAction $ fromIntegral axis) (LeftRight (fromIntegral $ signum val)) $
if isJust k then M.delete (fromJust k) (translation ud) else translation ud
}
fullClean
switchBack
listener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do
ud <- getAffection
case state ud of
Menu (Adjust (Activate)) -> do
let k = fst <$> find (\(_, v) -> case v of
Activate -> True
_ -> False
) (M.assocs $ translation ud)
putAffection ud
{ translation =
M.insert (ButtonAction but SDL.JoyButtonPressed) Activate $
if isJust k then M.delete (fromJust k) (translation ud) else translation ud
}
fullClean
switchBack
listener _ _ = return ()
drawAdjust :: Affection UserData ()
drawAdjust = do
ud <- getAffection
liftIO $ do
let ctx = nano ud
save ctx
beginPath ctx
roundedRect ctx 440 310 400 100 10
strokeWidth ctx 5
strokeColor ctx (rgb 255 255 255)
fillColor ctx (rgb 255 255 255)
closePath ctx
stroke ctx
fill ctx
fontSize ctx 50
fontFace ctx "bedstead"
textAlign ctx (S.fromList [AlignCenter, AlignTop])
fillColor ctx (rgb 0 0 0)
textBox ctx 440 310 400 "Enter new movement ..."
restore ctx

View file

@ -18,6 +18,7 @@ import Control.Monad
import Types import Types
import Util import Util
import Menu.Adjust
loadMenu :: Affection UserData () loadMenu :: Affection UserData ()
loadMenu = do loadMenu = do
@ -31,7 +32,7 @@ loadMenu = do
uu5 <- partSubscribe m handleClicks uu5 <- partSubscribe m handleClicks
partUnSubscribe j (joyUUID ud) partUnSubscribe j (joyUUID ud)
putAffection ud putAffection ud
{ uuid = [ uu1, uu2, uu3, uu4 ] { uuid = [ uu1, uu2, uu3, uu4, uu5 ]
, state = Menu Connect , state = Menu Connect
, stateData = MenuData (V2 0 0) S 0 , stateData = MenuData (V2 0 0) S 0
, joyCache = [] , joyCache = []
@ -91,11 +92,39 @@ handleActionMessages (ActionMessage (LeftRight f) _) = do
handleClicks :: MouseMessage -> Affection UserData () handleClicks :: MouseMessage -> Affection UserData ()
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos) rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
when (arrowUp rels) adjustUpDown when (arrowUp rels || arrowDown rels) (adjustUpDown rels)
when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
when (buttonActivate rels) (adjustActivate)
where where
adjustUpDown = liftIO $ logIO A.Debug "TODO: adjustUpDown" adjustUpDown rels = do
if arrowUp rels
then do
fullClean
loadAdjust (UpDown 1) loadMenu
else do
fullClean
loadAdjust (UpDown (-1)) loadMenu
adjustLeftRight rels = do
if arrowLeft rels
then do
fullClean
loadAdjust (LeftRight 1) loadMenu
else do
fullClean
loadAdjust (LeftRight (-1)) loadMenu
adjustActivate = do
fullClean
loadAdjust Activate loadMenu
arrowUp (V2 rx ry) = arrowUp (V2 rx ry) =
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720 rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
arrowDown (V2 rx ry) =
rx > 310 / 1280 && rx < 410 / 1280 && ry > 430 / 720 && ry < 530 / 720
arrowLeft (V2 rx ry) =
rx > 190 / 1280 && rx < 290 / 1280 && ry > 310 / 720 && ry < 410 / 720
arrowRight (V2 rx ry) =
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
handleClicks _ = return () handleClicks _ = return ()
updateMenu :: Double -> Affection UserData () updateMenu :: Double -> Affection UserData ()
@ -129,8 +158,8 @@ drawMenu = do
beginPath ctx beginPath ctx
roundedRect ctx 140 110 1000 500 25 roundedRect ctx 140 110 1000 500 25
strokeWidth ctx 5 strokeWidth ctx 5
fillColor ctx (rgba 255 255 255 128) fillColor ctx (rgba 255 255 255 64)
strokeColor ctx (rgba 255 255 255 255) strokeColor ctx (rgb 255 255 255)
stroke ctx stroke ctx
fill ctx fill ctx
mapM_ (\deg -> do mapM_ (\deg -> do
@ -143,56 +172,64 @@ drawMenu = do
rotate ctx (dtor deg) rotate ctx (dtor deg)
translate ctx (-50) (-50) translate ctx (-50) (-50)
case deg of case deg of
0 -> when (vx < 0) $ do 0 -> do
beginPath ctx when (vy < 0) $ do
fillColor ctx (rgb 255 128 0) beginPath ctx
roundedRect ctx 0 0 100 100 10 fillColor ctx (rgb 255 128 0)
closePath ctx roundedRect ctx 0 0 100 100 10
fill ctx closePath ctx
fill ctx
case state ud of case state ud of
Menu (Adjust (UpDown _)) -> do Menu (Adjust (UpDown _)) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
_ -> _ ->
return () return ()
90 -> when (vy > 0) $ do 90 -> do
beginPath ctx when (vx > 0) $ do
fillColor ctx (rgb 255 128 0) beginPath ctx
roundedRect ctx 0 0 100 100 10 fillColor ctx (rgb 255 128 0)
closePath ctx roundedRect ctx 0 0 100 100 10
fill ctx closePath ctx
fill ctx
case state ud of case state ud of
Menu (Adjust (LeftRight _)) -> do Menu (Adjust (LeftRight _)) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
_ -> _ ->
return () return ()
180 -> when (vx > 0) $ do 180 -> do
beginPath ctx when (vy > 0) $ do
fillColor ctx (rgb 255 128 0) beginPath ctx
roundedRect ctx 0 0 100 100 10 fillColor ctx (rgb 255 128 0)
closePath ctx roundedRect ctx 0 0 100 100 10
fill ctx closePath ctx
fill ctx
case state ud of case state ud of
Menu (Adjust (UpDown _)) -> do Menu (Adjust (UpDown _)) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
_ -> _ ->
return () return ()
270 -> when (vy < 0) $ do 270 -> do
beginPath ctx when (vx < 0) $ do
fillColor ctx (rgb 255 128 0) beginPath ctx
roundedRect ctx 0 0 100 100 10 fillColor ctx (rgb 255 128 0)
closePath ctx roundedRect ctx 0 0 100 100 10
fill ctx closePath ctx
fill ctx
case state ud of case state ud of
Menu (Adjust (LeftRight _)) -> do Menu (Adjust (LeftRight _)) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
@ -212,6 +249,15 @@ drawMenu = do
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 160 150 50 10 roundedRect ctx 650 160 150 50 10
fill ctx 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 roundedRect ctx 650 160 150 50 10
strokeWidth ctx 2 strokeWidth ctx 2
stroke ctx stroke ctx

View file

@ -8,21 +8,26 @@ import Types
import Load import Load
import Menu.Connect import Menu.Connect
import Menu.Adjust
import MainGame.WorldMap import MainGame.WorldMap
import MainGame.MindMap import MainGame.MindMap
import Util
instance StateMachine State UserData where instance StateMachine State UserData where
smLoad Load = loadLoad smLoad Load = loadLoad
smLoad (Menu Connect) = loadMenu smLoad (Menu Connect) = loadMenu
-- smLoad (Menu (Adjust _)) = loadAdjust
smLoad (Main _) = loadMap smLoad (Main _) = loadMap
smUpdate Load = updateLoad smUpdate Load = updateLoad
smUpdate (Menu Connect) = updateMenu smUpdate (Menu Connect) = updateMenu
smUpdate (Menu (Adjust _)) = const (return ())
smUpdate (Main WorldMap) = updateMap smUpdate (Main WorldMap) = updateMap
smUpdate (Main MindMap) = updateMind smUpdate (Main MindMap) = updateMind
smDraw Load = drawLoad smDraw Load = drawLoad
smDraw (Menu Connect) = drawMenu smDraw (Menu Connect) = drawMenu
smDraw (Menu (Adjust _)) = drawMenu >> drawAdjust
smDraw (Main WorldMap) = drawMap smDraw (Main WorldMap) = drawMap
smDraw (Main MindMap) = drawMind smDraw (Main MindMap) = drawMind
@ -34,17 +39,4 @@ instance StateMachine State UserData where
consumeSDLEvents m evs consumeSDLEvents m evs
return () return ()
smClean _ = do smClean _ = fullClean
ud <- getAffection
let Subsystems w m k j t = subsystems ud
toClean = uuid ud
mapM_ (\u -> do
partUnSubscribe w u
partUnSubscribe m u
partUnSubscribe k u
partUnSubscribe j u
partUnSubscribe t u
) toClean
putAffection ud
{ uuid = []
}

View file

@ -51,23 +51,23 @@ data State
= Load = Load
| Menu SubMenu | Menu SubMenu
| Main SubMain | Main SubMain
deriving (Eq) deriving (Eq, Show)
data SubMain data SubMain
= WorldMap = WorldMap
| MindMap | MindMap
deriving (Eq) deriving (Eq, Show)
data SubMenu data SubMenu
= Connect = Connect
| Adjust Action | Adjust Action
deriving (Eq) deriving (Eq, Show)
defaultTranslation :: M.Map GamepadAction Action defaultTranslation :: M.Map GamepadAction Action
defaultTranslation = M.fromList defaultTranslation = M.fromList
[ (ButtonAction 0 SDL.JoyButtonPressed, Activate) [ (ButtonAction 0 SDL.JoyButtonPressed, Activate)
, (AxisAction 0, UpDown 0) , (AxisAction 1, UpDown 1)
, (AxisAction 1, LeftRight 0) , (AxisAction 0, LeftRight 1)
] ]
data Action data Action

View file

@ -295,8 +295,8 @@ emitActionMessage (MsgJoystickAxis time _ axis val) = do
ud <- getAffection ud <- getAffection
let Subsystems _ _ _ _ t = subsystems ud let Subsystems _ _ _ _ t = subsystems ud
case (translation ud) Map.!? (AxisAction axis) of case (translation ud) Map.!? (AxisAction axis) of
Just (UpDown _) -> partEmit t (ActionMessage (UpDown (fromIntegral val)) time) Just (UpDown s) -> partEmit t (ActionMessage (UpDown (s * fromIntegral val)) time)
Just (LeftRight _) -> partEmit t (ActionMessage (LeftRight (fromIntegral val)) time) Just (LeftRight s) -> partEmit t (ActionMessage (LeftRight (s * fromIntegral val)) time)
_ -> return () _ -> return ()
emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
ud <- getAffection ud <- getAffection
@ -305,3 +305,19 @@ emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
Just Activate -> partEmit t (ActionMessage Activate time) Just Activate -> partEmit t (ActionMessage Activate time)
_ -> return () _ -> return ()
emitActionMessage _ = return () emitActionMessage _ = return ()
fullClean :: Affection UserData ()
fullClean = do
ud <- getAffection
let Subsystems w m k j t = subsystems ud
toClean = uuid ud
mapM_ (\u -> do
partUnSubscribe w u
partUnSubscribe m u
partUnSubscribe k u
partUnSubscribe j u
partUnSubscribe t u
) toClean
putAffection ud
{ uuid = []
}

View file

@ -41,6 +41,7 @@ executable tracer-game
, Init , Init
, Load , Load
, Menu.Connect , Menu.Connect
, Menu.Adjust
, MainGame.WorldMap , MainGame.WorldMap
, MainGame.MindMap , MainGame.MindMap
, Navigation , Navigation