implement controller adjustments

src/Menu/Adjust.hs

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

src/Menu/Connect.hs

@@ -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)
+      fillColor ctx (rgba 255 255 255 64)
-      strokeColor ctx (rgba 255 255 255 255)
+      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
+          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
               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
-            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
               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
-            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
               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
-            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
               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

src/StateMachine.hs

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

src/Types/UserData.hs

@@ -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, UpDown 1)
-  , (AxisAction 1, LeftRight 0)
+  , (AxisAction 0, LeftRight 1)
   ]
 
 data Action

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 (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 ()
 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 = []
+    }

tracer-game.cabal

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