preparing controller adjustment

src/Init.hs

@@ -47,6 +47,8 @@ init = do
     , stateData       = None
     , threadContext   = Nothing
     , joystick        = Nothing
+    , translation     = defaultTranslation
+    , joyCache        = []
     }
 
 loadPlayerSprite

src/Load.hs

@@ -20,7 +20,7 @@ import NanoVG hiding (V2(..))
 
 -- internal imports
 
-import Menu
+import Menu.Connect
 import Types
 import MainGame.WorldMap
 import Util
@@ -63,7 +63,7 @@ loadFork
   -> MVar (Float, T.Text)
   -> IO ()
 loadFork ws win glc nvg future progress = do
-  let stateSteps = 37
+  let stateSteps = 40
       increment = 1 / stateSteps
   SDL.glMakeCurrent win glc
   modifyMVar_ progress (return . (\(p, _) ->
@@ -76,6 +76,11 @@ loadFork ws win glc nvg future progress = do
     , "Loading icon \"conntroller_green\""
     )))
   mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading icon \"arrow\""
+    )))
+  marrow <- createImage nvg (FileName "assets/icons/arrow.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_asc\""
@@ -202,7 +207,7 @@ loadFork ws win glc nvg future progress = do
     )))
   mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") 0
   let micons =
-        [ mcontrblue, mcontrgreen
+        [ mcontrblue, mcontrgreen, marrow
         ]
   when (any isNothing micons) $ do
     liftIO $logIO Error "Failed to load icon assets"
@@ -234,7 +239,7 @@ loadFork ws win glc nvg future progress = do
         mimgs
       icons = zipWith (\a b -> (a, fromJust b))
         [ IconContrBlue
-        .. IconContrGreen
+        .. IconArrow
         ]
         micons
       directions = [E .. N] ++ [NE]
@@ -376,7 +381,7 @@ updateLoad _ = do
         , assetAnimations = loadAssetAnims ld
         , assetIcons      = loadAssetIcons ld
         -- , state           = Main WorldMap
-        , state           = Menu
+        -- , state           = Menu Connect
         , stateData       = None
         }
       -- loadMap

src/Main.hs

@@ -22,6 +22,7 @@ import Control.Monad (when)
 import Types hiding (draw)
 import StateMachine ()
 import Init
+import Util
 
 foreign import ccall unsafe "glewInit"
   glewInit :: IO CInt
@@ -60,11 +61,13 @@ pre = do
   _ <- partSubscribe w exitOnWindowClose
   _ <- partSubscribe k toggleFullScreen
   _ <- partSubscribe k quitGame
+  u <- partSubscribe j cacheJoypad
   (ws, _) <- yieldSystemT (0, defStorage) (return ())
   putAffection ud
     { threadContext = Just threadCtx
     , window     = Just (drawWindow ad)
     , worldState = ws
+    , joyUUID    = u
     }
 
 quitGame :: KeyboardMessage -> Affection UserData ()

src/Menu.hs

@@ -1,75 +0,0 @@
-module Menu where
-
-import Affection as A
-
-import qualified SDL
-
-import NanoVG
-
-import qualified Data.Map.Strict as M
-import Data.Maybe (isNothing)
-
-import Control.Monad (when)
-
--- internal imports
-
-import Types
-
-loadMenu :: Affection UserData ()
-loadMenu = do
-  ud <- getAffection
-  ad <- get
-  let (Subsystems _ m _ j _) = subsystems ud
-  uu1 <- partSubscribe j joystickConnect
-  uu2 <- partSubscribe j joyDisconnect
-  putAffection ud
-    { uuid  = [ uu1, uu2 ]
-    , state = Menu
-    }
-
-joystickConnect :: JoystickMessage -> Affection UserData ()
-joystickConnect msg = do
-  ud <- getAffection
-  when (isNothing $ joystick ud) $ do
-    mjoy <- joystickAutoConnect msg
-    maybe (return ()) (\joy -> do
-      ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
-      liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
-      putAffection ud
-        { joystick = Just joy
-        , translation = defaultTranslation
-        }
-      ) mjoy
-
-joyDisconnect :: JoystickMessage -> Affection UserData ()
-joyDisconnect msg = do
-  ud <- getAffection
-  maybe (return ()) (\joy -> do
-    njoys <- joystickAutoDisconnect [joy] msg
-    when (null njoys) $ do
-      liftIO $ logIO A.Debug $ "Joystick disconnected"
-      putAffection ud
-        { joystick = Nothing
-        }
-    ) (joystick ud)
-
-updateMenu :: Double -> Affection UserData ()
-updateMenu dt = return ()
-
-drawMenu :: Affection UserData ()
-drawMenu = do
-  ud <- getAffection
-  liftIO $ do
-    let ctx = nano ud
-        controller = joystick ud
-    save ctx
-    beginPath ctx
-    paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
-      if isNothing controller
-      then IconContrBlue
-      else IconContrGreen
-      ) 1
-    rect ctx 600 620 80 80
-    fillPaint ctx paint
-    fill ctx
-    restore ctx

