diff --git a/src/Menu/Adjust.hs b/src/Menu/Adjust.hs index d2a3959..f49750f 100644 --- a/src/Menu/Adjust.hs +++ b/src/Menu/Adjust.hs @@ -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