bumped module Menu.Adjust to affection 0.0.0.10
This commit is contained in:
parent
81e16c4428
commit
ace1f0ce8c
1 changed files with 58 additions and 82 deletions
|
|
@ -10,98 +10,74 @@ import qualified Data.Map.Strict as M
|
|||
import qualified Data.Set as S
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromJust, isJust)
|
||||
import Data.String
|
||||
import Data.String (fromString)
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Types
|
||||
import Util
|
||||
|
||||
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 contr)
|
||||
, uuid = [ uu1 ]
|
||||
}
|
||||
loadAdjust :: UserData -> Action -> Controller -> Affection () -> Affection ()
|
||||
loadAdjust ud sub contr switchBack = do
|
||||
let Subsystems _ _ _ j _ = subsystems ud
|
||||
uu1 <- partSubscribe j (joyListener ud switchBack)
|
||||
void $ liftIO $ swapMVar (state ud) (Menu (Adjust sub contr))
|
||||
void $ liftIO $ swapMVar (uuid ud) [uu1]
|
||||
|
||||
joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
|
||||
joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
|
||||
ud <- getAffection
|
||||
liftIO $ logIO
|
||||
A.Debug
|
||||
("switching " <>
|
||||
fromString (show $ state ud) <>
|
||||
" to " <>
|
||||
fromString (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
|
||||
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 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
|
||||
}
|
||||
joyListener :: UserData -> Affection () -> JoystickMessage -> Affection ()
|
||||
joyListener ud switchBack message = do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
trans <- liftIO $ readMVar (translation ud)
|
||||
case message of
|
||||
MsgJoystickAxis _ _ axis val -> do
|
||||
let 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
|
||||
let (Menu (Adjust cact (Joystick _))) = curState
|
||||
act = case cact of
|
||||
ActUp _ -> ActUp 1
|
||||
ActDown _ -> ActDown 1
|
||||
ActLeft _ -> ActLeft 1
|
||||
ActRight _ -> ActRight 1
|
||||
x -> A.log A.Error (fromString (show x) <> " is a non-movement action!") (error "*dies*")
|
||||
k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
|
||||
void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
|
||||
M.insert (AxisAction (fromIntegral axis) align) act $
|
||||
if isJust k then M.delete (fromJust k) tmap else tmap
|
||||
)
|
||||
fullClean ud
|
||||
switchBack
|
||||
_ -> return ()
|
||||
fullClean
|
||||
switchBack
|
||||
joyListener _ _ = return ()
|
||||
MsgJoystickButton _ _ but SDL.JoyButtonPressed -> do
|
||||
case trans of
|
||||
JoyTranslation tmap -> do
|
||||
case curState 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)
|
||||
void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
|
||||
M.insert (ButtonAction but SDL.JoyButtonPressed) act $
|
||||
if isJust k then M.delete (fromJust k) tmap else tmap
|
||||
)
|
||||
_ -> return ()
|
||||
fullClean ud
|
||||
switchBack
|
||||
x -> A.log A.Error (fromString (show x) <> " is a non-joystick translation!") (error "*dies*")
|
||||
_ -> return ()
|
||||
|
||||
drawAdjust :: Affection UserData ()
|
||||
drawAdjust = do
|
||||
ud <- getAffection
|
||||
drawAdjust :: Context -> Affection ()
|
||||
drawAdjust ctx = do
|
||||
liftIO $ do
|
||||
let ctx = nano ud
|
||||
save ctx
|
||||
beginPath ctx
|
||||
roundedRect ctx 440 310 400 100 10
|
||||
|
|
|
|||
Loading…
Reference in a new issue