From 8f662cf6fa0278b2b1b3d7af3d5950af6eb11fc4 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 12 Jan 2018 22:08:23 +0100 Subject: [PATCH] fixing viewport and joysticks --- src/Affection.hs | 2 ++ src/Affection/Subsystems/AffectionJoystick.hs | 13 ++++++--- src/Affection/Util.hs | 27 ++++++++++++++++--- 3 files changed, 35 insertions(+), 7 deletions(-) diff --git a/src/Affection.hs b/src/Affection.hs index aa842a5..61235fe 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -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(..)) diff --git a/src/Affection/Subsystems/AffectionJoystick.hs b/src/Affection/Subsystems/AffectionJoystick.hs index 30d9578..64ad018 100644 --- a/src/Affection/Subsystems/AffectionJoystick.hs +++ b/src/Affection/Subsystems/AffectionJoystick.hs @@ -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 diff --git a/src/Affection/Util.hs b/src/Affection/Util.hs index 879aa3b..16fbbf8 100644 --- a/src/Affection/Util.hs +++ b/src/Affection/Util.hs @@ -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 ()