keyboard controls finished

This commit is contained in:
nek0 2019-02-12 00:11:53 +01:00
parent c9c7f5ce5d
commit c9dd91927e
8 changed files with 362 additions and 177 deletions

View file

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

View file

@ -80,12 +80,12 @@ loadFork ws win glc nvg future progress = do
( p + increment
, "Loading icon \"controller_green\""
)))
mcontrblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0
mkbdblue <- 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
mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading icon \"keyboard_green\""
@ -267,7 +267,7 @@ loadFork ws win glc nvg future progress = do
)))
mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") 0
let micons =
[ mcontrblue, mcontrgreen, marrow
[ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow
]
when (any isNothing micons) $ do
liftIO $logIO Error "Failed to load icon assets"

View file

@ -46,19 +46,17 @@ loadMap = do
ud <- getAffection
ad <- get
let (Subsystems _ m k j t) = subsystems ud
uu1 <- partSubscribe m movePlayer
uu2 <- partSubscribe k changeMaps
uu3 <- partSubscribe m playerInteract
uu4 <- partSubscribe j emitActionMessage
uu5 <- partSubscribe t movePlayer2
uu6 <- partSubscribe t playerInteract2
uu7 <- partSubscribe t changeMaps2
uu0 <- partSubscribe k emitKbdActionMessage
uu1 <- partSubscribe j emitJoyActionMessage
uu2 <- partSubscribe t movePlayer2
uu3 <- partSubscribe t playerInteract2
uu4 <- partSubscribe t changeMaps2
future <- liftIO newEmptyMVar
progress <- liftIO $ newMVar (0, "Ohai!")
_ <- liftIO $ forkIO $ loadMapFork ud ad future progress
putAffection ud
{ stateData = None
, uuid = [ uu1, uu2, uu3, uu4, uu5, uu6, uu7 ]
, uuid = [ uu0, uu1, uu2, uu3, uu4 ]
, stateMVar = future
, stateProgress = progress
, state = Main WorldMap
@ -67,20 +65,22 @@ loadMap = do
changeMaps :: KeyboardMessage -> Affection UserData ()
changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do
ud <- getAffection
putAffection ud
{ state = Main WorldMap
}
| SDL.keysymKeycode sym == SDL.KeycodeF2 = do
ud <- getAffection
putAffection ud
{ state = Main MindMap
}
ud <- getAffection
case state ud of
Main MindMap ->
putAffection ud
{ state = Main WorldMap
}
Main WorldMap ->
putAffection ud
{ state = Main MindMap
}
_ -> return ()
| otherwise = return ()
changeMaps _ = return ()
changeMaps2 :: ActionMessage -> Affection UserData ()
changeMaps2 (ActionMessage SwitchMap _) = do
changeMaps2 (ActionMessage ActSwitchMap _) = do
ud <- getAffection
case state ud of
Main MindMap ->
@ -272,60 +272,116 @@ loadMapFork ud ad future progress = do
, roomGraph = gr
})
mouseToPlayer :: V2 Int32 -> Affection UserData ()
mouseToPlayer mv2 = do
ud <- getAffection
(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
return $ unchanged
{ xyvel = Set $ V2 rx ry
}
putAffection ud
{ worldState = nws
}
-- mouseToPlayer :: V2 Int32 -> Affection UserData ()
-- mouseToPlayer mv2 = do
-- ud <- getAffection
-- (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
-- (nws, _) <- yieldSystemT (worldState ud) $
-- emap allEnts $ do
-- with player
-- return $ unchanged
-- { xyvel = Set $ V2 rx ry
-- }
-- putAffection ud
-- { worldState = nws
-- }
--
-- movePlayer :: MouseMessage -> Affection UserData ()
-- movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m
-- movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
-- mouseToPlayer m
-- movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
-- ud <- getAffection
-- (nws, _) <- yieldSystemT (worldState ud) $
-- emap allEnts $ do
-- with player
-- return $ unchanged
-- { xyvel = Set $ V2 0 0
-- }
-- putAffection ud
-- { worldState = nws
-- }
-- movePlayer _ = return ()
movePlayer :: MouseMessage -> Affection UserData ()
movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m
movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
mouseToPlayer m
movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
return $ unchanged
{ xyvel = Set $ V2 0 0
}
putAffection ud
{ worldState = nws
}
movePlayer _ = return ()
movePlayerKbd :: KeyboardMessage -> Affection UserData ()
movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
| SDL.keysymKeycode sym == SDL.KeycodeW = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 vx _) <- query xyvel
let ry = if (press == SDL.Pressed)
then 1
else 0
return $ unchanged
{ xyvel = Set $ V2 vx ry
}
putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeS = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 vx _) <- query xyvel
let ry = if (press == SDL.Pressed)
then -1
else 0
return $ unchanged
{ xyvel = Set $ V2 vx ry
}
putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeA = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 _ vy) <- query xyvel
let rx = if (press == SDL.Pressed)
then -1
else 0
return $ unchanged
{ xyvel = Set $ V2 rx vy
}
putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeD = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 _ vy) <- query xyvel
let rx = if (press == SDL.Pressed)
then 1
else 0
return $ unchanged
{ xyvel = Set $ V2 rx vy
}
putAffection ud
{ worldState = nws
}
| otherwise = return ()
movePlayerKbd _ = return ()
movePlayer2 :: ActionMessage -> Affection UserData ()
movePlayer2 (ActionMessage (UpDown f) _) = do
movePlayer2 (ActionMessage mov _) = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
V2 vx _ <- query xyvel
let ry = fromIntegral f / if f < 0 then 32768 :: Double else 32767 :: Double
V2 vx vy <- query xyvel
return $ unchanged
{ xyvel = Set $ V2 vx ry
}
putAffection ud
{ worldState = nws
}
movePlayer2 (ActionMessage (LeftRight f) _) = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
V2 _ vy <- query xyvel
let rx = fromIntegral f / if f < 0 then 32768 :: Double else 32767 :: Double
return $ unchanged
{ xyvel = Set $ V2 rx vy
{ xyvel = Set $ case mov of
ActUp f -> V2 vx (-f)
ActDown f -> V2 vx f
ActLeft f -> V2 (-f) vy
ActRight f -> V2 f vy
_ -> V2 vx vy
}
putAffection ud
{ worldState = nws
@ -384,7 +440,7 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
playerInteract _ = return ()
playerInteract2 :: ActionMessage -> Affection UserData ()
playerInteract2 (ActionMessage Activate _) = do
playerInteract2 (ActionMessage ActActivate _) = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $ do
pdata <- efor allEnts $ do

View file

@ -16,13 +16,13 @@ import Data.Maybe (fromJust, isJust)
import Types
import Util
loadAdjust :: Action -> Affection UserData () -> Affection UserData ()
loadAdjust sub switchBack = do
loadAdjust :: Action -> Controller -> Affection UserData () -> Affection UserData ()
loadAdjust sub contr switchBack = do
ud <- getAffection
let Subsystems w m k j t = subsystems ud
uu1 <- partSubscribe j (joyListener switchBack)
putAffection ud
{ state = Menu (Adjust sub)
{ state = Menu (Adjust sub contr)
, uuid = [ uu1 ]
}
@ -30,38 +30,64 @@ joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
ud <- getAffection
liftIO $ logIO A.Debug ("switching " ++ show (state ud) ++ " to " ++ show axis)
case state ud of
Menu (Adjust (UpDown s)) -> do
let k = fst <$> find (\(_, v) -> v == UpDown 1 || v == UpDown (-1)) (M.assocs $ translation ud)
putAffection ud
{ translation =
M.insert (AxisAction $ fromIntegral axis) (UpDown (fromIntegral $ -signum val)) $
if isJust k then M.delete (fromJust k) (translation ud) else translation ud
}
Menu (Adjust (LeftRight s)) -> do
let k = fst <$> find (\(_, v) -> v == LeftRight 1 || v == LeftRight (-1)) (M.assocs $ translation ud)
putAffection ud
{ translation =
M.insert (AxisAction $ fromIntegral axis) (LeftRight (fromIntegral $ signum val)) $
if isJust k then M.delete (fromJust k) (translation ud) else translation ud
}
fullClean
switchBack
let trans = translation ud
align
| val > 0 = AxisPositive
| val < 0 = AxisNegative
| otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*")
case trans of
JoyTranslation tmap -> do
case state ud of
Menu (Adjust (ActUp s) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == ActUp 1) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (AxisAction (fromIntegral axis) align) (ActUp 1) $
if isJust k then M.delete (fromJust k) (tmap) else tmap
}
Menu (Adjust (ActDown s) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == ActDown 1) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (AxisAction (fromIntegral axis) align) (ActDown 1) $
if isJust k then M.delete (fromJust k) (tmap) else tmap
}
Menu (Adjust (ActLeft s) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == ActLeft 1) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (AxisAction (fromIntegral axis) align) (ActLeft 1) $
if isJust k then M.delete (fromJust k) (tmap) else tmap
}
Menu (Adjust (ActRight s) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == ActRight 1) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (AxisAction (fromIntegral axis) align) (ActRight 1) $
if isJust k then M.delete (fromJust k) (tmap) else tmap
}
fullClean
switchBack
_ -> return ()
joyListener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do
ud <- getAffection
case state ud of
Menu (Adjust (UpDown s)) -> return ()
Menu (Adjust (LeftRight s)) -> return ()
Menu (Adjust (act)) -> do
let k = fst <$> find (\(_, v) -> v == act) (M.assocs $ translation ud)
putAffection ud
{ translation =
M.insert (ButtonAction but SDL.JoyButtonPressed) act $
if isJust k then M.delete (fromJust k) (translation ud) else translation ud
}
_ -> return ()
fullClean
switchBack
case translation ud of
JoyTranslation tmap -> do
case state ud of
Menu (Adjust (ActUp _) (Joystick _)) -> return ()
Menu (Adjust (ActDown _) (Joystick _)) -> return ()
Menu (Adjust (ActLeft _) (Joystick _)) -> return ()
Menu (Adjust (ActRight _) (Joystick _)) -> return ()
Menu (Adjust (act) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (ButtonAction but SDL.JoyButtonPressed) act $
if isJust k then M.delete (fromJust k) tmap else tmap
}
_ -> return ()
fullClean
switchBack
joyListener _ _ = return ()
drawAdjust :: Affection UserData ()

