87 lines
2.6 KiB
Haskell
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
|