src/Menu/Connect.hs

@@ -0,0 +1,224 @@
+module Menu.Connect where
+
+import Affection as A
+
+import qualified SDL hiding (V2)
+
+import NanoVG hiding (V2)
+
+import Linear hiding (rotate)
+
+import qualified Data.Set as S
+import qualified Data.Map.Strict as M
+import Data.Maybe (isNothing, isJust)
+
+import Control.Monad
+
+-- internal imports
+
+import Types
+import Util
+
+loadMenu :: Affection UserData ()
+loadMenu = do
+  ud <- getAffection
+  ad <- get
+  let (Subsystems _ m _ j t) = subsystems ud
+  uu1 <- partSubscribe j joystickConnect
+  uu2 <- partSubscribe j joystickDisconnect
+  uu3 <- partSubscribe j emitActionMessage
+  uu4 <- partSubscribe t handleActionMessages
+  uu5 <- partSubscribe m handleClicks
+  partUnSubscribe j (joyUUID ud)
+  putAffection ud
+    { uuid      = [ uu1, uu2, uu3, uu4 ]
+    , state     = Menu Connect
+    , stateData = MenuData (V2 0 0) S 0
+    , joyCache  = []
+    }
+  mapM_ (partEmit j) (joyCache ud)
+
+joystickConnect :: JoystickMessage -> Affection UserData ()
+joystickConnect msg = do
+  ud <- getAffection
+  when (isNothing $ joystick ud) $ do
+    mjoy <- joystickAutoConnect msg
+    maybe (return ()) (\joy -> do
+      ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
+      liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
+      putAffection ud
+        { joystick = Just joy
+        }
+      ) mjoy
+
+joystickDisconnect :: JoystickMessage -> Affection UserData ()
+joystickDisconnect msg = do
+  ud <- getAffection
+  maybe (return ()) (\joy -> do
+    njoys <- joystickAutoDisconnect [joy] msg
+    when (null njoys) $ do
+      liftIO $ logIO A.Debug $ "Joystick disconnected"
+      putAffection ud
+        { joystick = Nothing
+        }
+    ) (joystick ud)
+
+handleActionMessages :: ActionMessage -> Affection UserData ()
+handleActionMessages (ActionMessage Activate _) = do
+  ud <- getAffection
+  putAffection ud
+    { stateData = (stateData ud)
+      { activate = 0.5
+      }
+    }
+handleActionMessages (ActionMessage (UpDown f) _) = do
+  ud <- getAffection
+  let V2 vx _ = velocity $ stateData ud
+  putAffection ud
+    { stateData = (stateData ud)
+      { velocity = (V2 vx (fromIntegral f / 32768))
+      }
+    }
+handleActionMessages (ActionMessage (LeftRight f) _) = do
+  ud <- getAffection
+  let V2 _ vy = velocity $ stateData ud
+  putAffection ud
+    { stateData = (stateData ud)
+      { velocity = (V2 (fromIntegral f / 32768) vy)
+      }
+    }
+
+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
+  where
+  adjustUpDown = liftIO $ logIO A.Debug "TODO: adjustUpDown"
+  arrowUp (V2 rx ry) =
+    rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
+handleClicks _ = return ()
+
+updateMenu :: Double -> Affection UserData ()
+updateMenu dt = do
+  ud <- getAffection
+  putAffection ud
+    { stateData = MenuData
+      (velocity $ stateData ud)
+      (rotation $ stateData ud)
+      (max 0 ((activate $ stateData ud) - dt))
+    }
+
+drawMenu :: Affection UserData ()
+drawMenu = do
+  ud <- getAffection
+  liftIO $ do
+    let ctx = nano ud
+        controller = joystick ud
+    save ctx
+    beginPath ctx
+    paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
+      if isNothing controller
+      then IconContrBlue
+      else IconContrGreen
+      ) 1
+    rect ctx 600 620 80 80
+    fillPaint ctx paint
+    fill ctx
+    when (isJust controller) $ do
+      let V2 vx vy = velocity $ stateData ud
+      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)
+      stroke ctx
+      fill ctx
+      mapM_ (\deg -> do
+        let V2 px py = fmap realToFrac $
+              V2 360 360 - V2 50 50 + fmap realToFrac rot
+            rot@(V2 rx ry) = fmap (fromIntegral . floor) $
+              V2 0 120 `rotVec` deg :: V2 Int
+        save ctx
+        translate ctx (px + 50) (py + 50)
+        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
+            case state ud of
+              Menu (Adjust (UpDown _)) -> do
+                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
+            case state ud of
+              Menu (Adjust (LeftRight _)) -> do
+                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
+            case state ud of
+              Menu (Adjust (UpDown _)) -> do
+                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
+            case state ud of
+              Menu (Adjust (LeftRight _)) -> do
+                fillColor ctx (rgb 0 255 0)
+                roundedRect ctx 0 0 100 100 10
+                closePath ctx
+                fill ctx
+              _ ->
+                return ()
+        beginPath ctx
+        paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
+        rect ctx 0 0 100 100
+        fillPaint ctx paint
+        closePath ctx
+        fill ctx
+        restore ctx
+        ) [0, 90, 180, 270]
+      beginPath ctx
+      when (activate (stateData ud) > 0) $ do
+        fillColor ctx (rgb 255 128 0)
+        roundedRect ctx 650 160 150 50 10
+        fill 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)
+      textBox ctx 650 175 150 "Activate"
+      closePath ctx
+    restore ctx

