diff --git a/SDL/Compositor/TTF.hs b/SDL/Compositor/TTF.hs new file mode 100644 --- /dev/null +++ b/SDL/Compositor/TTF.hs @@ -0,0 +1,80 @@ +module SDL.Compositor.TTF + ( -- * Interface + FontSupport(..) + , Alignment(..) + -- * Texture generation + , ColorWrapper(..) + , FontKey(..) + , defaultFontKey + , textureFromKey + ) +where + +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 +import SDL.Raw.Types (Color(..)) + +import SDL.Data.Cache + +data Alignment = AlignTopLeft | AlignTopRight | AlignTopCenter + | AlignLeft | AlignRight | AlignCenter + | AlignBottomLeft | AlignBottomRight | AlignBottomCenter + deriving (Eq,Read,Show) + +newtype ColorWrapper = ColorWrapper Color deriving Eq + +instance Ord ColorWrapper where + compare (ColorWrapper (Color r1 g1 b1 a1)) + (ColorWrapper (Color r2 g2 b2 a2)) = + compare (r1,g1,b1,a1) (r2,g2,b2,a2) + +data FontKey = FontKey { fkStyle :: TTFStyle + , fkFont :: TTFFont + , fkHinting :: TTFHinting + , fkKerning :: Bool + , fkMessage :: Text + , fkColor :: ColorWrapper + } + deriving (Eq,Ord) + +defaultFontKey :: TTFFont -> FontKey +defaultFontKey font = + FontKey { fkStyle = TTFNormal + , fkFont = font + , fkHinting = TTFHNormal + , fkKerning = True + , fkMessage = pack "" + , fkColor = (ColorWrapper (Color 255 255 255 255)) + } + +class FontSupport c where + withFontStyle :: TTFStyle -> c a -> c a + withFont :: TTFFont -> c a -> c a + withFontHint :: TTFHinting -> c a -> c a + showText :: Alignment -> Color -> Text -> c a + withKerning :: Bool -> c a -> c a + withFontCache :: (Cacheable a) => Cache FontKey a -> c a -> c a + +textureFromKey :: Renderer -> FontKey -> IO Texture +textureFromKey rend (FontKey style font + hints kerning msg (ColorWrapper color)) = do + oldStyle <- getFontStyle font + oldHinting <- getFontHinting font + let changeStyle = oldStyle /= style + changeHinting = oldHinting /= hints + when changeStyle $ setFontStyle font style + when changeHinting $ setFontHinting font hints + if kerning + then setFontKerning font KerningOn + else setFontKerning font KerningOff + s <- renderUTF8Solid font (unpack msg) color + let surf = Surface s Nothing + tex <- createTextureFromSurface rend surf + freeSurface surf + when changeStyle $ setFontStyle font oldStyle + when changeHinting $ setFontHinting font oldHinting + return tex diff --git a/SDL/Data/Cache.hs b/SDL/Data/Cache.hs new file mode 100644 --- /dev/null +++ b/SDL/Data/Cache.hs @@ -0,0 +1,73 @@ +module SDL.Data.Cache + ( + Cacheable (..) + , Cache + , newCache + , throughCache + , emptyCache + ) +where + +import Control.Concurrent.STM.TMVar +import Control.Monad.STM +import Data.Cache.LRU +import Prelude hiding (lookup) +import SDL + +class Cacheable r where + releaseResource :: r -> IO () + +instance Cacheable Texture where + releaseResource = destroyTexture + +instance Cacheable Surface where + releaseResource = freeSurface + +data Cache k a = Cache (TMVar (LRU k a)) Int + +newCache :: (Ord k) => Int -> IO (Cache k a) +newCache s = Cache <$> + atomically (newTMVar (newLRU (Just (fromIntegral s)))) <*> + pure s + +putInCache :: (Ord k, Cacheable r) => Cache k r -> k -> IO r -> IO r +putInCache (Cache var s) key action = do + newResource <- action + mOldResource <- atomically $ do + mlru <- tryReadTMVar var + case mlru of + Nothing -> do + let lru = newLRU (Just $ fromIntegral s) + putTMVar var (insert key newResource lru) + return Nothing + Just lru -> do + let (newLru,mOld) = insertInforming key newResource lru + putTMVar var newLru + return mOld + mapM_ (releaseResource.snd) mOldResource + pure newResource + +lookupFromCache :: (Ord k) => Cache k r -> k -> IO (Maybe r) +lookupFromCache (Cache var s) key = + atomically $ do + mLru <- tryTakeTMVar var + case mLru of + Nothing -> do + putTMVar var (newLRU (Just $ fromIntegral s)) + return Nothing + Just lru -> do + let (newLru,mVal) = lookup key lru + putTMVar var newLru + return mVal + +throughCache :: (Cacheable r, Ord k) => Cache k r -> k -> IO r -> IO r +throughCache cache key action = do + mVal <- lookupFromCache cache key + case mVal of + Nothing -> putInCache cache key action + Just val -> return val + +emptyCache :: (Cacheable r, Ord k) => Cache k r -> IO () +emptyCache (Cache var _) = do + mlru <- atomically $ tryTakeTMVar var + mapM_ (mapM_ releaseResource) mlru diff --git a/SDL/Data/Texture.hs b/SDL/Data/Texture.hs new file mode 100644 --- /dev/null +++ b/SDL/Data/Texture.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module SDL.Data.Texture + ( Renderable(..) + , Texture(..) + ) + where + +import qualified SDL +import Control.Monad (void) +import Linear.V2 (V2(..)) +import Linear.Affine (Point(..)) +import Linear.V3 (V3) +import Foreign.C (CDouble(..)) +import Data.StateVar (StateVar) +import Data.Word (Word8) + +-- | This class modells that something can be rendered to another +-- thing. +class Renderable rend tex where + copyEx :: rend -- ^ rendering context + -> tex -- ^ texture + -> Maybe (SDL.Rectangle Int) -- ^ source rectangle + -> Maybe (SDL.Rectangle Int) -- ^ destination rectangle + -> Double -- ^ rotation + -> Maybe (Point V2 Int) -- ^ rotation center + -> V2 Bool -- ^ flipping + -> IO () + +instance Renderable SDL.Renderer SDL.Texture where + copyEx rend tex sourceRect destRect rot center flipping = + void $ + SDL.copyEx rend tex (fmap fromIntegral <$> sourceRect) + (fmap fromIntegral <$> destRect) (CDouble rot) + (fmap fromIntegral <$> center) flipping + +class Texture tex where + textureAlphaMod :: tex -> StateVar Word8 + textureColorMod :: tex -> StateVar (V3 Word8) + textureBlendMode :: tex -> StateVar SDL.BlendMode + +instance Texture SDL.Texture where + textureAlphaMod = SDL.textureAlphaMod + textureColorMod = SDL.textureColorMod + textureBlendMode = SDL.textureBlendMode 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 +version: 1.2.0.1 synopsis: image compositing with sdl2 - declarative style description: This package provides tools for simple image composition @@ -30,8 +30,11 @@ exposed-modules: SDL.Compositor, SDL.Compositor.Manipulator, SDL.Compositor.Blender, - SDL.Compositor.Drawer - SDL.Compositor.ResIndependent + SDL.Compositor.Drawer, + SDL.Compositor.ResIndependent, + SDL.Compositor.TTF, + SDL.Data.Texture, + SDL.Data.Cache -- other-modules: -- other-extensions: build-depends: base >=4.8 && <4.9,