From 09f67b37f3ae8d64dc1f3d754c3448dcb4f39fe1 Mon Sep 17 00:00:00 2001 From: Jason Shipman Date: Wed, 24 Jan 2024 17:38:43 -0500 Subject: [PATCH 1/2] Add rendererIntegerScale --- ChangeLog.md | 5 +++++ src/SDL/Raw/Video.hs | 12 ++++++++++++ src/SDL/Video/Renderer.hs | 21 ++++++++++++++++++++- 3 files changed, 37 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 515e2b9..92f5c5e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +2.5.X.Y +======= + +* Added `rendererIntegerScale` + 2.5.5.0 ======= diff --git a/src/SDL/Raw/Video.hs b/src/SDL/Raw/Video.hs index e65ee5b..b0bd136 100644 --- a/src/SDL/Raw/Video.hs +++ b/src/SDL/Raw/Video.hs @@ -134,6 +134,7 @@ module SDL.Raw.Video ( renderGeometryRaw, #endif renderGetClipRect, + renderGetIntegerScale, renderGetLogicalSize, renderGetScale, renderGetViewport, @@ -141,6 +142,7 @@ module SDL.Raw.Video ( renderPresent, renderReadPixels, renderSetClipRect, + renderSetIntegerScale, renderSetLogicalSize, renderSetScale, renderSetViewport, @@ -367,6 +369,7 @@ foreign import ccall "SDL.h SDL_RenderGeometryRaw" renderGeometryRawFFI :: Rende foreign import ccall "sqlhelper.c SDLHelper_RenderFillRectEx" renderFillRectExFFI :: Renderer -> CInt -> CInt -> CInt -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderFillRects" renderFillRectsFFI :: Renderer -> Ptr Rect -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderGetClipRect" renderGetClipRectFFI :: Renderer -> Ptr Rect -> IO () +foreign import ccall "SDL.h SDL_RenderGetIntegerScale" renderGetIntegerScaleFFI :: Renderer -> IO CInt foreign import ccall "SDL.h SDL_RenderGetLogicalSize" renderGetLogicalSizeFFI :: Renderer -> Ptr CInt -> Ptr CInt -> IO () foreign import ccall "SDL.h SDL_RenderGetScale" renderGetScaleFFI :: Renderer -> Ptr CFloat -> Ptr CFloat -> IO () foreign import ccall "SDL.h SDL_RenderGetViewport" renderGetViewportFFI :: Renderer -> Ptr Rect -> IO () @@ -374,6 +377,7 @@ foreign import ccall "SDL.h SDL_RenderIsClipEnabled" renderIsClipEnabledFFI :: R foreign import ccall "SDL.h SDL_RenderPresent" renderPresentFFI :: Renderer -> IO () foreign import ccall "SDL.h SDL_RenderReadPixels" renderReadPixelsFFI :: Renderer -> Ptr Rect -> Word32 -> Ptr () -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderSetClipRect" renderSetClipRectFFI :: Renderer -> Ptr Rect -> IO CInt +foreign import ccall "SDL.h SDL_RenderSetIntegerScale" renderSetIntegerScaleFFI :: Renderer -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderSetLogicalSize" renderSetLogicalSizeFFI :: Renderer -> CInt -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderSetScale" renderSetScaleFFI :: Renderer -> CFloat -> CFloat -> IO CInt foreign import ccall "SDL.h SDL_RenderSetViewport" renderSetViewportFFI :: Renderer -> Ptr Rect -> IO CInt @@ -967,6 +971,10 @@ renderGetClipRect :: MonadIO m => Renderer -> Ptr Rect -> m () renderGetClipRect v1 v2 = liftIO $ renderGetClipRectFFI v1 v2 {-# INLINE renderGetClipRect #-} +renderGetIntegerScale :: MonadIO m => Renderer -> m CInt +renderGetIntegerScale v1 = liftIO $ renderGetIntegerScaleFFI v1 +{-# INLINE renderGetIntegerScale #-} + renderGetLogicalSize :: MonadIO m => Renderer -> Ptr CInt -> Ptr CInt -> m () renderGetLogicalSize v1 v2 v3 = liftIO $ renderGetLogicalSizeFFI v1 v2 v3 {-# INLINE renderGetLogicalSize #-} @@ -995,6 +1003,10 @@ renderSetClipRect :: MonadIO m => Renderer -> Ptr Rect -> m CInt renderSetClipRect v1 v2 = liftIO $ renderSetClipRectFFI v1 v2 {-# INLINE renderSetClipRect #-} +renderSetIntegerScale :: MonadIO m => Renderer -> CInt -> m CInt +renderSetIntegerScale v1 v2 = liftIO $ renderSetIntegerScaleFFI v1 v2 +{-# INLINE renderSetIntegerScale #-} + renderSetLogicalSize :: MonadIO m => Renderer -> CInt -> CInt -> m CInt renderSetLogicalSize v1 v2 v3 = liftIO $ renderSetLogicalSizeFFI v1 v2 v3 {-# INLINE renderSetLogicalSize #-} diff --git a/src/SDL/Video/Renderer.hs b/src/SDL/Video/Renderer.hs index a888852..a9c5e3e 100644 --- a/src/SDL/Video/Renderer.hs +++ b/src/SDL/Video/Renderer.hs @@ -55,6 +55,7 @@ module SDL.Video.Renderer , rendererDrawColor , rendererRenderTarget , rendererClipRect + , rendererIntegerScale , rendererLogicalSize , rendererScale , rendererViewport @@ -133,6 +134,7 @@ module SDL.Video.Renderer , getRenderDriverInfo ) where +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Bits import Data.Data (Data) @@ -1337,7 +1339,24 @@ rendererRenderTarget (Renderer r) = makeStateVar getRenderTarget setRenderTarget Nothing -> Raw.setRenderTarget r nullPtr Just (Texture t) -> Raw.setRenderTarget r t --- | Get or set the device independent resolution for rendering. +-- | Get or set whether to force integer scales for resolution-independent rendering. +-- It may be desirable to enable integer scales when using device independent resolution +-- via 'rendererLogicalSize' so that pixel sizing is consistent. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +rendererIntegerScale :: Renderer -> StateVar Bool +rendererIntegerScale (Renderer r) = makeStateVar renderGetIntegerScale renderSetIntegerScale + where + renderGetIntegerScale = (== 1) <$> Raw.renderGetIntegerScale r + + renderSetIntegerScale True = void $ Raw.renderSetIntegerScale r 1 + renderSetIntegerScale False = void $ Raw.renderSetIntegerScale r 0 + +-- | Get or set the device independent resolution for rendering. When using this setting, +-- it may be desirable to also enable integer scales via 'rendererIntegerScale' so that +-- pixel sizing is consistent. -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- From 2cf9fcd148c2298244985e1905dc86363d369b32 Mon Sep 17 00:00:00 2001 From: Jason Shipman Date: Wed, 24 Jan 2024 17:39:01 -0500 Subject: [PATCH 2/2] Remove redundant liftIO calls --- src/SDL/Video/Renderer.hs | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/src/SDL/Video/Renderer.hs b/src/SDL/Video/Renderer.hs index a9c5e3e..6e4f0cb 100644 --- a/src/SDL/Video/Renderer.hs +++ b/src/SDL/Video/Renderer.hs @@ -507,7 +507,7 @@ getWindowSurface (Window w) = rendererDrawBlendMode :: Renderer -> StateVar BlendMode rendererDrawBlendMode (Renderer r) = makeStateVar getRenderDrawBlendMode setRenderDrawBlendMode where - getRenderDrawBlendMode = liftIO $ + getRenderDrawBlendMode = alloca $ \bmPtr -> do throwIfNeg_ "SDL.Video.Renderer.getRenderDrawBlendMode" "SDL_GetRenderDrawBlendMode" $ Raw.getRenderDrawBlendMode r bmPtr @@ -525,7 +525,7 @@ rendererDrawBlendMode (Renderer r) = makeStateVar getRenderDrawBlendMode setRend rendererDrawColor :: Renderer -> StateVar (V4 Word8) rendererDrawColor (Renderer re) = makeStateVar getRenderDrawColor setRenderDrawColor where - getRenderDrawColor = liftIO $ + getRenderDrawColor = alloca $ \r -> alloca $ \g -> alloca $ \b -> @@ -814,7 +814,7 @@ rendererScale (Renderer r) = makeStateVar renderGetScale renderSetScale throwIfNeg_ "SDL.Video.renderSetScale" "SDL_RenderSetScale" $ Raw.renderSetScale r x y - renderGetScale = liftIO $ + renderGetScale = alloca $ \w -> alloca $ \h -> do Raw.renderGetScale r w h @@ -828,12 +828,11 @@ rendererScale (Renderer r) = makeStateVar renderGetScale renderSetScale rendererClipRect :: Renderer -> StateVar (Maybe (Rectangle CInt)) rendererClipRect (Renderer r) = makeStateVar renderGetClipRect renderSetClipRect where - renderGetClipRect = liftIO $ + renderGetClipRect = alloca $ \rPtr -> do Raw.renderGetClipRect r rPtr maybePeek peek (castPtr rPtr) renderSetClipRect rect = - liftIO $ throwIfNeg_ "SDL.Video.renderSetClipRect" "SDL_RenderSetClipRect" $ maybeWith with rect $ Raw.renderSetClipRect r . castPtr @@ -845,13 +844,12 @@ rendererClipRect (Renderer r) = makeStateVar renderGetClipRect renderSetClipRect rendererViewport :: Renderer -> StateVar (Maybe (Rectangle CInt)) rendererViewport (Renderer r) = makeStateVar renderGetViewport renderSetViewport where - renderGetViewport = liftIO $ + renderGetViewport = alloca $ \rect -> do Raw.renderGetViewport r rect maybePeek peek (castPtr rect) renderSetViewport rect = - liftIO $ throwIfNeg_ "SDL.Video.renderSetViewport" "SDL_RenderSetViewport" $ maybeWith with rect $ Raw.renderSetViewport r . castPtr @@ -992,7 +990,6 @@ surfaceColorKey :: Surface -> StateVar (Maybe (V4 Word8)) surfaceColorKey (Surface s _) = makeStateVar getColorKey setColorKey where getColorKey = - liftIO $ alloca $ \keyPtr -> do ret <- Raw.getColorKey s keyPtr if ret == -1 @@ -1006,7 +1003,6 @@ surfaceColorKey (Surface s _) = makeStateVar getColorKey setColorKey do Raw.getRGBA mapped format r g b a Just <$> (V4 <$> peek r <*> peek g <*> peek b <*> peek a) setColorKey key = - liftIO $ throwIfNeg_ "SDL.Video.Renderer.setColorKey" "SDL_SetColorKey" $ case key of Nothing -> @@ -1032,7 +1028,7 @@ surfaceColorKey (Surface s _) = makeStateVar getColorKey setColorKey textureColorMod :: Texture -> StateVar (V3 Word8) textureColorMod (Texture t) = makeStateVar getTextureColorMod setTextureColorMod where - getTextureColorMod = liftIO $ + getTextureColorMod = alloca $ \r -> alloca $ \g -> alloca $ \b -> do @@ -1272,7 +1268,7 @@ getRenderDriverInfo = liftIO $ do textureAlphaMod :: Texture -> StateVar Word8 textureAlphaMod (Texture t) = makeStateVar getTextureAlphaMod setTextureAlphaMod where - getTextureAlphaMod = liftIO $ + getTextureAlphaMod = alloca $ \x -> do throwIfNeg_ "SDL.Video.Renderer.getTextureAlphaMod" "SDL_GetTextureAlphaMod" $ Raw.getTextureAlphaMod t x @@ -1290,7 +1286,7 @@ textureAlphaMod (Texture t) = makeStateVar getTextureAlphaMod setTextureAlphaMod textureBlendMode :: Texture -> StateVar BlendMode textureBlendMode (Texture t) = makeStateVar getTextureBlendMode setTextureBlendMode where - getTextureBlendMode = liftIO $ + getTextureBlendMode = alloca $ \x -> do throwIfNeg_ "SDL.Video.Renderer.getTextureBlendMode" "SDL_GetTextureBlendMode" $ Raw.getTextureBlendMode t x @@ -1308,7 +1304,7 @@ textureBlendMode (Texture t) = makeStateVar getTextureBlendMode setTextureBlendM surfaceBlendMode :: Surface -> StateVar BlendMode surfaceBlendMode (Surface s _) = makeStateVar getSurfaceBlendMode setSurfaceBlendMode where - getSurfaceBlendMode = liftIO $ + getSurfaceBlendMode = alloca $ \x -> do throwIfNeg_ "SDL.Video.Renderer.getSurfaceBlendMode" "SDL_GetSurfaceBlendMode" $ Raw.getSurfaceBlendMode s x @@ -1364,7 +1360,7 @@ rendererIntegerScale (Renderer r) = makeStateVar renderGetIntegerScale renderSet rendererLogicalSize :: Renderer -> StateVar (Maybe (V2 CInt)) rendererLogicalSize (Renderer r) = makeStateVar renderGetLogicalSize renderSetLogicalSize where - renderGetLogicalSize = liftIO $ + renderGetLogicalSize = alloca $ \w -> do alloca $ \h -> do Raw.renderGetLogicalSize r w h