fixing viewport and joysticks

This commit is contained in:
nek0 2018-01-12 22:08:23 +01:00
parent 6b1e7b557a
commit 8f662cf6fa
3 changed files with 35 additions and 7 deletions

View File

@ -4,6 +4,7 @@ module Affection
( withAffection
, get
, put
, liftIO
, module A
) where
@ -14,6 +15,7 @@ import System.Clock
import Control.Monad.Loops
import Control.Monad.State
import Control.Monad.IO.Class (liftIO)
import Foreign.C.Types (CInt(..))

View File

@ -82,15 +82,20 @@ joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
[descr] <- V.toList <$>
(return . V.filter (\(SDL.JoystickDevice _ id) -> id == CInt which)
=<< SDL.availableJoysticks)
logIO Verbose $ "Connecting Joystick " ++ show which
logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr
Just <$> SDL.openJoystick descr
joystickAutoConnect _ = return Nothing
joystickAutoDisconnect :: [SDL.Joystick] -> JoystickMessage -> Affection us [SDL.Joystick]
joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
liftIO $ do
[disc] <- filterM (\j -> return . (which ==) =<< SDL.getJoystickID j) js
joyIds <- mapM SDL.getJoystickID js
logIO Verbose $ "These are the Joysticks connected: " ++ show joyIds
[d] <- filterM (\j -> return . (which ==) =<< SDL.getJoystickID j) js
logIO Verbose $ "disconnected joysticks: " ++ show d
logIO Verbose $ "Disconnecting Joystick " ++ show which
SDL.closeJoystick disc
filterM (\j -> return . (which /=) =<< SDL.getJoystickID j) js
SDL.closeJoystick d
njoys <- filterM (\j -> return $ d /= j) js
logIO Verbose $ "returning joysticks: " ++ show njoys
return njoys
joystickAutoDisconnect js _ = return js

View File

@ -1,10 +1,12 @@
module Affection.Util
where
module Affection.Util where
import Affection.Types
import Affection.Logging
import Affection.MessageBus.Message.WindowMessage
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import System.Clock
@ -63,10 +65,29 @@ toggleScreen = do
SDL.setWindowMode (drawWindow ad) SDL.Windowed
return SDL.Windowed
x -> do
liftIO $ logIO Warn ("Unknown Screen mode: " ++ show x)
liftIO $ logIO Warn ("Unexpected Screen mode: " ++ show x)
return x
now <- liftIO $ getTime Monotonic
put ad
{ sysTime = now
, screenMode = newMode
}
-- | Fit the GL Viewport to Window size
fitViewport
:: Double -- ^ Image Ratio (width / height)
-> WindowMessage -- ^ Incoming Message. Listens only on
-- 'MsgWindowResize' and ignores all others.
-> Affection us ()
fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
liftIO $ logIO Verbose "Fitting Viewport to size"
if (fromIntegral w / fromIntegral h) > ratio
then do
let nw = floor (fromIntegral h * ratio)
dw = floor ((fromIntegral w - fromIntegral nw) / 2 :: Double)
GL.viewport $= (GL.Position dw 0, GL.Size nw h)
else do
let nh = floor (fromIntegral w / ratio)
dh = floor ((fromIntegral h - fromIntegral nh) / 2 :: Double)
GL.viewport $= (GL.Position 0 dh, GL.Size w nh)
fitViewport _ _ = return ()