From 8f2366502b701438225588ea0157d9dcd914fcff Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 5 May 2020 06:29:35 +0200 Subject: [PATCH] bump module Util to affection 0.0.0.10 --- src/Util.hs | 91 ++++++++++++++++++++++++++--------------------------- 1 file changed, 45 insertions(+), 46 deletions(-) diff --git a/src/Util.hs b/src/Util.hs index e4fbffa..9ade31f 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -12,7 +12,9 @@ import Data.Maybe import qualified Data.Text as T import Data.String -import Control.Monad (join, when) +import Control.Monad + +import Control.Concurrent.MVar import qualified SDL import qualified Graphics.Rendering.OpenGL as GL hiding (get) @@ -221,7 +223,8 @@ drawLoadScreen ud (progress, msg) = do save ctx fillColor ctx (rgb 255 128 0) fontSize ctx 100 - fontFace ctx (assetFonts ud Map.! FontBedstead) + fonts <- readMVar (assetFonts ud) + fontFace ctx (fonts Map.! FontBedstead) textAlign ctx (S.fromList [AlignCenter, AlignTop]) textBox ctx 0 300 1280 "Loading" beginPath ctx @@ -304,48 +307,47 @@ rotVec (V2 x y) deg = V2 nx ny dtor :: (Num a, Floating a) => a -> a dtor = (pi / 180 *) -cacheJoypad :: JoystickMessage -> Affection () -cacheJoypad msg = do - ud <- getAffection - putAffection ud - { joyCache = msg : joyCache ud - } +cacheJoypad :: UserData -> JoystickMessage -> Affection () +cacheJoypad ud msg = do + joy <- liftIO $ readMVar (joyCache ud) + void $ liftIO $ swapMVar (joyCache ud) (msg : joy) -emitJoyActionMessage :: JoystickMessage -> Affection () -emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do - ud <- getAffection - case translation ud of - JoyTranslation tmap -> do +emitJoyActionMessage :: UserData -> JoystickMessage -> Affection () +emitJoyActionMessage ud message = do + trans <- liftIO $ readMVar (translation ud) + case message of + MsgJoystickAxis time _ axis val -> do + case trans of + JoyTranslation tmap -> do + let Subsystems _ _ _ _ t = subsystems ud + vnormal = fromIntegral val / 32768 + sigvnormal = abs vnormal + align + | signum vnormal >= 0 = AxisPositive + | signum vnormal < 0 = AxisNegative + case tmap Map.!? (AxisAction axis align) of + Just (ActUp _) -> partEmit t (ActionMessage (ActUp sigvnormal) time) + Just (ActDown _) -> partEmit t (ActionMessage (ActDown sigvnormal) time) + Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft sigvnormal) time) + Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time) + _ -> return () + _ -> return () + MsgJoystickButton time _ but SDL.JoyButtonPressed -> do let Subsystems _ _ _ _ t = subsystems ud - vnormal = fromIntegral val / 32768 - sigvnormal = abs vnormal - align - | signum vnormal >= 0 = AxisPositive - | signum vnormal < 0 = AxisNegative - case tmap Map.!? (AxisAction axis align) of - Just (ActUp _) -> partEmit t (ActionMessage (ActUp sigvnormal) time) - Just (ActDown _) -> partEmit t (ActionMessage (ActDown sigvnormal) time) - Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft sigvnormal) time) - Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time) - _ -> return () + case trans of + JoyTranslation tmap -> do + case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of + Just act -> partEmit t (ActionMessage act time) + _ -> return () + _ -> return () _ -> return () -emitJoyActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do - ud <- getAffection - let Subsystems _ _ _ _ t = subsystems ud - case (translation ud) of - JoyTranslation tmap -> do - case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of - Just act -> partEmit t (ActionMessage act time) - _ -> return () - _ -> return () -emitJoyActionMessage _ = return () -emitKbdActionMessage :: KeyboardMessage -> Affection () -emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do - ud <- getAffection +emitKbdActionMessage :: UserData -> KeyboardMessage -> Affection () +emitKbdActionMessage ud (MsgKeyboardEvent time _ press False sym) = do let Subsystems _ _ _ _ t = subsystems ud val = if press == SDL.Pressed then 1 else 0 - case (translation ud) of + trans <- liftIO $ readMVar (translation ud) + case trans of KbdTranslation tmap -> do case tmap Map.!? SDL.keysymKeycode sym of Just (ActUp _) -> partEmit t (ActionMessage (ActUp val) time) @@ -355,13 +357,12 @@ emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time)) _ -> return () _ -> return () -emitKbdActionMessage _ = return () +emitKbdActionMessage _ _ = return () -fullClean :: Affection () -fullClean = do - ud <- getAffection +fullClean :: UserData -> Affection () +fullClean ud = do let Subsystems w m k j t = subsystems ud - toClean = uuid ud + toClean <- liftIO $ readMVar $ uuid ud mapM_ (\u -> do partUnSubscribe w u partUnSubscribe m u @@ -369,6 +370,4 @@ fullClean = do partUnSubscribe j u partUnSubscribe t u ) toClean - putAffection ud - { uuid = [] - } + void $ liftIO $ swapMVar (uuid ud) []