View file

@ -6,7 +6,7 @@ import qualified SDL hiding (V2)
import NanoVG hiding (V2)
import Linear hiding (rotate)
import Linear hiding (rotate, translation)
import qualified Data.Set as S
import qualified Data.Map.Strict as M
@ -29,12 +29,13 @@ loadMenu = do
uu1 <- partSubscribe j joystickConnect
uu2 <- partSubscribe j joystickDisconnect
uu3 <- partSubscribe j emitJoyActionMessage
uu4 <- partSubscribe t handleActionMessages
uu5 <- partSubscribe m handleClicks
uu4 <- partSubscribe k emitKbdActionMessage
uu5 <- partSubscribe t handleActionMessages
uu6 <- partSubscribe m handleClicks
-- uu6 <- partSubscribe k emitKbdActionMessage
partUnSubscribe j (joyUUID ud)
putAffection ud
{ uuid = [ uu1, uu2, uu3, uu4, uu5 ]
{ uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
, state = Menu Connect
, stateData = MenuData (V2 0 0) S 0 0
, joyCache = []
@ -51,6 +52,7 @@ joystickConnect msg = do
liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
putAffection ud
{ controls = Joystick joy
, translation = JoyTranslation defaultJoyTranslation
}
) mjoy
@ -63,77 +65,104 @@ joystickDisconnect msg = do
when (null njoys) $ do
liftIO $ logIO A.Debug $ "Joystick disconnected"
putAffection ud
{ controls = None
{ controls = NoController
, translation = NoTranslation
}
_ -> return ()
handleActionMessages :: ActionMessage -> Affection UserData ()
handleActionMessages (ActionMessage Activate _) = do
handleActionMessages (ActionMessage ActActivate _) = do
ud <- getAffection
putAffection ud
{ stateData = (stateData ud)
{ activate = 0.5
}
}
handleActionMessages (ActionMessage SwitchMap _) = do
handleActionMessages (ActionMessage ActSwitchMap _) = do
ud <- getAffection
putAffection ud
{ stateData = (stateData ud)
{ switchMap = 0.5
}
}
handleActionMessages (ActionMessage (UpDown f) _) = do
handleActionMessages (ActionMessage (ActUp f) _) = do
ud <- getAffection
let V2 vx _ = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 vx (fromIntegral f / 32768))
{ velocity = (V2 vx (-f))
}
}
handleActionMessages (ActionMessage (LeftRight f) _) = do
handleActionMessages (ActionMessage (ActDown f) _) = do
ud <- getAffection
let V2 vx _ = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 vx f)
}
}
handleActionMessages (ActionMessage (ActLeft f) _) = do
ud <- getAffection
let V2 _ vy = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 (fromIntegral f / 32768) vy)
{ velocity = (V2 (-f) vy)
}
}
handleActionMessages (ActionMessage (ActRight f) _) = do
ud <- getAffection
let V2 _ vy = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 f vy)
}
}
handleClicks :: MouseMessage -> Affection UserData ()
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
ud <- getAffection
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
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 ()
Joystick _ -> do
when (arrowUp rels) adjustKbdUp
when (arrowDown rels) adjustKbdDown
when (arrowLeft rels) adjustKbdLeft
when (arrowRight rels) adjustKbdRight
when (buttonActivate rels) adjustKbdActivate
when (buttonSwitchMap rels) adjustKbdSwitchMap
when (buttonPlay rels) enterGame
NoController -> do
when (kbdIcon rels) $
putAffection ud
{ controls = Keyboard
, translation = KbdTranslation defaultKbdTranslation
}
Keyboard -> do
when (kbdIcon rels) $
putAffection ud
{ controls = NoController
, translation = NoTranslation
}
when (buttonPlay rels) enterGame
where
adjustUpDown rels = do
if arrowUp rels
then do
adjustKbdUp = do
fullClean
loadAdjust (UpDown 1) loadMenu
else do
loadAdjust (ActUp 1) Keyboard loadMenu
adjustKbdDown = do
fullClean
loadAdjust (UpDown (-1)) loadMenu
adjustLeftRight rels = do
if arrowLeft rels
then do
loadAdjust (ActDown 1) Keyboard loadMenu
adjustKbdLeft = do
fullClean
loadAdjust (LeftRight 1) loadMenu
else do
loadAdjust (ActLeft 1) Keyboard loadMenu
adjustKbdRight = do
fullClean
loadAdjust (LeftRight (-1)) loadMenu
adjustActivate = do
loadAdjust (ActRight 1) Keyboard loadMenu
adjustKbdActivate = do
fullClean
loadAdjust Activate loadMenu
adjustSwitchMap = do
loadAdjust ActActivate Keyboard loadMenu
adjustKbdSwitchMap = do
fullClean
loadAdjust SwitchMap loadMenu
loadAdjust ActSwitchMap Keyboard loadMenu
enterGame = do
fullClean
loadMap
@ -151,6 +180,8 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
rx > 650 / 1280 && rx < 800 / 1280 && ry > 220 / 720 && ry < 270 / 720
buttonPlay (V2 rx ry) =
rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
kbdIcon (V2 rx ry) =
rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720
handleClicks _ = return ()
updateMenu :: Double -> Affection UserData ()
@ -179,12 +210,12 @@ drawMenu = do
beginPath ctx
cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.!
case controller of
Joystick -> IconContrGreen
_ -> IconContrBlue
Joystick _ -> IconContrGreen
_ -> IconContrBlue
) 1
rect ctx 600 620 80 80
rect ctx 550 620 80 80
fillPaint ctx cpaint
endPath ctx
closePath ctx
fill ctx
beginPath ctx
cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.!
@ -192,9 +223,9 @@ drawMenu = do
Keyboard -> IconKbdGreen
_ -> IconKbdBlue
) 1
rect ctx 600 620 80 80
rect ctx 650 620 80 80
fillPaint ctx cpaint
endPath ctx
closePath ctx
fill ctx
when (controller /= NoController) $ do
let V2 vx vy = velocity $ stateData ud
@ -223,7 +254,13 @@ drawMenu = do
closePath ctx
fill ctx
case state ud of
Menu (Adjust (UpDown _)) -> do
Menu (Adjust (ActUp _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
Menu (Adjust (ActDown _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
@ -239,7 +276,13 @@ drawMenu = do
closePath ctx
fill ctx
case state ud of
Menu (Adjust (LeftRight _)) -> do
Menu (Adjust (ActLeft _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
Menu (Adjust (ActRight _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
@ -255,7 +298,13 @@ drawMenu = do
closePath ctx
fill ctx
case state ud of
Menu (Adjust (UpDown _)) -> do
Menu (Adjust (ActUp _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
Menu (Adjust (ActDown _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
@ -271,7 +320,13 @@ drawMenu = do
closePath ctx
fill ctx
case state ud of
Menu (Adjust (LeftRight _)) -> do
Menu (Adjust (ActLeft _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
Menu (Adjust (ActRight _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 0 0 100 100 10
@ -294,7 +349,7 @@ drawMenu = do
fill ctx
closePath ctx
case state ud of
Menu (Adjust Activate) -> do
Menu (Adjust ActActivate _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 650 160 150 50 10
@ -319,7 +374,7 @@ drawMenu = do
fill ctx
closePath ctx
case state ud of
Menu (Adjust SwitchMap) -> do
Menu (Adjust ActSwitchMap _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
roundedRect ctx 650 220 150 50 10

View file

@ -21,13 +21,13 @@ instance StateMachine State UserData where
smUpdate Load = updateLoad
smUpdate (Menu Connect) = updateMenu
smUpdate (Menu (Adjust _)) = const (return ())
smUpdate (Menu (Adjust _ _)) = const (return ())
smUpdate (Main WorldMap) = updateMap
smUpdate (Main MindMap) = updateMind
smDraw Load = drawLoad
smDraw (Menu Connect) = drawMenu
smDraw (Menu (Adjust _)) = drawMenu >> drawAdjust
smDraw (Menu (Adjust _ _)) = drawMenu >> drawAdjust
smDraw (Main WorldMap) = drawMap
smDraw (Main MindMap) = drawMind

View file

@ -31,7 +31,7 @@ data UserData = UserData
, assetFonts :: M.Map FontId T.Text
, assetAnimations :: M.Map AnimId Animation
, controls :: Controller -- Maybe SDL.Joystick
, translation :: M.Map GamepadAction Action
, translation :: Translation
, nano :: Context
, uuid :: [UUID]
, worldState :: SystemState Entity (AffectionState (AffectionData UserData) IO)
@ -66,27 +66,47 @@ data SubMain
data SubMenu
= Connect
| Adjust Action
| Adjust Action Controller
deriving (Eq, Show)
defaultTranslation :: M.Map GamepadAction Action
defaultTranslation = M.fromList
[ (ButtonAction 0 SDL.JoyButtonPressed, Activate)
, (ButtonAction 7 SDL.JoyButtonPressed, SwitchMap)
, (AxisAction 1, UpDown 1)
, (AxisAction 0, LeftRight 1)
defaultJoyTranslation :: M.Map JoypadAction Action
defaultJoyTranslation = M.fromList
[ (ButtonAction 0 SDL.JoyButtonPressed, ActActivate)
, (ButtonAction 7 SDL.JoyButtonPressed, ActSwitchMap)
, (AxisAction 1 AxisNegative, ActUp 1)
, (AxisAction 1 AxisPositive, ActDown 1)
, (AxisAction 0 AxisNegative, ActLeft 1)
, (AxisAction 0 AxisPositive, ActRight 1)
]
data Action
= Activate
| SwitchMap
| UpDown Int
| LeftRight Int
defaultKbdTranslation :: M.Map SDL.Keycode Action
defaultKbdTranslation = M.fromList
[ (SDL.KeycodeSpace, ActActivate)
, (SDL.KeycodeF1, ActSwitchMap)
, (SDL.KeycodeW, ActUp 1)
, (SDL.KeycodeS, ActDown 1)
, (SDL.KeycodeA, ActLeft 1)
, (SDL.KeycodeD, ActRight 1)
]
data Translation
= JoyTranslation (M.Map JoypadAction Action)
| KbdTranslation (M.Map SDL.Keycode Action)
| NoTranslation
deriving (Show, Eq)
data GamepadAction
data Action
= ActActivate
| ActSwitchMap
| ActUp Double
| ActDown Double
| ActLeft Double
| ActRight Double
deriving (Show, Eq)
data JoypadAction
= ButtonAction Word8 SDL.JoyButtonState
| AxisAction Word8
| AxisAction Word8 AxisAlign
-- | HatAction Word SDL.JoyHatPosition
deriving (Show, Eq, Ord)

View file

@ -11,7 +11,7 @@ import Data.Graph.AStar
import Data.Maybe
import qualified Data.Text as T
import Control.Monad (join)
import Control.Monad (join, when)
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get)
@ -307,18 +307,46 @@ cacheJoypad msg = 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
Just (UpDown s) -> partEmit t (ActionMessage (UpDown (s * fromIntegral val)) time)
Just (LeftRight s) -> partEmit t (ActionMessage (LeftRight (s * fromIntegral val)) time)
_ -> return ()
emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
case translation ud of
JoyTranslation tmap -> do
let Subsystems _ _ _ _ t = subsystems ud
vnormal = fromIntegral val / 32768
sigvnormal = abs vnormal
align
| signum vnormal >= 0 = AxisPositive
| signum vnormal < 0 = AxisNegative
case tmap Map.!? (AxisAction axis align) of
Just (ActUp _) -> partEmit t (ActionMessage (ActUp sigvnormal) time)
Just (ActDown _) -> partEmit t (ActionMessage (ActDown sigvnormal) time)
Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
_ -> return ()
_ -> return ()
emitJoyActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
ud <- getAffection
let Subsystems _ _ _ _ t = subsystems ud
case (translation ud) Map.!? (ButtonAction but SDL.JoyButtonPressed) of
Just act -> partEmit t (ActionMessage act time)
_ -> return ()
emitActionMessage _ = return ()
case (translation ud) of
JoyTranslation tmap -> do
case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
Just act -> partEmit t (ActionMessage act time)
_ -> return ()
emitJoyActionMessage _ = return ()
emitKbdActionMessage :: KeyboardMessage -> Affection UserData ()
emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do
ud <- getAffection
let Subsystems _ _ _ _ t = subsystems ud
val = if press == SDL.Pressed then 1 else 0
case (translation ud) of
KbdTranslation tmap -> do
case tmap Map.!? SDL.keysymKeycode sym of
Just (ActUp _) -> partEmit t (ActionMessage (ActUp val) time)
Just (ActDown _) -> partEmit t (ActionMessage (ActDown val) time)
Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft val) time)
Just (ActRight _) -> partEmit t (ActionMessage (ActRight val) time)
Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time))
_ -> return ()
emitKbdActionMessage _ = return ()
fullClean :: Affection UserData ()
fullClean = do