module Menu.Adjust where import Affection as A import qualified SDL import NanoVG import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.List (find) import Data.Maybe (fromJust, isJust) -- internal imports import Types import Util loadAdjust :: Action -> Affection UserData () -> Affection UserData () loadAdjust sub switchBack = do ud <- getAffection let Subsystems w m k j t = subsystems ud uu1 <- partSubscribe j (joyListener switchBack) putAffection ud { state = Menu (Adjust sub) , uuid = [ uu1 ] } 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 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 joyListener _ _ = return () drawAdjust :: Affection UserData () drawAdjust = do ud <- getAffection liftIO $ do let ctx = nano ud save ctx beginPath ctx roundedRect ctx 440 310 400 100 10 strokeWidth ctx 5 strokeColor ctx (rgb 255 255 255) fillColor ctx (rgb 255 255 255) closePath ctx stroke ctx fill ctx fontSize ctx 50 fontFace ctx "bedstead" textAlign ctx (S.fromList [AlignCenter, AlignTop]) fillColor ctx (rgb 0 0 0) textBox ctx 440 310 400 "Enter new movement ..." restore ctx