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 , stateData = None
, threadContext = Nothing , threadContext = Nothing
, controls = NoController , controls = NoController
, translation = defaultTranslation , translation = NoTranslation
, joyCache = [] , joyCache = []
} }

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -11,7 +11,7 @@ import Data.Graph.AStar
import Data.Maybe import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import Control.Monad (join) import Control.Monad (join, when)
import qualified SDL import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get) import qualified Graphics.Rendering.OpenGL as GL hiding (get)
@ -307,18 +307,46 @@ cacheJoypad msg = do
emitJoyActionMessage :: JoystickMessage -> Affection UserData () emitJoyActionMessage :: JoystickMessage -> Affection UserData ()
emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do
ud <- getAffection ud <- getAffection
case translation ud of
JoyTranslation tmap -> do
let Subsystems _ _ _ _ t = subsystems ud let Subsystems _ _ _ _ t = subsystems ud
case (translation ud) Map.!? (AxisAction axis) of vnormal = fromIntegral val / 32768
Just (UpDown s) -> partEmit t (ActionMessage (UpDown (s * fromIntegral val)) time) sigvnormal = abs vnormal
Just (LeftRight s) -> partEmit t (ActionMessage (LeftRight (s * fromIntegral val)) time) 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 ()
emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do _ -> return ()
emitJoyActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
ud <- getAffection ud <- getAffection
let Subsystems _ _ _ _ t = subsystems ud let Subsystems _ _ _ _ t = subsystems ud
case (translation ud) Map.!? (ButtonAction but SDL.JoyButtonPressed) of case (translation ud) of
JoyTranslation tmap -> do
case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
Just act -> partEmit t (ActionMessage act time) Just act -> partEmit t (ActionMessage act time)
_ -> return () _ -> return ()
emitActionMessage _ = 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 :: Affection UserData ()
fullClean = do fullClean = do