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 ( withAffection
, get , get
, put , put
, liftIO
, module A , module A
) where ) where
@ -14,6 +15,7 @@ import System.Clock
import Control.Monad.Loops import Control.Monad.Loops
import Control.Monad.State import Control.Monad.State
import Control.Monad.IO.Class (liftIO)
import Foreign.C.Types (CInt(..)) import Foreign.C.Types (CInt(..))

View file

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

View file

@ -1,10 +1,12 @@
module Affection.Util module Affection.Util where
where
import Affection.Types import Affection.Types
import Affection.Logging import Affection.Logging
import Affection.MessageBus.Message.WindowMessage
import SDL (($=))
import qualified SDL import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import System.Clock import System.Clock
@ -63,10 +65,29 @@ toggleScreen = do
SDL.setWindowMode (drawWindow ad) SDL.Windowed SDL.setWindowMode (drawWindow ad) SDL.Windowed
return SDL.Windowed return SDL.Windowed
x -> do x -> do
liftIO $ logIO Warn ("Unknown Screen mode: " ++ show x) liftIO $ logIO Warn ("Unexpected Screen mode: " ++ show x)
return x return x
now <- liftIO $ getTime Monotonic now <- liftIO $ getTime Monotonic
put ad put ad
{ sysTime = now { sysTime = now
, screenMode = newMode , 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 ()