diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +2.5.4.1 +======= + +* Added `windowOpacity` property +* Added `renderGeometry` and `renderGeometryRaw` + - Requires SDL 2.0.18 + - See examples/RenderGeometry.hs + 2.5.4.0 ======= diff --git a/examples/RenderGeometry.hs b/examples/RenderGeometry.hs new file mode 100644 --- /dev/null +++ b/examples/RenderGeometry.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} + +module RenderGeometry where + +import Control.Monad +import Data.Word (Word8) +import Foreign (castPtr, plusPtr, sizeOf) +import Foreign.C.Types +import SDL.Vect +import qualified Data.Vector.Storable as V + +import SDL (($=)) +import qualified SDL +import SDL.Raw.Types (FPoint(..), Color(..)) + +screenWidth, screenHeight :: CInt +(screenWidth, screenHeight) = (640, 480) + +main :: IO () +main = do + SDL.initialize [SDL.InitVideo] + SDL.HintRenderScaleQuality $= SDL.ScaleLinear + do renderQuality <- SDL.get SDL.HintRenderScaleQuality + when (renderQuality /= SDL.ScaleLinear) $ + putStrLn "Warning: Linear texture filtering not enabled!" + + window <- + SDL.createWindow + "SDL / RenderGeometry Example" + SDL.defaultWindow + { SDL.windowInitialSize = V2 screenWidth screenHeight + , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + } + SDL.showWindow window + + renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer + + let + tl = fromIntegral screenWidth * 0.1 + tt = fromIntegral screenHeight * 0.1 + tr = fromIntegral screenWidth * 0.9 + tb = fromIntegral screenHeight * 0.9 + + triVertices = V.fromList + [ SDL.Vertex + (FPoint tl tb) + (Color 0xFF 0 0 255) + (FPoint 0 0) + , SDL.Vertex + (FPoint tr tb) + (Color 0 0xFF 0 255) + (FPoint 0 1) + , SDL.Vertex + (FPoint (tl/2 + tr/2) tt) + (Color 0 0 0xFF 255) + (FPoint 1 1) + ] + + let + l = fromIntegral screenWidth * 0.2 + t = fromIntegral screenHeight * 0.2 + r = fromIntegral screenWidth * 0.8 + b = fromIntegral screenHeight * 0.8 + + quadVertices = V.fromList + [ SDL.Vertex + (FPoint l b) + (Color 0xFF 0 0xFF 127) + (FPoint 0 0) + , SDL.Vertex + (FPoint r b) + (Color 0xFF 0 0xFF 127) + (FPoint 1 0) + , SDL.Vertex + (FPoint r t) + (Color 0xFF 0xFF 0 127) + (FPoint 1 1) + , SDL.Vertex + (FPoint l t) + (Color 0 0 0 127) + (FPoint 0 1) + ] + quadIndices = V.fromList + [ 0, 1, 3 + , 2, 3, 1 + ] + stride = fromIntegral $ sizeOf (undefined :: SDL.Vertex) + + let loop = do + events <- SDL.pollEvents + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events + + SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound + SDL.clear renderer + + SDL.renderGeometry + renderer + Nothing + triVertices + mempty + + SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend + V.unsafeWith quadVertices $ \ptr -> + SDL.renderGeometryRaw + renderer + Nothing + (castPtr ptr) + stride + (castPtr ptr `plusPtr` sizeOf (undefined :: FPoint)) + stride + (castPtr ptr `plusPtr` sizeOf (undefined :: FPoint) `plusPtr` sizeOf (undefined :: Color)) + stride + (fromIntegral $ V.length quadVertices) + (quadIndices :: V.Vector Word8) + + SDL.present renderer + + unless quit loop + + loop + + SDL.destroyWindow window + SDL.quit diff --git a/sdl2.cabal b/sdl2.cabal --- a/sdl2.cabal +++ b/sdl2.cabal @@ -1,5 +1,5 @@ name: sdl2 -version: 2.5.4.0 +version: 2.5.4.1 synopsis: Both high- and low-level bindings to the SDL library (version 2.0.6+). description: This package contains bindings to the SDL 2 library, in both high- and @@ -61,7 +61,7 @@ description: Use features from a more recent libsdl2 release. default: True manual: False - + flag pkgconfig description: Use pkgconfig to sort out SDL2 dependency default: True @@ -150,13 +150,13 @@ StateVar >= 1.1.0.0 && < 1.3, text >= 1.1.0.0 && < 2.1, transformers >= 0.2 && < 0.7, - vector >= 0.10.9.0 && < 0.13 + vector >= 0.10.9.0 && < 0.14 if flag(no-linear) cpp-options: -Dnolinear else build-depends: - linear >= 1.10.1.2 && < 1.22 + linear >= 1.10.1.2 && < 1.23 if impl(ghc >= 8.6) default-extensions: NoStarIsType @@ -505,6 +505,18 @@ main-is: UserEvents.hs default-language: Haskell2010 ghc-options: -main-is UserEvents + other-modules: Paths_sdl2 + +executable rendergeometry-example + if flag(examples) + build-depends: base, bytestring, vector, sdl2 + else + buildable: False + + hs-source-dirs: examples + main-is: RenderGeometry.hs + default-language: Haskell2010 + ghc-options: -main-is RenderGeometry other-modules: Paths_sdl2 executable opengl-example diff --git a/src/SDL/Event.hs b/src/SDL/Event.hs --- a/src/SDL/Event.hs +++ b/src/SDL/Event.hs @@ -109,10 +109,10 @@ import Control.Applicative #endif --- | A single SDL event. This event occured at 'eventTimestamp' and carries data under 'eventPayload'. +-- | A single SDL event. This event occurred at 'eventTimestamp' and carries data under 'eventPayload'. data Event = Event { eventTimestamp :: Timestamp - -- ^ The time the event occured. + -- ^ The time the event occurred. , eventPayload :: EventPayload -- ^ Data pertaining to this event. } deriving (Eq, Ord, Generic, Show, Typeable) @@ -396,7 +396,7 @@ data JoyDeviceEventData = JoyDeviceEventData {joyDeviceEventConnection :: !JoyDeviceConnection -- ^ Was the device added or removed? - ,joyDeviceEventWhich :: !Int32 + ,joyDeviceEventWhich :: !Raw.JoystickID -- ^ The instance id of the joystick that reported the event. } deriving (Eq,Ord,Generic,Show,Typeable) @@ -405,7 +405,7 @@ data ControllerAxisEventData = ControllerAxisEventData {controllerAxisEventWhich :: !Raw.JoystickID -- ^ The joystick instance ID that reported the event. - ,controllerAxisEventAxis :: !Word8 + ,controllerAxisEventAxis :: !ControllerAxis -- ^ The index of the axis. ,controllerAxisEventValue :: !Int16 -- ^ The axis value ranging between -32768 and 32767. @@ -427,7 +427,7 @@ data ControllerDeviceEventData = ControllerDeviceEventData {controllerDeviceEventConnection :: !ControllerDeviceConnection -- ^ Was the device added, removed, or remapped? - ,controllerDeviceEventWhich :: !Int32 + ,controllerDeviceEventWhich :: !Raw.JoystickID -- ^ The joystick instance ID that reported the event. } deriving (Eq,Ord,Generic,Show,Typeable) @@ -681,7 +681,11 @@ convertRaw (Raw.JoyDeviceEvent t ts a) = return (Event ts (JoyDeviceEvent (JoyDeviceEventData (fromNumber t) a))) convertRaw (Raw.ControllerAxisEvent _ ts a b c) = - return (Event ts (ControllerAxisEvent (ControllerAxisEventData a b c))) + return (Event ts + (ControllerAxisEvent + (ControllerAxisEventData a + (fromNumber $ fromIntegral b) + c))) convertRaw (Raw.ControllerButtonEvent t ts a b _) = return (Event ts (ControllerButtonEvent diff --git a/src/SDL/Input/GameController.hs b/src/SDL/Input/GameController.hs --- a/src/SDL/Input/GameController.hs +++ b/src/SDL/Input/GameController.hs @@ -1,22 +1,177 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} module SDL.Input.GameController - ( ControllerButton(..) - , ControllerButtonState(..) - , ControllerDeviceConnection(..) + ( ControllerDevice (..) + , availableControllers + + , openController + , closeController + , controllerAttached + + , getControllerID + + , controllerMapping + , addControllerMapping + , addControllerMappingsFromFile + + , ControllerButton (..) + , ControllerButtonState (..) + , controllerButton + + , ControllerAxis (..) + , controllerAxis + + , ControllerDeviceConnection (..) ) where +import Control.Monad (filterM) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Data (Data) +import Data.Int +import Data.Text (Text) +import Data.Traversable (for) import Data.Typeable import Data.Word +import Foreign.C (withCString) +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable import GHC.Generics (Generic) import GHC.Int (Int32) +import SDL.Input.Joystick (numJoysticks) +import SDL.Internal.Exception import SDL.Internal.Numbered +import SDL.Internal.Types +import SDL.Vect +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSI import qualified SDL.Raw as Raw +import qualified Data.Text.Encoding as Text +import qualified Data.Vector as V +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +{- | A description of game controller that can be opened using 'openController'. + To retrieve a list of connected game controllers, use 'availableControllers'. +-} +data ControllerDevice = ControllerDevice + { gameControllerDeviceName :: Text + , gameControllerDeviceId :: CInt + } + deriving (Eq, Generic, Read, Ord, Show, Typeable) + +-- | Enumerate all connected Controllers, retrieving a description of each. +availableControllers :: MonadIO m => m (V.Vector ControllerDevice) +availableControllers = liftIO $ do + n <- numJoysticks + indices <- filterM Raw.isGameController [0 .. (n - 1)] + fmap V.fromList $ for indices $ \i -> do + cstr <- + throwIfNull "SDL.Input.Controller.availableGameControllers" "SDL_GameControllerNameForIndex" $ + Raw.gameControllerNameForIndex i + name <- Text.decodeUtf8 <$> BS.packCString cstr + return (ControllerDevice name i) + +{- | Open a controller so that you can start receiving events from interaction with this controller. + + See @@ for C documentation. +-} +openController + :: (Functor m, MonadIO m) + => ControllerDevice + -- ^ The device to open. Use 'availableControllers' to find 'JoystickDevices's + -> m GameController +openController (ControllerDevice _ x) = + fmap GameController $ + throwIfNull "SDL.Input.GameController.openController" "SDL_GameControllerOpen" $ + Raw.gameControllerOpen x + +{- | Close a controller previously opened with 'openController'. + + See @@ for C documentation. +-} +closeController :: MonadIO m => GameController -> m () +closeController (GameController j) = Raw.gameControllerClose j + +{- | Check if a controller has been opened and is currently connected. + + See @@ for C documentation. +-} +controllerAttached :: MonadIO m => GameController -> m Bool +controllerAttached (GameController c) = Raw.gameControllerGetAttached c + +{- | Get the instance ID of an opened controller. The instance ID is used to identify the controller + in future SDL events. + + See @@ for C documentation. +-} +getControllerID :: MonadIO m => GameController -> m Int32 +getControllerID (GameController c) = + throwIfNeg "SDL.Input.GameController.getControllerID" "SDL_JoystickInstanceID" $ + Raw.joystickInstanceID c + +{- | Get the current mapping of a Game Controller. + + See @@ for C documentation. +-} +controllerMapping :: MonadIO m => GameController -> m Text +controllerMapping (GameController c) = liftIO $ do + mapping <- + throwIfNull "SDL.Input.GameController.getControllerMapping" "SDL_GameControllerMapping" $ + Raw.gameControllerMapping c + Text.decodeUtf8 <$> BS.packCString mapping + +{- | Add support for controllers that SDL is unaware of or to cause an existing controller to + have a different binding. + + See @@ for C documentation. +-} +addControllerMapping :: MonadIO m => BS.ByteString -> m () +addControllerMapping mapping = + liftIO $ + throwIfNeg_ "SDL.Input.GameController.addControllerMapping" "SDL_GameControllerAddMapping" $ + let (mappingForeign, _, _) = BSI.toForeignPtr mapping + in withForeignPtr mappingForeign $ \mappingPtr -> + Raw.gameControllerAddMapping (castPtr mappingPtr) + +{- | Use this function to load a set of Game Controller mappings from a file, filtered by the + current SDL_GetPlatform(). A community sourced database of controllers is available + @@ + (on GitHub). + + See @@ for C documentation. +-} +addControllerMappingsFromFile :: MonadIO m => FilePath -> m () +addControllerMappingsFromFile mappingFile = + liftIO $ + throwIfNeg_ "SDL.Input.GameController.addControllerMappingsFromFile" "SDL_GameControllerAddMappingsFromFile" $ + withCString mappingFile Raw.gameControllerAddMappingsFromFile + +{- | Get the current state of an axis control on a game controller. + + See @@ for C documentation. +-} +controllerAxis :: MonadIO m => GameController -> ControllerAxis -> m Int16 +controllerAxis (GameController c) axis = + Raw.gameControllerGetAxis c (toNumber axis) + +{- | Get the current state of a button on a game controller. + + See @@ for C documentation. +-} +controllerButton :: MonadIO m => GameController -> ControllerButton -> m ControllerButtonState +controllerButton (GameController c) button = + fromNumber . fromIntegral <$> Raw.gameControllerGetButton c (toNumber button) + -- | Identifies a gamepad button. data ControllerButton = ControllerButtonInvalid @@ -88,7 +243,40 @@ Raw.SDL_CONTROLLERBUTTONUP -> ControllerButtonReleased _ -> ControllerButtonInvalidState --- | Identified whether the game controller was added, removed, or remapped. +data ControllerAxis + = ControllerAxisInvalid + | ControllerAxisLeftX + | ControllerAxisLeftY + | ControllerAxisRightX + | ControllerAxisRightY + | ControllerAxisTriggerLeft + | ControllerAxisTriggerRight + | ControllerAxisMax + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +instance ToNumber ControllerAxis Int32 where + toNumber a = case a of + ControllerAxisLeftX -> Raw.SDL_CONTROLLER_AXIS_LEFTX + ControllerAxisLeftY -> Raw.SDL_CONTROLLER_AXIS_LEFTY + ControllerAxisRightX -> Raw.SDL_CONTROLLER_AXIS_RIGHTX + ControllerAxisRightY -> Raw.SDL_CONTROLLER_AXIS_RIGHTY + ControllerAxisTriggerLeft -> Raw.SDL_CONTROLLER_AXIS_TRIGGERLEFT + ControllerAxisTriggerRight -> Raw.SDL_CONTROLLER_AXIS_TRIGGERRIGHT + ControllerAxisMax -> Raw.SDL_CONTROLLER_AXIS_MAX + ControllerAxisInvalid -> Raw.SDL_CONTROLLER_AXIS_INVALID + +instance FromNumber ControllerAxis Int32 where + fromNumber n = case n of + Raw.SDL_CONTROLLER_AXIS_LEFTX -> ControllerAxisLeftX + Raw.SDL_CONTROLLER_AXIS_LEFTY -> ControllerAxisLeftY + Raw.SDL_CONTROLLER_AXIS_RIGHTX -> ControllerAxisRightX + Raw.SDL_CONTROLLER_AXIS_RIGHTY -> ControllerAxisRightY + Raw.SDL_CONTROLLER_AXIS_TRIGGERLEFT -> ControllerAxisTriggerLeft + Raw.SDL_CONTROLLER_AXIS_TRIGGERRIGHT -> ControllerAxisTriggerRight + Raw.SDL_CONTROLLER_AXIS_MAX -> ControllerAxisMax + _ -> ControllerAxisInvalid + +-- | Identifies whether the game controller was added, removed, or remapped. data ControllerDeviceConnection = ControllerDeviceAdded | ControllerDeviceRemoved diff --git a/src/SDL/Input/Joystick.hs b/src/SDL/Input/Joystick.hs --- a/src/SDL/Input/Joystick.hs +++ b/src/SDL/Input/Joystick.hs @@ -108,7 +108,7 @@ -- in future SDL events. -- -- See @@ for C documentation. -getJoystickID :: MonadIO m => Joystick -> m (Int32) +getJoystickID :: MonadIO m => Joystick -> m Raw.JoystickID getJoystickID (Joystick j) = throwIfNeg "SDL.Input.Joystick.getJoystickID" "SDL_JoystickInstanceID" $ Raw.joystickInstanceID j diff --git a/src/SDL/Internal/Types.hs b/src/SDL/Internal/Types.hs --- a/src/SDL/Internal/Types.hs +++ b/src/SDL/Internal/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} module SDL.Internal.Types ( Joystick(..) + , GameController(..) , Window(..) , Renderer(..) ) where @@ -13,6 +14,10 @@ import qualified SDL.Raw as Raw newtype Joystick = Joystick { joystickPtr :: Raw.Joystick } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +newtype GameController = GameController + { gameControllerPtr :: Raw.GameController } deriving (Data, Eq, Generic, Ord, Show, Typeable) newtype Window = Window (Raw.Window) diff --git a/src/SDL/Raw/Types.hsc b/src/SDL/Raw/Types.hsc --- a/src/SDL/Raw/Types.hsc +++ b/src/SDL/Raw/Types.hsc @@ -72,6 +72,7 @@ #ifdef RECENT_ISH FPoint(..), FRect(..), + Vertex(..), #endif RendererInfo(..), RWops(..), @@ -1400,6 +1401,24 @@ (#poke SDL_FRect, w) ptr w (#poke SDL_FRect, h) ptr h +data Vertex = Vertex + { vertexPosition :: !FPoint + , vertexColor :: !Color + , vertexTexCoord :: !FPoint + } deriving (Eq, Show, Typeable) + +instance Storable Vertex where + sizeOf _ = (#size SDL_Vertex) + alignment _ = (#alignment SDL_Vertex) + peek ptr = do + position <- (#peek SDL_Vertex, position) ptr + color <- (#peek SDL_Vertex, color) ptr + tex_coord <- (#peek SDL_Vertex, tex_coord) ptr + return $! Vertex position color tex_coord + poke ptr (Vertex position color tex_coord) = do + (#poke SDL_Vertex, position) ptr position + (#poke SDL_Vertex, color) ptr color + (#poke SDL_Vertex, tex_coord) ptr tex_coord #endif data RendererInfo = RendererInfo diff --git a/src/SDL/Raw/Video.hs b/src/SDL/Raw/Video.hs --- a/src/SDL/Raw/Video.hs +++ b/src/SDL/Raw/Video.hs @@ -52,6 +52,7 @@ getWindowID, getWindowMaximumSize, getWindowMinimumSize, + getWindowOpacity, getWindowPixelFormat, getWindowPosition, getWindowSize, @@ -73,6 +74,7 @@ setWindowIcon, setWindowMaximumSize, setWindowMinimumSize, + setWindowOpacity, setWindowPosition, setWindowSize, setWindowTitle, @@ -128,6 +130,8 @@ renderDrawRectsF, renderFillRectF, renderFillRectsF, + renderGeometry, + renderGeometryRaw, #endif renderGetClipRect, renderGetLogicalSize, @@ -282,6 +286,7 @@ foreign import ccall "SDL.h SDL_GetWindowID" getWindowIDFFI :: Window -> IO Word32 foreign import ccall "SDL.h SDL_GetWindowMaximumSize" getWindowMaximumSizeFFI :: Window -> Ptr CInt -> Ptr CInt -> IO () foreign import ccall "SDL.h SDL_GetWindowMinimumSize" getWindowMinimumSizeFFI :: Window -> Ptr CInt -> Ptr CInt -> IO () +foreign import ccall "SDL.h SDL_GetWindowOpacity" getWindowOpacityFFI :: Window -> Ptr CFloat -> IO () foreign import ccall "SDL.h SDL_GetWindowPixelFormat" getWindowPixelFormatFFI :: Window -> IO Word32 foreign import ccall "SDL.h SDL_GetWindowPosition" getWindowPositionFFI :: Window -> Ptr CInt -> Ptr CInt -> IO () foreign import ccall "SDL.h SDL_GetWindowSize" getWindowSizeFFI :: Window -> Ptr CInt -> Ptr CInt -> IO () @@ -303,6 +308,7 @@ foreign import ccall "SDL.h SDL_SetWindowIcon" setWindowIconFFI :: Window -> Ptr Surface -> IO () foreign import ccall "SDL.h SDL_SetWindowMaximumSize" setWindowMaximumSizeFFI :: Window -> CInt -> CInt -> IO () foreign import ccall "SDL.h SDL_SetWindowMinimumSize" setWindowMinimumSizeFFI :: Window -> CInt -> CInt -> IO () +foreign import ccall "SDL.h SDL_SetWindowOpacity" setWindowOpacityFFI :: Window -> CFloat -> IO () foreign import ccall "SDL.h SDL_SetWindowPosition" setWindowPositionFFI :: Window -> CInt -> CInt -> IO () foreign import ccall "SDL.h SDL_SetWindowSize" setWindowSizeFFI :: Window -> CInt -> CInt -> IO () foreign import ccall "SDL.h SDL_SetWindowTitle" setWindowTitleFFI :: Window -> CString -> IO () @@ -355,6 +361,8 @@ foreign import ccall "SDL.h SDL_RenderDrawRectsF" renderDrawRectsFFFI :: Renderer -> Ptr FRect -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderFillRectF" renderFillRectFFFI :: Renderer -> Ptr FRect -> IO CInt foreign import ccall "SDL.h SDL_RenderFillRectsF" renderFillRectsFFFI :: Renderer -> Ptr FRect -> CInt -> IO CInt +foreign import ccall "SDL.h SDL_RenderGeometry" renderGeometryFFI :: Renderer -> Texture -> Ptr Vertex -> CInt -> Ptr CInt -> CInt -> IO CInt +foreign import ccall "SDL.h SDL_RenderGeometryRaw" renderGeometryRawFFI :: Renderer -> Texture -> Ptr FPoint -> CInt -> Ptr Color -> CInt -> Ptr FPoint -> CInt -> CInt -> Ptr () -> CInt -> CInt -> IO CInt #endif 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 @@ -643,6 +651,10 @@ getWindowMinimumSize v1 v2 v3 = liftIO $ getWindowMinimumSizeFFI v1 v2 v3 {-# INLINE getWindowMinimumSize #-} +getWindowOpacity :: MonadIO m => Window -> Ptr CFloat -> m () +getWindowOpacity v1 v2 = liftIO $ getWindowOpacityFFI v1 v2 +{-# INLINE getWindowOpacity #-} + getWindowPixelFormat :: MonadIO m => Window -> m Word32 getWindowPixelFormat v1 = liftIO $ getWindowPixelFormatFFI v1 {-# INLINE getWindowPixelFormat #-} @@ -727,6 +739,10 @@ setWindowMinimumSize v1 v2 v3 = liftIO $ setWindowMinimumSizeFFI v1 v2 v3 {-# INLINE setWindowMinimumSize #-} +setWindowOpacity :: MonadIO m => Window -> CFloat -> m () +setWindowOpacity v1 v2 = liftIO $ setWindowOpacityFFI v1 v2 +{-# INLINE setWindowOpacity #-} + setWindowPosition :: MonadIO m => Window -> CInt -> CInt -> m () setWindowPosition v1 v2 v3 = liftIO $ setWindowPositionFFI v1 v2 v3 {-# INLINE setWindowPosition #-} @@ -937,6 +953,13 @@ renderFillRectsF v1 v2 v3 = liftIO $ renderFillRectsFFFI v1 v2 v3 {-# INLINE renderFillRectsF #-} +renderGeometry :: MonadIO m => Renderer -> Texture -> Ptr Vertex -> CInt -> Ptr CInt -> CInt -> m CInt +renderGeometry v1 v2 v3 v4 v5 v6 = liftIO $ renderGeometryFFI v1 v2 v3 v4 v5 v6 +{-# INLINE renderGeometry #-} + +renderGeometryRaw :: MonadIO m => Renderer -> Texture -> Ptr FPoint -> CInt -> Ptr Color -> CInt -> Ptr FPoint -> CInt -> CInt -> Ptr () -> CInt -> CInt -> m CInt +renderGeometryRaw v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 = liftIO $ renderGeometryRawFFI v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 +{-# INLINE renderGeometryRaw #-} #endif diff --git a/src/SDL/Video.hs b/src/SDL/Video.hs --- a/src/SDL/Video.hs +++ b/src/SDL/Video.hs @@ -25,6 +25,7 @@ -- * Window Attributes , windowMinimumSize , windowMaximumSize + , windowOpacity , windowSize , windowBordered , windowBrightness @@ -610,6 +611,22 @@ alloca $ \hptr -> do Raw.getWindowMinimumSize win wptr hptr V2 <$> peek wptr <*> peek hptr + +-- | Get or set the opacity of a window. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +windowOpacity :: Window -> StateVar CFloat +windowOpacity (Window win) = makeStateVar getWindowOpacity setWindowOpacity + where + setWindowOpacity opacity = Raw.setWindowOpacity win opacity + + getWindowOpacity = + liftIO $ + alloca $ \optr -> do + Raw.getWindowOpacity win optr + peek optr createRenderer :: MonadIO m => Window -> CInt -> RendererConfig -> m Renderer createRenderer (Window w) driver config = diff --git a/src/SDL/Video/Renderer.hs b/src/SDL/Video/Renderer.hs --- a/src/SDL/Video/Renderer.hs +++ b/src/SDL/Video/Renderer.hs @@ -42,6 +42,9 @@ , drawRectsF , fillRectF , fillRectsF + , renderGeometry + , Raw.Vertex(..) + , renderGeometryRaw #endif , present @@ -744,6 +747,45 @@ SV.unsafeWith rects $ \rp -> Raw.renderFillRectsF r (castPtr rp) (fromIntegral (SV.length rects)) +-- | Render a list of triangles, optionally using a texture and indices into the +-- vertex array Color and alpha modulation is done per vertex +-- (SDL_SetTextureColorMod and SDL_SetTextureAlphaMod are ignored). +renderGeometry :: MonadIO m => Renderer -> Maybe Texture -> SV.Vector Raw.Vertex -> SV.Vector CInt -> m () +renderGeometry (Renderer r) mtexture vertices indices = liftIO $ + throwIfNeg_ "SDL.Video.renderGeometry" "SDL_RenderGeometry" $ + SV.unsafeWith vertices $ \vp -> + SV.unsafeWith indices $ \ip -> + Raw.renderGeometry r t vp (fromIntegral (SV.length vertices)) (ipOrNull ip) ipSize + where + t = case mtexture of + Just (Texture found) -> found + Nothing -> nullPtr + + ipOrNull ip = if ipSize == 0 then nullPtr else ip + + ipSize = fromIntegral (SV.length indices) + +-- | Render a list of triangles, optionally using a texture and indices into the +-- vertex array Color and alpha modulation is done per vertex +-- (SDL_SetTextureColorMod and SDL_SetTextureAlphaMod are ignored). +-- +-- This version allows storeing vertex data in arbitrary types, but you have to provide +-- pointers and strides yourself. +renderGeometryRaw :: forall ix m . (Storable ix, MonadIO m) => Renderer -> Maybe Texture -> Ptr Raw.FPoint -> CInt -> Ptr Raw.Color -> CInt -> Ptr Raw.FPoint -> CInt -> CInt -> SV.Vector ix -> m () +renderGeometryRaw (Renderer r) mtexture xy xyStride color colorStride uv uvStride numVertices indices = liftIO $ + throwIfNeg_ "SDL.Video.renderGeometryRaw" "SDL_RenderGeometryRaw" $ + SV.unsafeWith indices $ \ip -> + Raw.renderGeometryRaw r t xy xyStride color colorStride uv uvStride numVertices (castPtr $ ipOrNull ip) ipSize sizeOfip + where + t = case mtexture of + Just (Texture found) -> found + Nothing -> nullPtr + + ipOrNull ip = if ipSize == 0 then nullPtr else ip + + ipSize = fromIntegral (SV.length indices) + + sizeOfip = fromIntegral $ sizeOf (undefined :: ix) #endif