retrofitting

This commit is contained in:
nek0 2019-02-11 16:11:27 +01:00
parent 5067551373
commit 0497c97475
6 changed files with 60 additions and 32 deletions

View file

@ -46,7 +46,7 @@ init = do
, uuid = []
, stateData = None
, threadContext = Nothing
, joystick = Nothing
, controls = NoController
, translation = defaultTranslation
, joyCache = []
}

View file

@ -73,12 +73,22 @@ loadFork ws win glc nvg future progress = do
mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") 0
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading icon \"conntroller_green\""
, "Loading icon \"controller_blue\""
)))
mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading icon \"arrow\""
, "Loading icon \"controller_green\""
)))
mcontrblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading icon \"keyboard_blue\""
)))
mcontrgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading icon \"keyboard_green\""
)))
marrow <- createImage nvg (FileName "assets/icons/arrow.png") 0
modifyMVar_ progress (return . (\(p, _) ->

View file

@ -31,7 +31,7 @@ loadMenu = do
uu3 <- partSubscribe j emitJoyActionMessage
uu4 <- partSubscribe t handleActionMessages
uu5 <- partSubscribe m handleClicks
uu6 <- partSubscribe k emitKbdActionMessage
-- uu6 <- partSubscribe k emitKbdActionMessage
partUnSubscribe j (joyUUID ud)
putAffection ud
{ uuid = [ uu1, uu2, uu3, uu4, uu5 ]
@ -44,27 +44,28 @@ loadMenu = do
joystickConnect :: JoystickMessage -> Affection UserData ()
joystickConnect msg = do
ud <- getAffection
when (isNothing $ joystick ud) $ do
when (controls ud == NoController) $ do
mjoy <- joystickAutoConnect msg
maybe (return ()) (\joy -> do
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
putAffection ud
{ controls = Joystick
{ controls = Joystick 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
{ Controls = None
}
) (joystick ud)
case controls ud of
Joystick joy -> do
njoys <- joystickAutoDisconnect [joy] msg
when (null njoys) $ do
liftIO $ logIO A.Debug $ "Joystick disconnected"
putAffection ud
{ controls = None
}
_ -> return ()
handleActionMessages :: ActionMessage -> Affection UserData ()
handleActionMessages (ActionMessage Activate _) = do
@ -100,12 +101,16 @@ handleActionMessages (ActionMessage (LeftRight f) _) = do
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 || arrowDown rels) (adjustUpDown rels)
when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
when (buttonActivate rels) (adjustActivate)
when (buttonSwitchMap rels) (adjustSwitchMap)
when (buttonPlay rels) (enterGame)
ud <- getAffection
case controls ud of
Joystick -> do
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
when (arrowUp rels || arrowDown rels) (adjustUpDown rels)
when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
when (buttonActivate rels) (adjustActivate)
when (buttonSwitchMap rels) (adjustSwitchMap)
when (buttonPlay rels) (enterGame)
_ -> return ()
where
adjustUpDown rels = do
if arrowUp rels
@ -172,15 +177,26 @@ drawMenu = do
controller = controls ud
save ctx
beginPath ctx
paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
if isNothing controller
then IconContrBlue
else IconContrGreen
cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.!
case controller of
Joystick -> IconContrGreen
_ -> IconContrBlue
) 1
rect ctx 600 620 80 80
fillPaint ctx paint
fillPaint ctx cpaint
endPath ctx
fill ctx
when (controller /= None) $ do
beginPath ctx
cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.!
case controller of
Keyboard -> IconKbdGreen
_ -> IconKbdBlue
) 1
rect ctx 600 620 80 80
fillPaint ctx cpaint
endPath ctx
fill ctx
when (controller /= NoController) $ do
let V2 vx vy = velocity $ stateData ud
beginPath ctx
roundedRect ctx 140 110 1000 500 25
@ -264,9 +280,9 @@ drawMenu = do
_ ->
return ()
beginPath ctx
paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
apaint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
rect ctx 0 0 100 100
fillPaint ctx paint
fillPaint ctx apaint
closePath ctx
fill ctx
restore ctx

View file

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

View file

@ -48,9 +48,9 @@ data UserData = UserData
}
data Controller
= None
= NoController
| Keyboard
| Joystick
| Joystick SDL.Joystick
deriving (Eq, Show)
data State

View file

@ -304,8 +304,8 @@ cacheJoypad msg = do
{ joyCache = msg : joyCache ud
}
emitActionMessage :: JoystickMessage -> Affection UserData ()
emitActionMessage (MsgJoystickAxis time _ axis val) = do
emitJoyActionMessage :: JoystickMessage -> Affection UserData ()
emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do
ud <- getAffection
let Subsystems _ _ _ _ t = subsystems ud
case (translation ud) Map.!? (AxisAction axis) of