nek0/tracer
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

implement controller adjustments

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

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

104
src/Menu/Connect.hs
View file

@ -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,56 +172,64 @@ drawMenu = do
rotate ctx (dtor deg)
translate ctx (-50) (-50)
case deg of
0 -> when (vx < 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
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 -> when (vy > 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
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 -> when (vx > 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
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 -> when (vy < 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
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
@ -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

20
src/StateMachine.hs
View file

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

10
src/Types/UserData.hs
View file

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

@ -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 = []
}

1
tracer-game.cabal
View file

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