diff --git a/assets/icons/controller_blue.png b/assets/icons/controller_blue.png new file mode 100644 index 0000000..11911e4 Binary files /dev/null and b/assets/icons/controller_blue.png differ diff --git a/assets/icons/controller_green.png b/assets/icons/controller_green.png new file mode 100644 index 0000000..a9bc462 Binary files /dev/null and b/assets/icons/controller_green.png differ diff --git a/src/Init.hs b/src/Init.hs index aa2bb25..b817252 100644 --- a/src/Init.hs +++ b/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 diff --git a/src/Load.hs b/src/Load.hs index b71c1d0..5413828 100644 --- a/src/Load.hs +++ b/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 () diff --git a/src/Main.hs b/src/Main.hs index a52fe91..4d6a9e8 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index d381e02..8484751 100644 --- a/src/MainGame/WorldMap.hs +++ b/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 diff --git a/src/Menu.hs b/src/Menu.hs new file mode 100644 index 0000000..bbca091 --- /dev/null +++ b/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 diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 9f437ea..08a71d8 100644 --- a/src/StateMachine.hs +++ b/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 = [] diff --git a/src/Types/ImgId.hs b/src/Types/ImgId.hs index 4a6fb9d..32092b5 100644 --- a/src/Types/ImgId.hs +++ b/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 diff --git a/src/Types/StateData.hs b/src/Types/StateData.hs index b104a57..8b59fa4 100644 --- a/src/Types/StateData.hs +++ b/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 diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index dd85270..fbfecd2 100644 --- a/src/Types/UserData.hs +++ b/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 ())] diff --git a/tracer-game.cabal b/tracer-game.cabal index bec17cf..f4b38a8 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -40,6 +40,7 @@ executable tracer-game , Interior , Init , Load + , Menu , MainGame.WorldMap , MainGame.MindMap , Navigation