more joypad stuff

This commit is contained in:
nek0 2018-10-08 23:36:52 +02:00
parent a52cb93d78
commit 5f5e4d4827
12 changed files with 204 additions and 22 deletions

Binary file not shown.

After

Width:  |  Height:  |  Size: 5.3 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 5.4 KiB

View file

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

View file

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

View file

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

View file

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

75
src/Menu.hs Normal file
View file

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

View file

@ -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 = []

View file

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

View file

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

View file

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

View file

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