fixing viewport and joysticks

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(..))
 

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

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 ()