implement controller adjustments
This commit is contained in:
nek0
parent
a58f415e73
commit
dc91005dee
6 changed files with 191 additions and 50 deletions
86
src/Menu/Adjust.hs
Normal file
86
src/Menu/Adjust.hs
Normal 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
|
||||
|
|
@ -18,6 +18,7 @@ import Control.Monad
|
|||
|
||||
import Types
|
||||
import Util
|
||||
import Menu.Adjust
|
||||
|
||||
loadMenu :: Affection UserData ()
|
||||
loadMenu = do
|
||||
|
|
@ -31,7 +32,7 @@ loadMenu = do
|
|||
uu5 <- partSubscribe m handleClicks
|
||||
partUnSubscribe j (joyUUID ud)
|
||||
putAffection ud
|
||||
{ uuid = [ uu1, uu2, uu3, uu4 ]
|
||||
{ uuid = [ uu1, uu2, uu3, uu4, uu5 ]
|
||||
, state = Menu Connect
|
||||
, stateData = MenuData (V2 0 0) S 0
|
||||
, joyCache = []
|
||||
|
|
@ -91,11 +92,39 @@ handleActionMessages (ActionMessage (LeftRight f) _) = do
|
|||
handleClicks :: MouseMessage -> Affection UserData ()
|
||||
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
|
||||
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
|
||||
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) =
|
||||
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 ()
|
||||
|
||||
updateMenu :: Double -> Affection UserData ()
|
||||
|
|
@ -129,8 +158,8 @@ drawMenu = do
|
|||
beginPath ctx
|
||||
roundedRect ctx 140 110 1000 500 25
|
||||
strokeWidth ctx 5
|
||||
fillColor ctx (rgba 255 255 255 128)
|
||||
strokeColor ctx (rgba 255 255 255 255)
|
||||
fillColor ctx (rgba 255 255 255 64)
|
||||
strokeColor ctx (rgb 255 255 255)
|
||||
stroke ctx
|
||||
fill ctx
|
||||
mapM_ (\deg -> do
|
||||
|
|
@ -143,7 +172,8 @@ drawMenu = do
|
|||
rotate ctx (dtor deg)
|
||||
translate ctx (-50) (-50)
|
||||
case deg of
|
||||
0 -> when (vx < 0) $ do
|
||||
0 -> do
|
||||
when (vy < 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
|
|
@ -151,13 +181,15 @@ drawMenu = do
|
|||
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 -> when (vy > 0) $ do
|
||||
90 -> do
|
||||
when (vx > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
|
|
@ -165,13 +197,15 @@ drawMenu = do
|
|||
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 -> when (vx > 0) $ do
|
||||
180 -> do
|
||||
when (vy > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
|
|
@ -179,13 +213,15 @@ drawMenu = do
|
|||
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 -> when (vy < 0) $ do
|
||||
270 -> do
|
||||
when (vx < 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 0 0 100 100 10
|
||||
|
|
@ -193,6 +229,7 @@ drawMenu = do
|
|||
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
|
||||
|
|
@ -212,6 +249,15 @@ drawMenu = 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
|
||||
|
|
|
|||
|
|
@ -8,21 +8,26 @@ import Types
|
|||
|
||||
import Load
|
||||
import Menu.Connect
|
||||
import Menu.Adjust
|
||||
import MainGame.WorldMap
|
||||
import MainGame.MindMap
|
||||
import Util
|
||||
|
||||
instance StateMachine State UserData where
|
||||
smLoad Load = loadLoad
|
||||
smLoad (Menu Connect) = loadMenu
|
||||
-- smLoad (Menu (Adjust _)) = loadAdjust
|
||||
smLoad (Main _) = loadMap
|
||||
|
||||
smUpdate Load = updateLoad
|
||||
smUpdate (Menu Connect) = updateMenu
|
||||
smUpdate (Menu (Adjust _)) = const (return ())
|
||||
smUpdate (Main WorldMap) = updateMap
|
||||
smUpdate (Main MindMap) = updateMind
|
||||
|
||||
smDraw Load = drawLoad
|
||||
smDraw (Menu Connect) = drawMenu
|
||||
smDraw (Menu (Adjust _)) = drawMenu >> drawAdjust
|
||||
smDraw (Main WorldMap) = drawMap
|
||||
smDraw (Main MindMap) = drawMind
|
||||
|
||||
|
|
@ -34,17 +39,4 @@ instance StateMachine State UserData where
|
|||
consumeSDLEvents m evs
|
||||
return ()
|
||||
|
||||
smClean _ = 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 = []
|
||||
}
|
||||
smClean _ = fullClean
|
||||
|
|
|
|||
|
|
@ -51,23 +51,23 @@ data State
|
|||
= Load
|
||||
| Menu SubMenu
|
||||
| Main SubMain
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SubMain
|
||||
= WorldMap
|
||||
| MindMap
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SubMenu
|
||||
= Connect
|
||||
| Adjust Action
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
defaultTranslation :: M.Map GamepadAction Action
|
||||
defaultTranslation = M.fromList
|
||||
[ (ButtonAction 0 SDL.JoyButtonPressed, Activate)
|
||||
, (AxisAction 0, UpDown 0)
|
||||
, (AxisAction 1, LeftRight 0)
|
||||
, (AxisAction 1, UpDown 1)
|
||||
, (AxisAction 0, LeftRight 1)
|
||||
]
|
||||
|
||||
data Action
|
||||
|
|
|
|||
20
src/Util.hs
20
src/Util.hs
|
|
@ -295,8 +295,8 @@ emitActionMessage (MsgJoystickAxis time _ axis val) = do
|
|||
ud <- getAffection
|
||||
let Subsystems _ _ _ _ t = subsystems ud
|
||||
case (translation ud) Map.!? (AxisAction axis) of
|
||||
Just (UpDown _) -> partEmit t (ActionMessage (UpDown (fromIntegral val)) time)
|
||||
Just (LeftRight _) -> partEmit t (ActionMessage (LeftRight (fromIntegral val)) time)
|
||||
Just (UpDown s) -> partEmit t (ActionMessage (UpDown (s * fromIntegral val)) time)
|
||||
Just (LeftRight s) -> partEmit t (ActionMessage (LeftRight (s * fromIntegral val)) time)
|
||||
_ -> return ()
|
||||
emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
|
||||
ud <- getAffection
|
||||
|
|
@ -305,3 +305,19 @@ emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
|
|||
Just Activate -> partEmit t (ActionMessage Activate time)
|
||||
_ -> 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 = []
|
||||
}
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@ executable tracer-game
|
|||
, Init
|
||||
, Load
|
||||
, Menu.Connect
|
||||
, Menu.Adjust
|
||||
, MainGame.WorldMap
|
||||
, MainGame.MindMap
|
||||
, Navigation
|
||||
|
|
|
|||
Loading…
Reference in a new issue