src/StateMachine.hs

@@ -7,22 +7,22 @@ import Affection
 import Types
 
 import Load
-import Menu
+import Menu.Connect
 import MainGame.WorldMap
 import MainGame.MindMap
 
 instance StateMachine State UserData where
   smLoad Load = loadLoad
-  smLoad Menu = loadMenu
+  smLoad (Menu Connect) = loadMenu
   smLoad (Main _) = loadMap
 
   smUpdate Load = updateLoad
-  smUpdate Menu = updateMenu
+  smUpdate (Menu Connect) = updateMenu
   smUpdate (Main WorldMap) = updateMap
   smUpdate (Main MindMap) = updateMind
 
   smDraw Load = drawLoad
-  smDraw Menu = drawMenu
+  smDraw (Menu Connect) = drawMenu
   smDraw (Main WorldMap) = drawMap
   smDraw (Main MindMap) = drawMind
 

src/Types/ImgId.hs

@@ -3,6 +3,7 @@ module Types.ImgId where
 data IconId
   = IconContrBlue
   | IconContrGreen
+  | IconArrow
   deriving (Show, Eq, Ord, Enum)
 
 data ImgId

src/Types/StateData.hs

@@ -3,12 +3,15 @@ module Types.StateData where
 import Data.Matrix
 import Data.Map
 
-import NanoVG
+import NanoVG hiding (V2)
+
+import Linear (V2)
 
 import Types.ReachPoint
 import Types.Map
 import Types.ImgId
 import Types.Animation
+import Types.Direction
 
 data StateData
   = None
@@ -23,4 +26,9 @@ data StateData
     , reachPoints :: [ReachPoint]
     , mmImgMat    :: Matrix (Maybe ImgId)
     }
+  | MenuData
+    { velocity :: V2 Double
+    , rotation :: Direction
+    , activate :: Double
+    }
   deriving (Eq)

src/Types/UserData.hs

@@ -43,11 +43,13 @@ data UserData = UserData
   , stateProgress   :: MVar (Float, T.Text)
   , threadContext   :: Maybe SDL.GLContext
   , window          :: Maybe SDL.Window
+  , joyCache        :: [JoystickMessage]
+  , joyUUID         :: UUID
   }
 
 data State
   = Load
