sdl2-compositor 1.2.0.3 → 1.2.0.4
raw patch · 6 files changed
+219/−25 lines, 6 filesdep ~sdl2-ttf
Dependency ranges changed: sdl2-ttf
Files
- SDL/Compositor.hs +2/−1
- SDL/Compositor/TTF.hs +4/−5
- SDL/Data/Cache.hs +26/−9
- SDL/Data/Texture.hs +178/−5
- font-test.hs +7/−3
- sdl2-compositor.cabal +2/−2
SDL/Compositor.hs view
@@ -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 ()
SDL/Compositor/TTF.hs view
@@ -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
SDL/Data/Cache.hs view
@@ -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.
SDL/Data/Texture.hs view
@@ -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<BlendMode>: 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
font-test.hs view
@@ -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
sdl2-compositor.cabal view
@@ -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,