diff --git a/assets/icons/arrow.png b/assets/icons/arrow.png new file mode 100644 index 0000000..d787ec1 Binary files /dev/null and b/assets/icons/arrow.png differ diff --git a/src/Init.hs b/src/Init.hs index b817252..0a97706 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -47,6 +47,8 @@ init = do , stateData = None , threadContext = Nothing , joystick = Nothing + , translation = defaultTranslation + , joyCache = [] } loadPlayerSprite diff --git a/src/Load.hs b/src/Load.hs index 5413828..e85eacd 100644 --- a/src/Load.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 4d6a9e8..5fb265b 100644 --- a/src/Main.hs +++ b/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 () diff --git a/src/Menu.hs b/src/Menu.hs deleted file mode 100644 index bbca091..0000000 --- a/src/Menu.hs +++ /dev/null @@ -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 diff --git a/src/Menu/Connect.hs b/src/Menu/Connect.hs new file mode 100644 index 0000000..8d5a4d5 --- /dev/null +++ b/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 diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 08a71d8..aae0684 100644 --- a/src/StateMachine.hs +++ b/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 diff --git a/src/Types/ImgId.hs b/src/Types/ImgId.hs index 32092b5..9c45ebf 100644 --- a/src/Types/ImgId.hs +++ b/src/Types/ImgId.hs @@ -3,6 +3,7 @@ module Types.ImgId where data IconId = IconContrBlue | IconContrGreen + | IconArrow deriving (Show, Eq, Ord, Enum) data ImgId diff --git a/src/Types/StateData.hs b/src/Types/StateData.hs index 8b59fa4..8769b87 100644 --- a/src/Types/StateData.hs +++ b/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) diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index fbfecd2..06990d3 100644 --- a/src/Types/UserData.hs +++ b/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 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) + [ (ButtonAction 0 SDL.JoyButtonPressed, Activate) + , (AxisAction 0, UpDown 0) + , (AxisAction 1, LeftRight 0) ] data Action - = Jump - | Duck - | Kick - | Punch - | Grab - | Block - | GoLeft - | GoRight - | GoUp - | GoDown - | StopLR - | StopUD - deriving (Show, Eq, Ord, Enum) + = Activate + | UpDown Int + | LeftRight Int + deriving (Show, Eq) data GamepadAction - = ButtonAction Word SDL.JoyButtonState - | AxisAction Word AxisAlign - | HatAction Word SDL.JoyHatPosition + = ButtonAction Word8 SDL.JoyButtonState + | AxisAction Word8 + -- | 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 ())]) diff --git a/src/Util.hs b/src/Util.hs index fa39b11..ddd4e47 100644 --- a/src/Util.hs +++ b/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 () diff --git a/tracer-game.cabal b/tracer-game.cabal index f4b38a8..4d7dc6f 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -40,7 +40,7 @@ executable tracer-game , Interior , Init , Load - , Menu + , Menu.Connect , MainGame.WorldMap , MainGame.MindMap , Navigation