keyboard controls finished
This commit is contained in:
parent
c9c7f5ce5d
commit
c9dd91927e
8 changed files with 362 additions and 177 deletions
|
|
@ -47,7 +47,7 @@ init = do
|
|||
, stateData = None
|
||||
, threadContext = Nothing
|
||||
, controls = NoController
|
||||
, translation = defaultTranslation
|
||||
, translation = NoTranslation
|
||||
, joyCache = []
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
50
src/Util.hs
50
src/Util.hs
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue