bump module Util to affection 0.0.0.10
This commit is contained in:
parent
808ab1db06
commit
8f2366502b
91
src/Util.hs
91
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) []
|
||||
|
|
|
|||
Loading…
Reference in New Issue