more joypad stuff

src/Init.hs

@@ -32,6 +32,7 @@ init = do
     <*> (SubMouse <$> newTVarIO [])
     <*> (SubKeyboard <$> newTVarIO [])
     <*> (SubJoypad <$> newTVarIO [])
+    <*> (SubTranslator <$> newTVarIO [])
   _ <- glewInit
   nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
   return UserData
@@ -40,10 +41,12 @@ init = do
     , assetImages     = M.empty
     , assetAnimations = M.empty
     , assetFonts      = M.empty
+    , assetIcons      = M.empty
     , nano            = nvg
     , uuid            = []
     , stateData       = None
     , threadContext   = Nothing
+    , joystick        = Nothing
     }
 
 loadPlayerSprite

src/Load.hs

@@ -20,6 +20,7 @@ import NanoVG hiding (V2(..))
 
 -- internal imports
 
+import Menu
 import Types
 import MainGame.WorldMap
 import Util
@@ -65,6 +66,16 @@ loadFork ws win glc nvg future progress = do
   let stateSteps = 37
       increment = 1 / stateSteps
   SDL.glMakeCurrent win glc
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading icon \"conntroller_blue\""
+    )))
+  mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") 0
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading icon \"conntroller_green\""
+    )))
+  mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_asc\""
@@ -190,6 +201,12 @@ loadFork ws win glc nvg future progress = do
     , "Loading asset \"watercooler\""
     )))
   mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") 0
+  let micons =
+        [ mcontrblue, mcontrgreen
+        ]
+  when (any isNothing micons) $ do
+    liftIO $logIO Error "Failed to load icon assets"
+    exitFailure
   let mimgs =
         [ mwallasc, mwalldesc
         , mwallcornern, mwallcornere, mwallcorners, mwallcornerw
@@ -215,6 +232,11 @@ loadFork ws win glc nvg future progress = do
         .. ImgMiscWatercooler
         ]
         mimgs
+      icons = zipWith (\a b -> (a, fromJust b))
+        [ IconContrBlue
+        .. IconContrGreen
+        ]
+        micons
       directions = [E .. N] ++ [NE]
       standIds var = map (AnimId var "standing") directions
       walkIds var = map (AnimId var "walking") directions
@@ -330,6 +352,7 @@ loadFork ws win glc nvg future progress = do
           toiletFree ++
           toiletOccupied
         )
+      , loadAssetIcons  = M.fromList icons
       }
     )
 
@@ -351,9 +374,12 @@ updateLoad _ = do
       putAffection ud
         { assetImages     = loadAssetImages ld
         , assetAnimations = loadAssetAnims ld
-        , state           = Main WorldMap
+        , assetIcons      = loadAssetIcons ld
+        -- , state           = Main WorldMap
+        , state           = Menu
         , stateData       = None
         }
-      loadMap
+      -- loadMap
+      loadMenu
     Nothing ->
       return ()

src/Main.hs

@@ -55,7 +55,7 @@ pre = do
   ud <- getAffection
   threadCtx <- SDL.glCreateContext (drawWindow ad)
   SDL.glMakeCurrent (drawWindow ad) (glContext ad)
-  let Subsystems w m k j = subsystems ud
+  let Subsystems w m k j t = subsystems ud
   _ <- partSubscribe w (fitViewport (1280/720))
   _ <- partSubscribe w exitOnWindowClose
   _ <- partSubscribe k toggleFullScreen
@@ -74,11 +74,12 @@ quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
     ad <- A.get
     ud <- getAffection
     when (state ud == Main WorldMap || state ud == Main MindMap) $ do
-      let Subsystems w m k j = subsystems ud
+      let Subsystems w m k j t = subsystems ud
       mapM_ (partUnSubscribe w) (uuid ud)
       mapM_ (partUnSubscribe m) (uuid ud)
       mapM_ (partUnSubscribe k) (uuid ud)
       mapM_ (partUnSubscribe j) (uuid ud)
+      mapM_ (partUnSubscribe t) (uuid ud)
       SDL.glMakeCurrent (drawWindow ad) (glContext ad)
       (ws, _) <- yieldSystemT (0, defStorage) (return ())
       putAffection ud

src/MainGame/WorldMap.hs

@@ -45,7 +45,7 @@ loadMap :: Affection UserData ()
 loadMap = do
   ud <- getAffection
   ad <- get
-  let (Subsystems _ m k _) = subsystems ud
+  let (Subsystems _ m k _ _) = subsystems ud
   uu1 <- partSubscribe m movePlayer
   uu2 <- partSubscribe k changeMaps
   uu3 <- partSubscribe m playerInteract

src/Menu.hs

@@ -0,0 +1,75 @@
+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/StateMachine.hs

@@ -7,26 +7,27 @@ import Affection
 import Types
 
 import Load
+import Menu
 import MainGame.WorldMap
 import MainGame.MindMap
 
 instance StateMachine State UserData where
+  smLoad Load = loadLoad
+  smLoad Menu = loadMenu
   smLoad (Main _) = loadMap
 
-  smLoad Load = loadLoad
-
+  smUpdate Load = updateLoad
+  smUpdate Menu = updateMenu
   smUpdate (Main WorldMap) = updateMap
   smUpdate (Main MindMap) = updateMind
 
