diff --git a/SDL/Compositor.hs b/SDL/Compositor.hs --- a/SDL/Compositor.hs +++ b/SDL/Compositor.hs @@ -214,7 +214,8 @@ renderNode (defaultState target) node rendererDrawColor target SDL.$= currentDrawColor -renderNode :: forall tex rend . (Texture tex, Renderable rend tex, Renderer rend) => +renderNode :: forall tex rend . + (Texture tex, Renderable rend tex, Renderer rend) => RendState rend tex -> CompositingNode tex -> IO () diff --git a/SDL/Compositor/TTF.hs b/SDL/Compositor/TTF.hs --- a/SDL/Compositor/TTF.hs +++ b/SDL/Compositor/TTF.hs @@ -12,9 +12,9 @@ import Control.Monad import Data.Text -import Graphics.UI.SDL.TTF -import Graphics.UI.SDL.TTF.FFI (TTFFont) -import Graphics.UI.SDL.TTF.Types +import SDL.TTF +import SDL.TTF.FFI (TTFFont) +import SDL.TTF.Types import SDL import SDL.Raw.Types (Color(..)) @@ -71,8 +71,7 @@ if kerning then setFontKerning font KerningOn else setFontKerning font KerningOff - s <- renderUTF8Solid font (unpack msg) color - let surf = Surface s Nothing + surf <- renderUTF8Solid font (unpack msg) color tex <- createTextureFromSurface rend surf freeSurface surf when changeStyle $ setFontStyle font oldStyle diff --git a/SDL/Data/Cache.hs b/SDL/Data/Cache.hs --- a/SDL/Data/Cache.hs +++ b/SDL/Data/Cache.hs @@ -12,24 +12,41 @@ ) where -import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM.TMVar (TMVar,newTMVar,tryReadTMVar,tryTakeTMVar,putTMVar) -import Control.Monad.STM (atomically) -import Data.Cache.LRU (LRU,newLRU,insert,insertInforming,lookup) -import Prelude hiding (lookup) -import SDL (Texture, destroyTexture,Surface,freeSurface) +import Control.Monad.STM (atomically) +import Data.Cache.LRU (LRU,newLRU,insert,insertInforming,lookup) +import Prelude hiding (lookup) +import qualified SDL as SDL (Texture, destroyTexture, Surface,freeSurface) +import qualified SDL.Raw as Raw +import SDL.Data.Texture + -- | Something is cacheable if there is an action to release the -- resource (if necessary). class Cacheable r where releaseResource :: r -> IO () -instance Cacheable Texture where - releaseResource = destroyTexture +instance Cacheable (SDL.Texture) where + releaseResource = SDL.destroyTexture -instance Cacheable Surface where - releaseResource = freeSurface +instance Cacheable (SDL.Surface) where + releaseResource = SDL.freeSurface +instance Cacheable RawTexture where + releaseResource (RawTexture tex) = Raw.destroyTexture tex + +instance (Cacheable a) => Cacheable (Maybe a) where + releaseResource Nothing = return () + releaseResource (Just r) = releaseResource r + +instance Cacheable Int where + releaseResource _ = return () + +instance (Cacheable a) => Cacheable [a] where + releaseResource = mapM_ releaseResource + +-- | Thread safe LRU cache. data Cache k a = Cache (TMVar (LRU k a)) Int -- | Create a new cache instance. diff --git a/SDL/Data/Texture.hs b/SDL/Data/Texture.hs --- a/SDL/Data/Texture.hs +++ b/SDL/Data/Texture.hs @@ -3,18 +3,30 @@ ( Renderable(..) , Texture(..) , Renderer(..) + -- * Bindings for low level sdl2 + , RawTexture(..) ) where +import Control.Lens (view) import Control.Monad (void) -import Data.StateVar (StateVar) -import Data.Word (Word8) -import Foreign.C (CDouble(..)) +import Data.Bits ((.|.)) +import Data.StateVar (StateVar, makeStateVar) +import Data.Word (Word8,Word32) +import Foreign.C (CDouble(..),CInt) +import Foreign.C.String +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc (malloc, free) +import Foreign.Marshal.Utils (with, maybeWith) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (Storable(peek)) import Linear.Affine (Point(..)) -import Linear.V2 (V2(..)) -import Linear.V3 (V3) +import Linear.V2 (V2(..), _x, _y) +import Linear.V3 (V3(..)) import Linear.V4 (V4) import qualified SDL +import qualified SDL.Internal.Types as SDL +import qualified SDL.Raw as Raw -- | This class modells that something can be rendered to another -- thing. @@ -43,6 +55,28 @@ createTexture r pf ta = SDL.createTexture r pf ta . fmap fromIntegral rendererRenderTarget = SDL.rendererRenderTarget +instance Renderable SDL.Renderer RawTexture where + copyEx (SDL.Renderer rend) (RawTexture tex) sourceRect destRect rot center flipping = + maybeWith with (toRawRect <$> sourceRect) $ \sourceRectPtr -> + maybeWith with (toRawRect <$> destRect) $ \destRectPtr -> + maybeWith with (toPoint <$> center) $ \centerPtr -> + void $ Raw.renderCopyEx rend tex + sourceRectPtr destRectPtr (CDouble rot) centerPtr (flipToWord flipping) + rendererRenderTarget (SDL.Renderer rend) = + makeStateVar getter setter + where + getter = do + tex <- Raw.getRenderTarget rend + if tex == nullPtr + then return Nothing + else (return . Just . RawTexture) tex + setter Nothing = void $ Raw.setRenderTarget rend nullPtr + setter (Just (RawTexture tex)) = void $ Raw.setRenderTarget rend tex + createTexture (SDL.Renderer rend) format access (V2 w h) = + RawTexture <$> + Raw.createTexture rend (formatToRaw format) (accessToRaw access) + (fromIntegral w) (fromIntegral h) + class Texture tex where textureAlphaMod :: tex -> StateVar Word8 textureColorMod :: tex -> StateVar (V3 Word8) @@ -78,3 +112,142 @@ present = SDL.present drawRect r = SDL.drawRect r . fmap (fmap fromIntegral) drawLine r a b = SDL.drawLine r (fromIntegral <$> a) (fromIntegral <$> b) + +-- | Wrapper around the raw Texture type from SDL package. +newtype RawTexture = RawTexture { getRawTexture :: Raw.Texture } + deriving (Eq,Ord) + +instance Texture RawTexture where + textureAlphaMod (RawTexture rawTex) = + makeStateVar getter setter + where + getter = returnSecond Raw.getTextureAlphaMod rawTex + setter newMod = void $ Raw.setTextureAlphaMod rawTex newMod + textureColorMod (RawTexture rawTex) = + makeStateVar getter setter + where + getter = do + rPtr <- malloc + gPtr <- malloc + bPtr <- malloc + void $ Raw.getTextureColorMod rawTex rPtr gPtr bPtr + colorVal <- V3 <$> peek rPtr <*> peek gPtr <*> peek bPtr + free rPtr + free gPtr + free bPtr + return colorVal + setter (V3 rmod gmod bmod) = + void $ Raw.setTextureColorMod rawTex rmod gmod bmod + textureBlendMode (RawTexture rawTex) = + makeStateVar getter setter + where + getter = convertBlendModeFromRaw <$> + returnSecond Raw.getTextureBlendMode rawTex + setter bm = void $ Raw.setTextureBlendMode rawTex + (convertBlendModeToRaw bm) + textureDims (RawTexture rawTex) = + fmap fromIntegral <$> queryTexture rawTex + textureWidth (RawTexture rawTex) = + fromIntegral . view _x <$> queryTexture rawTex + textureHeight (RawTexture rawTex) = + fromIntegral . view _y <$> queryTexture rawTex + destroyTexture = Raw.destroyTexture . getRawTexture + +returnSecond :: (Storable b) => (a -> Ptr b -> IO c) -> a -> IO b +returnSecond fun x = do + ptr <- malloc + _ <- fun x ptr + val <- peek ptr + free ptr + return val + +convertBlendModeFromRaw :: Raw.BlendMode -> SDL.BlendMode +convertBlendModeFromRaw bm = case bm of + Raw.SDL_BLENDMODE_ADD -> SDL.BlendAdditive + Raw.SDL_BLENDMODE_BLEND -> SDL.BlendAlphaBlend + Raw.SDL_BLENDMODE_NONE -> SDL.BlendNone + Raw.SDL_BLENDMODE_MOD -> SDL.BlendMod + _ -> error $ "fromNumber: unknown blend mode: " ++ show bm + +convertBlendModeToRaw :: SDL.BlendMode -> Raw.BlendMode +convertBlendModeToRaw SDL.BlendNone = Raw.SDL_BLENDMODE_NONE +convertBlendModeToRaw SDL.BlendAlphaBlend = Raw.SDL_BLENDMODE_BLEND +convertBlendModeToRaw SDL.BlendAdditive = Raw.SDL_BLENDMODE_ADD +convertBlendModeToRaw SDL.BlendMod = Raw.SDL_BLENDMODE_MOD + +toRawRect :: (Integral a) => SDL.Rectangle a -> Raw.Rect +toRawRect (SDL.Rectangle (P (V2 x y)) (V2 w h)) = + Raw.Rect + (fromIntegral x) + (fromIntegral y) + (fromIntegral w) + (fromIntegral h) + +toPoint :: (Integral a) => Point V2 a -> Raw.Point +toPoint (P (V2 x y)) = Raw.Point (fromIntegral x) (fromIntegral y) + +flipToWord :: V2 Bool -> Raw.RendererFlip +flipToWord (V2 h v) + | h && v = + Raw.SDL_FLIP_VERTICAL .|. Raw.SDL_FLIP_HORIZONTAL + | h = Raw.SDL_FLIP_HORIZONTAL + | v = Raw.SDL_FLIP_VERTICAL + | otherwise = Raw.SDL_FLIP_NONE + +formatToRaw :: SDL.PixelFormat -> Word32 +formatToRaw pf = case pf of + SDL.Unknown -> Raw.SDL_PIXELFORMAT_UNKNOWN + SDL.Index1LSB -> Raw.SDL_PIXELFORMAT_INDEX1LSB + SDL.Index1MSB -> Raw.SDL_PIXELFORMAT_INDEX1MSB + SDL.Index4LSB -> Raw.SDL_PIXELFORMAT_INDEX4LSB + SDL.Index4MSB -> Raw.SDL_PIXELFORMAT_INDEX4MSB + SDL.Index8 -> Raw.SDL_PIXELFORMAT_INDEX8 + SDL.RGB332 -> Raw.SDL_PIXELFORMAT_RGB332 + SDL.RGB444 -> Raw.SDL_PIXELFORMAT_RGB444 + SDL.RGB555 -> Raw.SDL_PIXELFORMAT_RGB555 + SDL.BGR555 -> Raw.SDL_PIXELFORMAT_BGR555 + SDL.ARGB4444 -> Raw.SDL_PIXELFORMAT_ARGB4444 + SDL.RGBA4444 -> Raw.SDL_PIXELFORMAT_RGBA4444 + SDL.ABGR4444 -> Raw.SDL_PIXELFORMAT_ABGR4444 + SDL.BGRA4444 -> Raw.SDL_PIXELFORMAT_BGRA4444 + SDL.ARGB1555 -> Raw.SDL_PIXELFORMAT_ARGB1555 + SDL.RGBA5551 -> Raw.SDL_PIXELFORMAT_RGBA5551 + SDL.ABGR1555 -> Raw.SDL_PIXELFORMAT_ABGR1555 + SDL.BGRA5551 -> Raw.SDL_PIXELFORMAT_BGRA5551 + SDL.RGB565 -> Raw.SDL_PIXELFORMAT_RGB565 + SDL.BGR565 -> Raw.SDL_PIXELFORMAT_BGR565 + SDL.RGB24 -> Raw.SDL_PIXELFORMAT_RGB24 + SDL.BGR24 -> Raw.SDL_PIXELFORMAT_BGR24 + SDL.RGB888 -> Raw.SDL_PIXELFORMAT_RGB888 + SDL.RGBX8888 -> Raw.SDL_PIXELFORMAT_RGBX8888 + SDL.BGR888 -> Raw.SDL_PIXELFORMAT_BGR888 + SDL.BGRX8888 -> Raw.SDL_PIXELFORMAT_BGRX8888 + SDL.ARGB8888 -> Raw.SDL_PIXELFORMAT_ARGB8888 + SDL.RGBA8888 -> Raw.SDL_PIXELFORMAT_RGBA8888 + SDL.ABGR8888 -> Raw.SDL_PIXELFORMAT_ABGR8888 + SDL.BGRA8888 -> Raw.SDL_PIXELFORMAT_BGRA8888 + SDL.ARGB2101010 -> Raw.SDL_PIXELFORMAT_ARGB2101010 + SDL.YV12 -> Raw.SDL_PIXELFORMAT_YV12 + SDL.IYUV -> Raw.SDL_PIXELFORMAT_IYUV + SDL.YUY2 -> Raw.SDL_PIXELFORMAT_YUY2 + SDL.UYVY -> Raw.SDL_PIXELFORMAT_UYVY + SDL.YVYU -> Raw.SDL_PIXELFORMAT_YVYU + +accessToRaw :: SDL.TextureAccess -> CInt +accessToRaw t = case t of + SDL.TextureAccessStatic -> Raw.SDL_TEXTUREACCESS_STATIC + SDL.TextureAccessStreaming -> Raw.SDL_TEXTUREACCESS_STREAMING + SDL.TextureAccessTarget -> Raw.SDL_TEXTUREACCESS_TARGET + +queryTexture :: Raw.Texture -> IO (V2 CInt) +queryTexture tex = do + formatPtr <- malloc + accessPtr <- malloc + wPtr <- malloc + hPtr <- malloc + void $ Raw.queryTexture tex formatPtr accessPtr wPtr hPtr + free accessPtr + free formatPtr + dims <- V2 <$> peek wPtr <*> peek hPtr + mapM_ free [wPtr, hPtr] + return dims diff --git a/font-test.hs b/font-test.hs --- a/font-test.hs +++ b/font-test.hs @@ -1,12 +1,16 @@ import Control.Concurrent import Control.Monad import Data.Text hiding (head) -import qualified Graphics.UI.SDL.TTF as TTF import Linear.V2 import Linear.V4 import SDL + (quit, BlendMode(BlendAlphaBlend),defaultWindow,initializeAll, + defaultRenderer,createWindow,createRenderer) import SDL.Compositor + (present,clear,translateA,overC,blendMode,runRenderer,filledRectangleC) +import SDL.Compositor.TTF (withFont,showText,Alignment(AlignLeft)) import SDL.Raw (Color(..)) +import qualified SDL.TTF as TTF import System.Environment main = do @@ -22,8 +26,8 @@ rectangle = filledRectangleC (V2 400 200) (V4 255 0 0 255) clear rend runRenderer rend (translateA (V2 400 300) $ - preserveBlendMode BlendAlphaBlend $ - (hello `overC` rectangle) + blendMode BlendAlphaBlend $ + (hello `overC` rectangle)) present rend threadDelay (5*1000000) TTF.quit diff --git a/sdl2-compositor.cabal b/sdl2-compositor.cabal --- a/sdl2-compositor.cabal +++ b/sdl2-compositor.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: sdl2-compositor -version: 1.2.0.3 +version: 1.2.0.4 synopsis: image compositing with sdl2 - declarative style description: This package provides tools for simple image composition @@ -41,7 +41,7 @@ sdl2 >= 2.0, transformers >= 0.4, linear >= 1.19, - sdl2-ttf >= 0.2.2, + sdl2-ttf >= 1, stm >= 2.3, lrucache >= 1.2, text,