preparing controller adjustment

This commit is contained in:
nek0 2018-10-12 14:26:06 +02:00
parent 5f5e4d4827
commit dd7f1e1627
12 changed files with 306 additions and 118 deletions

BIN
assets/icons/arrow.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 14 KiB

View file

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

View file

@ -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

View file

@ -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 ()

View file

@ -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

224
src/Menu/Connect.hs Normal file
View file

@ -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

View file

@ -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

View file

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

View file

@ -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)

View file

@ -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 ())])

View file

@ -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 ()

View file

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