-  smUpdate Load = updateLoad
-
+  smDraw Load = drawLoad
+  smDraw Menu = drawMenu
   smDraw (Main WorldMap) = drawMap
   smDraw (Main MindMap) = drawMind
 
-  smDraw Load = drawLoad
-
   smEvent _ evs = do
-    Subsystems w m k j <- subsystems <$> getAffection
+    Subsystems w m k j _ <- subsystems <$> getAffection
     _ <- consumeSDLEvents j =<<
       consumeSDLEvents k =<<
       consumeSDLEvents w =<<
@@ -35,13 +36,14 @@ instance StateMachine State UserData where
 
   smClean _ = do
     ud <- getAffection
-    let Subsystems w m k j = subsystems ud
-        toClean            = uuid ud
+    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/ImgId.hs

@@ -1,5 +1,10 @@
 module Types.ImgId where
 
+data IconId
+  = IconContrBlue
+  | IconContrGreen
+  deriving (Show, Eq, Ord, Enum)
+
 data ImgId
   = ImgEmpty -- TODO: Find better solution than empty image.
   | ImgEmptyNoWalk

src/Types/StateData.hs

@@ -15,6 +15,7 @@ data StateData
   | LoadData
     { loadAssetImages :: Map ImgId Image
     , loadAssetAnims  :: Map AnimId Animation
+    , loadAssetIcons  :: Map IconId Image
     }
   | MainData
     { mapMat      :: Matrix TileState

src/Types/UserData.hs

@@ -26,9 +26,12 @@ import Types.Entity
 data UserData = UserData
   { state           :: State
   , subsystems      :: Subsystems
+  , assetIcons      :: M.Map IconId Image
   , assetImages     :: M.Map ImgId Image
   , assetFonts      :: M.Map FontId T.Text
   , assetAnimations :: M.Map AnimId Animation
+  , joystick        :: Maybe SDL.Joystick
+  , translation     :: M.Map GamepadAction Action
   , nano            :: Context
   , uuid            :: [UUID]
   , worldState      :: SystemState Entity (AffectionState (AffectionData UserData) IO)
@@ -44,6 +47,7 @@ data UserData = UserData
 
 data State
   = Load
+  | Menu
   | Main SubMain
   deriving (Eq)
 
@@ -52,17 +56,72 @@ data SubMain
   | MindMap
   deriving (Eq)
 
+defaultTranslation :: M.Map GamepadAction Action
+defaultTranslation = M.fromList
+  [ (ButtonAction 0 SDL.JoyButtonPressed, Jump)
+  , (ButtonAction 1 SDL.JoyButtonPressed, Duck)
+  , (ButtonAction 2 SDL.JoyButtonPressed, Kick)
+  , (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
+  | Duck
+  | Kick
+  | Punch
+  | Grab
+  | Block
+  | GoLeft
+  | GoRight
+  | GoUp
+  | GoDown
+  | StopLR
+  | StopUD
+  deriving (Show, Eq, Ord, Enum)
+
+data GamepadAction
+  = ButtonAction Word SDL.JoyButtonState
+  | AxisAction Word AxisAlign
+  | HatAction Word SDL.JoyHatPosition
+  deriving (Show, Eq, Ord)
+
+data AxisAlign
+  = AxisPositive
+  | AxisNegative
+  | AxisNeutral
+  deriving (Show, Eq, Ord)
+
 data Subsystems = Subsystems
-  { subWindow   :: SubWindow
-  , subMouse    :: SubMouse
-  , subkeyboard :: SubKeyboard
-  , subJoypad   :: SubJoypad
+  { subWindow     :: SubWindow
+  , subMouse      :: SubMouse
+  , subkeyboard   :: SubKeyboard
+  , subJoypad     :: SubJoypad
+  , subTranslator :: SubTranslator
   }
 
-newtype SubWindow   = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())])
-newtype SubMouse    = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
-newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
-newtype SubJoypad   = SubJoypad (TVar [(UUID, JoystickMessage -> Affection UserData ())])
+data ActionMessage = ActionMessage
+  { amAction   :: Action
+  , amJoystick :: Word
+  , amTime     :: Double
+  }
+  deriving (Eq, Show)
+
+instance Message ActionMessage where
+  msgTime (ActionMessage _ _ t) = t
+
+newtype SubWindow     = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())])
+newtype SubMouse      = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
+newtype SubKeyboard   = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
+newtype SubJoypad     = SubJoypad (TVar [(UUID, JoystickMessage -> Affection UserData ())])
+newtype SubTranslator = SubTranslator (TVar [(UUID, ActionMessage -> Affection UserData ())])
 
 instance Participant SubWindow UserData where
   type Mesg SubWindow UserData = WindowMessage
@@ -112,6 +171,15 @@ instance Participant SubJoypad UserData where
 instance SDLSubsystem SubJoypad UserData where
   consumeSDLEvents = consumeSDLJoystickEvents
 
+instance Participant SubTranslator UserData where
+  type Mesg SubTranslator UserData = ActionMessage
+
+  partSubscribers (SubTranslator t) = generalSubscribers t
+
+  partSubscribe (SubTranslator t) = generalSubscribe t
+
+  partUnSubscribe (SubTranslator t) = generalUnSubscribe t
+
 generalSubscribers
   :: TVar [(UUID, msg -> Affection UserData ())]
   -> Affection UserData [(msg -> Affection UserData ())]

tracer-game.cabal

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