further implementation of controller

src/MainGame/MindMap.hs

@@ -26,6 +26,16 @@ updateMind :: Double -> Affection UserData ()
 updateMind dt = do
  ud <- getAffection
  (nws, _) <- yieldSystemT (worldState ud) $ do
+   emap allEnts $ do
+     with player
+     with xyvel
+     with mmvel
+     V2 rx ry <- query xyvel
+     let dr = (ry / sin (atan (1/2)) / 2) + rx
+         dc = rx - (ry / sin (atan (1/2)) / 2)
+     return $ unchanged
+       { mmvel = Set $ 2 * V2 dr dc
+       }
    emap allEnts $ do
      with anim
      with mmpos
@@ -68,7 +78,7 @@ updateMind dt = do
      with rot
      with anim
      pos'@(V2 pr pc) <- query mmpos
-     vel' <- query vel
+     vel' <- query mmvel
      rot' <- query rot
      stat <- query anim
      let npos = pos' + fmap (* dt) vel'

src/MainGame/WorldMap.hs

@@ -52,12 +52,13 @@ loadMap = do
   uu4 <- partSubscribe j emitActionMessage
   uu5 <- partSubscribe t movePlayer2
   uu6 <- partSubscribe t playerInteract2
+  uu7 <- partSubscribe t changeMaps2
   future <- liftIO newEmptyMVar
   progress <- liftIO $ newMVar (0, "Ohai!")
   _ <- liftIO $ forkIO $ loadMapFork ud ad future progress
   putAffection ud
     { stateData = None
-    , uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
+    , uuid = [ uu1, uu2, uu3, uu4, uu5, uu6, uu7 ]
     , stateMVar = future
     , stateProgress = progress
     , state = Main WorldMap
@@ -78,6 +79,21 @@ changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
   | otherwise = return ()
 changeMaps _ = return ()
 
+changeMaps2 :: ActionMessage -> Affection UserData ()
+changeMaps2 (ActionMessage SwitchMap _) = do
+  ud <- getAffection
+  case state ud of
+    Main MindMap ->
+      putAffection ud
+        { state = Main WorldMap
+        }
+    Main WorldMap ->
+      putAffection ud
+        { state = Main MindMap
+        }
+    _ -> return ()
+changeMaps2 _ = return ()
+
 loadMapFork
   :: UserData
   -> AffectionData UserData
@@ -250,13 +266,11 @@ mouseToPlayer :: V2 Int32 -> Affection UserData ()
 mouseToPlayer mv2 = do
   ud <- getAffection
   (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
-  let dr = (ry / sin (atan (1/2)) / 2) + rx
-      dc = rx - (ry / sin (atan (1/2)) / 2)
   (nws, _) <- yieldSystemT (worldState ud) $
     emap allEnts $ do
       with player
-      pure $ unchanged
-        { vel = Set $ 4 * V2 dr dc
+      return $ unchanged
+        { xyvel = Set $ V2 rx ry
         }
   putAffection ud
     { worldState = nws
@@ -272,7 +286,7 @@ movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
     emap allEnts $ do
       with player
       return $ unchanged
-        { vel = Set $ V2 0 0
+        { xyvel = Set $ V2 0 0
         }
   putAffection ud
     { worldState = nws

src/Menu/Adjust.hs

@@ -50,16 +50,16 @@ listener switchBack (MsgJoystickAxis _ _ axis val) = do
 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)
+    Menu (Adjust (UpDown s)) -> return ()
+    Menu (Adjust (LeftRight s)) -> return ()
+    Menu (Adjust (act)) -> do
+      let k = fst <$> find (\(_, v) -> v == act) (M.assocs $ translation ud)
       putAffection ud
         { translation =
-          M.insert (ButtonAction but SDL.JoyButtonPressed) Activate $
+          M.insert (ButtonAction but SDL.JoyButtonPressed) act $
             if isJust k then M.delete (fromJust k) (translation ud) else translation ud
         }
+    _ -> return ()
   fullClean
   switchBack
 listener _ _ = return ()

src/Menu/Connect.hs

@@ -35,7 +35,7 @@ loadMenu = do
   putAffection ud
     { uuid      = [ uu1, uu2, uu3, uu4, uu5 ]
     , state     = Menu Connect
-    , stateData = MenuData (V2 0 0) S 0
+    , stateData = MenuData (V2 0 0) S 0 0
     , joyCache  = []
     }
   mapM_ (partEmit j) (joyCache ud)
@@ -73,6 +73,13 @@ handleActionMessages (ActionMessage Activate _) = do
       { activate = 0.5
       }
     }
+handleActionMessages (ActionMessage SwitchMap _) = do
+  ud <- getAffection
+  putAffection ud
+    { stateData = (stateData ud)
+      { switchMap = 0.5
+      }
+    }
 handleActionMessages (ActionMessage (UpDown f) _) = do
   ud <- getAffection
   let V2 vx _ = velocity $ stateData ud
@@ -96,6 +103,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 (buttonSwitchMap rels) (adjustSwitchMap)
   when (buttonPlay rels) (enterGame)
   where
     adjustUpDown rels = do
@@ -117,6 +125,9 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
     adjustActivate = do
       fullClean
       loadAdjust Activate loadMenu
+    adjustSwitchMap = do
+      fullClean
+      loadAdjust SwitchMap loadMenu
     enterGame = do
       fullClean
       loadMap
@@ -130,6 +141,8 @@ 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
+    buttonSwitchMap (V2 rx ry) =
+      rx > 650 / 1280 && rx < 800 / 1280 && ry > 220 / 720 && ry < 270 / 720
     buttonPlay (V2 rx ry) =
       rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
 handleClicks _ = return ()
@@ -138,12 +151,13 @@ updateMenu :: Double -> Affection UserData ()
 updateMenu dt = do
   ud <- getAffection
   case stateData ud of
-    MenuData _ _ _ ->
+    MenuData _ _ _ _ ->
       putAffection ud
         { stateData = MenuData
           (velocity $ stateData ud)
           (rotation $ stateData ud)
           (max 0 ((activate $ stateData ud) - dt))
+          (max 0 ((switchMap $ stateData ud) - dt))
         }
     _ -> return ()
 
@@ -151,7 +165,7 @@ drawMenu :: Affection UserData ()
 drawMenu = do
   ud <- getAffection
   case stateData ud of
-    MenuData _ _ _ ->
+    MenuData _ _ _ _ ->
       liftIO $ do
         let ctx = nano ud
             controller = joystick ud
@@ -256,11 +270,12 @@ drawMenu = do
             fill ctx
             restore ctx
             ) [0, 90, 180, 270]
-          beginPath ctx
           when (activate (stateData ud) > 0) $ do
+            beginPath ctx
             fillColor ctx (rgb 255 128 0)
             roundedRect ctx 650 160 150 50 10
             fill ctx
+            closePath ctx
           case state ud of
             Menu (Adjust Activate) -> do
               beginPath ctx
@@ -270,22 +285,49 @@ drawMenu = do
               fill ctx
             _ ->
               return ()
+          beginPath ctx
           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)
+          fillColor ctx (rgb 255 255 255)
           textBox ctx 650 175 150 "Activate"
           closePath ctx
-          roundedRect ctx 650 560 150 50 10
-          strokeWidth ctx 5
+          when (switchMap (stateData ud) > 0) $ do
+            beginPath ctx
+            fillColor ctx (rgb 255 128 0)
+            roundedRect ctx 650 220 150 50 10
+            fill ctx
+            closePath ctx
+          case state ud of
+            Menu (Adjust SwitchMap) -> do
+              beginPath ctx
+              fillColor ctx (rgb 0 255 0)
+              roundedRect ctx 650 220 150 50 10
+              closePath ctx
+              fill ctx
+            _ ->
+              return ()
+          beginPath ctx
+          roundedRect ctx 650 220 150 50 10
+          strokeWidth ctx 2
           stroke ctx
           fontSize ctx 25
           fontFace ctx "bedstead"
+          fillColor ctx (rgb 255 255 255)
+          textAlign ctx (S.fromList [AlignCenter, AlignTop])
+          textBox ctx 650 235 150 "Switch Map"
+          closePath ctx
+          beginPath ctx
+          roundedRect ctx 650 560 150 50 10
+          strokeWidth ctx 5
+          stroke ctx
+          closePath 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 ()

src/Types/StateData.hs

@@ -27,8 +27,9 @@ data StateData
     , mmImgMat    :: Matrix (Maybe ImgId)
     }
   | MenuData
-    { velocity :: V2 Double
-    , rotation :: Direction
-    , activate :: Double
+    { velocity  :: V2 Double
+    , rotation  :: Direction
+    , activate  :: Double
+    , switchMap :: Double
     }
   deriving (Eq)

src/Types/UserData.hs

@@ -66,12 +66,14 @@ data SubMenu
 defaultTranslation :: M.Map GamepadAction Action
 defaultTranslation = M.fromList
   [ (ButtonAction 0 SDL.JoyButtonPressed, Activate)
+  , (ButtonAction 7 SDL.JoyButtonPressed, SwitchMap)
   , (AxisAction 1, UpDown 1)
   , (AxisAction 0, LeftRight 1)
   ]
 
 data Action
   = Activate
+  | SwitchMap
   | UpDown Int
   | LeftRight Int
   deriving (Show, Eq)

src/Util.hs

@@ -302,8 +302,8 @@ emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
   ud <- getAffection
   let Subsystems _ _ _ _ t = subsystems ud
   case (translation ud) Map.!? (ButtonAction but SDL.JoyButtonPressed) of
-    Just Activate -> partEmit t (ActionMessage Activate time)
-    _             -> return ()
+    Just act -> partEmit t (ActionMessage act time)
+    _        -> return ()
 emitActionMessage _ = return ()
 
 fullClean :: Affection UserData ()