-  | Menu
+  | Menu SubMenu
   | Main SubMain
   deriving (Eq)
 
@@ -56,41 +58,28 @@ data SubMain
   | MindMap
   deriving (Eq)
 
+data SubMenu
+  = Connect
+  | Adjust Action
+  deriving (Eq)
+
 defaultTranslation :: M.Map GamepadAction Action
 defaultTranslation = M.fromList
-  [ (ButtonAction 0 SDL.JoyButtonPressed, Jump)
+  [ (ButtonAction 0 SDL.JoyButtonPressed, Activate)
-  , (ButtonAction 1 SDL.JoyButtonPressed, Duck)
+  , (AxisAction 0, UpDown 0)
-  , (ButtonAction 2 SDL.JoyButtonPressed, Kick)
+  , (AxisAction 1, LeftRight 0)
-  , (ButtonAction 3 SDL.JoyButtonPressed, Punch)
-  , (ButtonAction 4 SDL.JoyButtonPressed, Grab)
-  , (ButtonAction 5 SDL.JoyButtonPressed, Block)
-  , (AxisAction 0 AxisNegative, GoLeft)
-  , (AxisAction 0 AxisPositive, GoRight)
-  , (AxisAction 0 AxisNeutral, StopLR)
-  , (AxisAction 1 AxisNegative, GoUp)
-  , (AxisAction 1 AxisPositive, GoDown)
-  , (AxisAction 1 AxisNeutral, StopUD)
   ]
 
 data Action
-  = Jump
+  = Activate
-  | Duck
+  | UpDown Int
-  | Kick
+  | LeftRight Int
-  | Punch
+  deriving (Show, Eq)
-  | Grab
-  | Block
-  | GoLeft
-  | GoRight
-  | GoUp
-  | GoDown
-  | StopLR
-  | StopUD
-  deriving (Show, Eq, Ord, Enum)
 
 data GamepadAction
-  = ButtonAction Word SDL.JoyButtonState
+  = ButtonAction Word8 SDL.JoyButtonState
-  | AxisAction Word AxisAlign
+  | AxisAction Word8
-  | HatAction Word SDL.JoyHatPosition
+  -- | HatAction Word SDL.JoyHatPosition
   deriving (Show, Eq, Ord)
 
 data AxisAlign
@@ -109,13 +98,12 @@ data Subsystems = Subsystems
 
 data ActionMessage = ActionMessage
   { amAction   :: Action
-  , amJoystick :: Word
   , amTime     :: Double
   }
   deriving (Eq, Show)
 
 instance Message ActionMessage where
-  msgTime (ActionMessage _ _ t) = t
+  msgTime (ActionMessage _ t) = t
 
 newtype SubWindow     = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())])
 newtype SubMouse      = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())])

src/Util.hs

@@ -18,7 +18,7 @@ import qualified Graphics.Rendering.OpenGL as GL hiding (get)
 
 import System.Exit (exitFailure)
 
-import Linear hiding (E(..))
+import Linear hiding (E(..), translation)
 
 import NanoVG hiding (V2(..))
 import NanoVG.Internal.Image (ImageFlags(..))
@@ -273,3 +273,35 @@ direction vel'@(V2 vr _) = if sqrt (vel' `dot` vel') > 0
           | otherwise                = NE
     in Just d
   else Nothing
+
+rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
+rotVec (V2 x y) deg = V2 nx ny
+  where
+    nx   = x * cos (dtor deg) + y * sin (dtor deg)
+    ny   = x * sin (dtor deg) - y * cos (dtor deg)
+
+dtor :: (Num a, Floating a) => a -> a
+dtor = (pi / 180 *)
+
+cacheJoypad :: JoystickMessage -> Affection UserData ()
+cacheJoypad msg = do
+  ud <- getAffection
+  putAffection ud
+    { joyCache = msg : joyCache ud
+    }
+
+emitActionMessage :: JoystickMessage -> Affection UserData ()
+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)
+    _                  -> return ()
+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 ()
+emitActionMessage _ = return ()

tracer-game.cabal

@@ -40,7 +40,7 @@ executable tracer-game
                      , Interior
                      , Init
                      , Load
-                     , Menu
+                     , Menu.Connect
                      , MainGame.WorldMap
                      , MainGame.MindMap
                      , Navigation