bump module Util to affection 0.0.0.10

This commit is contained in:
nek0 2020-05-05 06:29:35 +02:00
parent 808ab1db06
commit 8f2366502b

View file

@ -12,7 +12,9 @@ import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import Data.String import Data.String
import Control.Monad (join, when) import Control.Monad
import Control.Concurrent.MVar
import qualified SDL import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get) import qualified Graphics.Rendering.OpenGL as GL hiding (get)
@ -221,7 +223,8 @@ drawLoadScreen ud (progress, msg) = do
save ctx save ctx
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
fontSize ctx 100 fontSize ctx 100
fontFace ctx (assetFonts ud Map.! FontBedstead) fonts <- readMVar (assetFonts ud)
fontFace ctx (fonts Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter, AlignTop]) textAlign ctx (S.fromList [AlignCenter, AlignTop])
textBox ctx 0 300 1280 "Loading" textBox ctx 0 300 1280 "Loading"
beginPath ctx beginPath ctx
@ -304,48 +307,47 @@ rotVec (V2 x y) deg = V2 nx ny
dtor :: (Num a, Floating a) => a -> a dtor :: (Num a, Floating a) => a -> a
dtor = (pi / 180 *) dtor = (pi / 180 *)
cacheJoypad :: JoystickMessage -> Affection () cacheJoypad :: UserData -> JoystickMessage -> Affection ()
cacheJoypad msg = do cacheJoypad ud msg = do
ud <- getAffection joy <- liftIO $ readMVar (joyCache ud)
putAffection ud void $ liftIO $ swapMVar (joyCache ud) (msg : joy)
{ joyCache = msg : joyCache ud
}
emitJoyActionMessage :: JoystickMessage -> Affection () emitJoyActionMessage :: UserData -> JoystickMessage -> Affection ()
emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do emitJoyActionMessage ud message = do
ud <- getAffection trans <- liftIO $ readMVar (translation ud)
case translation ud of case message of
JoyTranslation tmap -> do 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 let Subsystems _ _ _ _ t = subsystems ud
vnormal = fromIntegral val / 32768 case trans of
sigvnormal = abs vnormal JoyTranslation tmap -> do
align case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
| signum vnormal >= 0 = AxisPositive Just act -> partEmit t (ActionMessage act time)
| signum vnormal < 0 = AxisNegative _ -> return ()
case tmap Map.!? (AxisAction axis align) of _ -> return ()
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 () _ -> 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 :: UserData -> KeyboardMessage -> Affection ()
emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do emitKbdActionMessage ud (MsgKeyboardEvent time _ press False sym) = do
ud <- getAffection
let Subsystems _ _ _ _ t = subsystems ud let Subsystems _ _ _ _ t = subsystems ud
val = if press == SDL.Pressed then 1 else 0 val = if press == SDL.Pressed then 1 else 0
case (translation ud) of trans <- liftIO $ readMVar (translation ud)
case trans of
KbdTranslation tmap -> do KbdTranslation tmap -> do
case tmap Map.!? SDL.keysymKeycode sym of case tmap Map.!? SDL.keysymKeycode sym of
Just (ActUp _) -> partEmit t (ActionMessage (ActUp val) time) 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)) Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time))
_ -> return () _ -> return ()
_ -> return () _ -> return ()
emitKbdActionMessage _ = return () emitKbdActionMessage _ _ = return ()
fullClean :: Affection () fullClean :: UserData -> Affection ()
fullClean = do fullClean ud = do
ud <- getAffection
let Subsystems w m k j t = subsystems ud let Subsystems w m k j t = subsystems ud
toClean = uuid ud toClean <- liftIO $ readMVar $ uuid ud
mapM_ (\u -> do mapM_ (\u -> do
partUnSubscribe w u partUnSubscribe w u
partUnSubscribe m u partUnSubscribe m u
@ -369,6 +370,4 @@ fullClean = do
partUnSubscribe j u partUnSubscribe j u
partUnSubscribe t u partUnSubscribe t u
) toClean ) toClean
putAffection ud void $ liftIO $ swapMVar (uuid ud) []
{ uuid = []
}