tracer/src/Menu/Adjust.hs

120 lines
3.9 KiB
Haskell
Raw Normal View History

2018-10-12 19:40:16 +00:00
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)
2019-10-28 17:20:34 +00:00
import Data.String
2018-10-12 19:40:16 +00:00
-- internal imports
import Types
import Util
2019-02-11 23:11:53 +00:00
loadAdjust :: Action -> Controller -> Affection UserData () -> Affection UserData ()
loadAdjust sub contr switchBack = do
2018-10-12 19:40:16 +00:00
ud <- getAffection
let Subsystems w m k j t = subsystems ud
2019-02-11 09:49:23 +00:00
uu1 <- partSubscribe j (joyListener switchBack)
2018-10-12 19:40:16 +00:00
putAffection ud
2019-02-11 23:11:53 +00:00
{ state = Menu (Adjust sub contr)
2018-10-12 19:40:16 +00:00
, uuid = [ uu1 ]
}
2019-02-11 09:49:23 +00:00
joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
2018-10-12 19:40:16 +00:00
ud <- getAffection
2019-10-28 17:20:34 +00:00
liftIO $ logIO
A.Debug
("switching " <>
fromString (show $ state ud) <>
" to " <>
fromString (show axis)
)
2019-02-11 23:11:53 +00:00
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 ()
2019-02-11 09:49:23 +00:00
joyListener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do
2018-10-12 19:40:16 +00:00
ud <- getAffection
2019-02-11 23:11:53 +00:00
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
}
_ -> return ()
fullClean
switchBack
2019-02-11 09:49:23 +00:00
joyListener _ _ = return ()
2018-10-12 19:40:16 +00:00
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