tracer/src/Menu/Adjust.hs
2018-10-12 21:40:16 +02:00

87 lines
2.6 KiB
Haskell

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 (listener switchBack)
putAffection ud
{ state = Menu (Adjust sub)
, uuid = [ uu1 ]
}
listener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
listener 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
listener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do
ud <- getAffection
case state ud of
Menu (Adjust (Activate)) -> do
let k = fst <$> find (\(_, v) -> case v of
Activate -> True
_ -> False
) (M.assocs $ translation ud)
putAffection ud
{ translation =
M.insert (ButtonAction but SDL.JoyButtonPressed) Activate $
if isJust k then M.delete (fromJust k) (translation ud) else translation ud
}
fullClean
switchBack
listener _ _ = 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