never executed always true always false
    1 {-|
    2 Module: Flaw.Graphics.Font.Render
    3 Description: Font rendering.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE RankNTypes, ViewPatterns #-}
    8 
    9 module Flaw.Graphics.Font.Render
   10   ( GlyphRenderer
   11   , GlyphSubpixelMode(..)
   12   , initGlyphRenderer
   13   , RenderableFont(..)
   14   , createRenderableFont
   15   , RenderableFontCache(..)
   16   , createRenderableFontCache
   17   , RenderGlyphsM
   18   , renderGlyphs
   19   , RenderTextCursorX(..)
   20   , RenderTextCursorY(..)
   21   , renderTextRun
   22   , renderTexts
   23   ) where
   24 
   25 import Control.Concurrent.STM
   26 import Control.Monad.Catch
   27 import Control.Monad.Reader
   28 import qualified Data.ByteString.Unsafe as B
   29 import Data.Default
   30 import qualified Data.HashMap.Strict as HM
   31 import qualified Data.HashSet as HS
   32 import Data.IORef
   33 import qualified Data.Text as T
   34 import qualified Data.Vector as V
   35 import qualified Data.Vector.Storable.Mutable as VSM
   36 import Foreign.ForeignPtr
   37 import Foreign.ForeignPtr.Unsafe
   38 import Foreign.Marshal.Array
   39 import Foreign.Ptr
   40 import Foreign.Storable
   41 
   42 import Flaw.Book
   43 import Flaw.Flow
   44 import Flaw.Graphics
   45 import Flaw.Graphics.Blend
   46 import Flaw.Graphics.Font
   47 import Flaw.Graphics.Program
   48 import Flaw.Graphics.Sampler
   49 import Flaw.Graphics.Texture
   50 import Flaw.Math
   51 
   52 -- | Glyph renderer keeps resources needed to render glyphs on a graphics device.
   53 data GlyphRenderer d = GlyphRenderer
   54   { glyphRendererVertexBuffer :: !(VertexBufferId d)
   55   , glyphRendererIndexBuffer :: !(IndexBufferId d)
   56   , glyphRendererUniformBuffer :: !(UniformBufferId d)
   57   , glyphRendererBlendState :: !(BlendStateId d)
   58   , glyphRendererProgram :: !(ProgramId d)
   59   , glyphRendererCapacity :: !Int
   60   , glyphRendererBuffer :: !(VSM.IOVector Float4)
   61   }
   62 
   63 -- | Subpixel antialiasing mode.
   64 data GlyphSubpixelMode
   65   = GlyphSubpixelModeNone
   66   | GlyphSubpixelModeHorizontalRGB
   67   | GlyphSubpixelModeHorizontalBGR
   68   | GlyphSubpixelModeVerticalRGB
   69   | GlyphSubpixelModeVerticalBGR
   70 
   71 initGlyphRenderer :: Device d => d -> GlyphSubpixelMode -> IO (GlyphRenderer d, IO ())
   72 initGlyphRenderer device subpixelMode = do
   73   bk <- newBook
   74 
   75   let
   76     vbStride = sizeOf (undefined :: Float4)
   77   vb <- book bk $ withArray
   78     [ Vec4 0 1 1 0 :: Float4
   79     , Vec4 1 1 0 0
   80     , Vec4 1 0 0 1
   81     , Vec4 0 1 1 0
   82     , Vec4 1 0 0 1
   83     , Vec4 0 0 1 1
   84     ] $ \ptr -> do
   85     bytes <- B.unsafePackCStringLen (castPtr ptr, vbStride * 6)
   86     createStaticVertexBuffer device bytes vbStride
   87   let
   88     ib = nullIndexBuffer
   89     capacity = 256;
   90   ub <- book bk $ createUniformBuffer device (capacity * 3 * sizeOf (undefined :: Float4))
   91 
   92   let
   93     nonSubpixelBlendStateInfo = def
   94       { blendSourceColor = ColorSourceOne
   95       , blendDestColor = ColorSourceInvSrcAlpha
   96       , blendSourceAlpha = AlphaSourceOne
   97       , blendDestAlpha = AlphaSourceInvSrc
   98       , blendColorOperation = BlendOperationAdd
   99       }
  100     subpixelBlendStateInfo = def
  101       { blendSourceColor = ColorSourceOne
  102       , blendDestColor = ColorSourceInvSecondSrc
  103       , blendSourceAlpha = AlphaSourceOne
  104       , blendDestAlpha = AlphaSourceInvSrc
  105       , blendColorOperation = BlendOperationAdd
  106       }
  107   bs <- book bk $ createBlendState device $ case subpixelMode of
  108     GlyphSubpixelModeNone -> nonSubpixelBlendStateInfo
  109     GlyphSubpixelModeHorizontalRGB -> subpixelBlendStateInfo
  110     GlyphSubpixelModeHorizontalBGR -> subpixelBlendStateInfo
  111     GlyphSubpixelModeVerticalRGB -> subpixelBlendStateInfo
  112     GlyphSubpixelModeVerticalBGR -> subpixelBlendStateInfo
  113 
  114   ubs <- uniformBufferSlot 0
  115   uPositions <- uniformArray capacity ubs :: IO (Node [Float4])
  116   uTexcoords <- uniformArray capacity ubs :: IO (Node [Float4])
  117   uColors <- uniformArray capacity ubs :: IO (Node [Float4])
  118   program <- book bk $ createProgram device $ do
  119     aCorner <- attribute 0 0 0 (AttributeVec4 AttributeFloat32)
  120     position <- temp $ uPositions ! instanceId
  121     texcoordCoefs <- temp $ uTexcoords ! instanceId
  122     color <- temp $ uColors ! instanceId
  123     texcoord <- temp $ cvec11 (dot (xz__ aCorner) (xz__ texcoordCoefs)) (dot (yw__ aCorner) (yw__ texcoordCoefs))
  124     rasterize (cvec1111
  125       (dot (xz__ aCorner) (xz__ position))
  126       (dot (yw__ aCorner) (yw__ position))
  127       (constf 0)
  128       (constf 1)
  129       ) $ case subpixelMode of
  130       GlyphSubpixelModeNone -> do
  131         alpha <- temp $ w_ color * sampleLod (sampler2Df 0) texcoord (constf 0)
  132         colorTarget 0 $ cvec31 (xyz__ color * vecFromScalar alpha) alpha
  133       _ -> let
  134         (dxr, dxg, dxb, dyr, dyg, dyb) = case subpixelMode of
  135           GlyphSubpixelModeNone -> undefined -- GHC warning defence, meh :(
  136           GlyphSubpixelModeHorizontalRGB -> (-1, 0, 1, 0, 0, 0)
  137           GlyphSubpixelModeHorizontalBGR -> (1, 0, -1, 0, 0, 0)
  138           GlyphSubpixelModeVerticalRGB -> (0, 0, 0, -1, 0, 1)
  139           GlyphSubpixelModeVerticalBGR -> (0, 0, 0, 1, 0, -1)
  140         r = w_ color * sampleLod (sampler2Df 0) (texcoord
  141           + ddx texcoord * vecFromScalar (constf $ dxr / 3)
  142           + ddy texcoord * vecFromScalar (constf $ dyr / 3)) (constf 0)
  143         g = w_ color * sampleLod (sampler2Df 0) (texcoord
  144           + ddx texcoord * vecFromScalar (constf $ dxg / 3)
  145           + ddy texcoord * vecFromScalar (constf $ dyg / 3)) (constf 0)
  146         b = w_ color * sampleLod (sampler2Df 0) (texcoord
  147           + ddx texcoord * vecFromScalar (constf $ dxb / 3)
  148           + ddy texcoord * vecFromScalar (constf $ dyb / 3)) (constf 0)
  149         in dualColorTarget (cvec31 (xyz__ color * cvec111 r g b) ((r + g + b) / 3)) (cvec1111 r g b (constf 1))
  150 
  151   buffer <- VSM.new $ capacity * 3
  152 
  153   return (GlyphRenderer
  154     { glyphRendererVertexBuffer = vb
  155     , glyphRendererIndexBuffer = ib
  156     , glyphRendererUniformBuffer = ub
  157     , glyphRendererBlendState = bs
  158     , glyphRendererProgram = program
  159     , glyphRendererCapacity = capacity
  160     , glyphRendererBuffer = buffer
  161     }, freeBook bk)
  162 
  163 -- | Runtime data about glyph of particular font.
  164 data RenderableGlyph = RenderableGlyph
  165   { renderableGlyphUV :: !Float4 -- ^ Left-bottom + right-top UV coordinates.
  166   , renderableGlyphOffset :: !Float4 -- ^ Offset from pen point to left-bottom + right-top corner, in pixels.
  167   }
  168 
  169 -- | Runtime data about particular font.
  170 data RenderableFont d = RenderableFont
  171   { renderableFontTexture :: !(TextureId d)
  172   , renderableFontGlyphs :: !(HM.HashMap Int RenderableGlyph)
  173   -- | Maximum glyph box (left, top, right, bottom values relative to pen point, i.e. left-baseline).
  174   , renderableFontMaxGlyphBox :: !Float4
  175   }
  176 
  177 createRenderableFont :: Device d => d -> Glyphs -> IO (RenderableFont d, IO ())
  178 createRenderableFont device Glyphs
  179   { glyphsTextureInfo = textureInfo@TextureInfo
  180     { textureWidth = width
  181     , textureHeight = height
  182     }
  183   , glyphsTextureData = textureData
  184   , glyphsInfos = infos
  185   , glyphsScaleX = scaleX
  186   , glyphsScaleY = scaleY
  187   } = withSpecialBook $ \bk -> do
  188 
  189   -- create texture
  190   textureId <- book bk $ createStaticTexture device textureInfo def
  191     { samplerMinFilter = SamplerLinearFilter
  192     , samplerMipFilter = SamplerPointFilter
  193     , samplerMagFilter = SamplerLinearFilter
  194     , samplerWrapU = SamplerWrapClamp
  195     , samplerWrapV = SamplerWrapClamp
  196     , samplerWrapW = SamplerWrapClamp
  197     , samplerMaxLod = 0
  198     } textureData
  199 
  200   -- create glyphs
  201   let
  202     invSize = xyxy__ $ Vec2 (1 / fromIntegral width) (1 / fromIntegral height)
  203     invScale = xyxy__ $ Vec2 (1 / fromIntegral scaleX) (1 / fromIntegral scaleY)
  204     createRenderableGlyph GlyphInfo
  205       { glyphWidth = gw
  206       , glyphHeight = gh
  207       , glyphLeftTopX = gltx
  208       , glyphLeftTopY = glty
  209       , glyphOffsetX = gox
  210       , glyphOffsetY = goy
  211       } = RenderableGlyph
  212       { renderableGlyphUV = Vec4 ltx (lty + h) (ltx + w) lty * invSize
  213       , renderableGlyphOffset = Vec4 ox (oy + h) (ox + w) oy * invScale
  214       } where
  215       w = fromIntegral gw
  216       h = fromIntegral gh
  217       ltx = fromIntegral gltx
  218       lty = fromIntegral glty
  219       ox = fromIntegral gox
  220       oy = fromIntegral goy
  221     glyphs = HM.map createRenderableGlyph infos
  222 
  223   -- calculate max glyph box
  224   let
  225     foldGlyphBox GlyphInfo
  226       { glyphWidth = gw
  227       , glyphHeight = gh
  228       , glyphOffsetX = gox
  229       , glyphOffsetY = goy
  230       } (Vec4 left top right bottom) = Vec4
  231       (min left $ fromIntegral gox)
  232       (min top $ fromIntegral goy)
  233       (max right $ fromIntegral (gw + gox))
  234       (max bottom $ fromIntegral (gh + goy))
  235     maxGlyphBox = foldr foldGlyphBox (Vec4 1e8 1e8 (-1e8) (-1e8)) infos
  236 
  237   return RenderableFont
  238     { renderableFontTexture = textureId
  239     , renderableFontGlyphs = glyphs
  240     , renderableFontMaxGlyphBox = maxGlyphBox * invScale
  241     }
  242 
  243 data RenderableFontCache d = RenderableFontCache
  244   { renderableFontCacheMaybeFontVar :: {-# UNPACK #-} !(TMVar (Maybe (RenderableFont d)))
  245   , renderableFontCacheNeededGlyphsVar :: {-# UNPACK #-} !(TVar (HS.HashSet Int))
  246   , renderableFontCacheNeedMoreGlyphsVar :: {-# UNPACK #-} !(TVar Bool)
  247   }
  248 
  249 createRenderableFontCache :: Device d => d -> ([Int] -> IO (Maybe Glyphs)) -> IO (RenderableFontCache d, IO ())
  250 createRenderableFontCache device createGlyphs = withSpecialBook $ \bk -> do
  251   maybeFontVar <- newTMVarIO Nothing
  252   neededGlyphsVar <- newTVarIO HS.empty
  253   needMoreGlyphsVar <- newTVarIO False
  254 
  255   fontBook <- book bk newDynamicBook
  256 
  257   -- start cache update thread
  258   book bk $ forkFlow $ forever $ do
  259     -- wait until we need more glyphs
  260     atomically $ do
  261       needMoreGlyphs <- readTVar needMoreGlyphsVar
  262       unless needMoreGlyphs retry
  263     -- get needed glyphs after a delay, so more glyphs may be accumulated
  264     delayVar <- registerDelay 30000
  265     neededGlyphs <- atomically $ do
  266       timeout <- readTVar delayVar
  267       unless timeout retry
  268       -- reset flag
  269       writeTVar needMoreGlyphsVar False
  270       -- return frozen set of glyphs needed
  271       readTVar neededGlyphsVar
  272     -- clear font book
  273     releaseFontBook <- releaseBook fontBook
  274     -- try to create glyphs
  275     maybeGlyphs <- createGlyphs (HS.toList neededGlyphs)
  276     case maybeGlyphs of
  277       Just glyphs -> atomically . void . swapTMVar maybeFontVar =<< Just <$> book fontBook (createRenderableFont device glyphs)
  278       Nothing -> atomically $ do
  279         -- reset needed glyphs and start from scratch
  280         writeTVar neededGlyphsVar HS.empty
  281         writeTVar needMoreGlyphsVar False
  282         void $ swapTMVar maybeFontVar Nothing
  283     -- free old font
  284     releaseFontBook
  285 
  286   return RenderableFontCache
  287     { renderableFontCacheMaybeFontVar = maybeFontVar
  288     , renderableFontCacheNeededGlyphsVar = neededGlyphsVar
  289     , renderableFontCacheNeedMoreGlyphsVar = needMoreGlyphsVar
  290     }
  291 
  292 data GlyphToRender = GlyphToRender
  293   { glyphToRenderPosition :: {-# UNPACK #-} !Float2
  294   , glyphToRenderIndex :: {-# UNPACK #-} !Int
  295   , glyphToRenderColor :: {-# UNPACK #-} !Float4
  296   }
  297 
  298 data RenderGlyphsState c d = RenderGlyphsState
  299   { renderGlyphsStateAddGlyph :: !(GlyphToRender -> Render c ())
  300   , renderGlyphsStateMaxGlyphBox :: {-# UNPACK #-} !Float4
  301   }
  302 
  303 type RenderGlyphsM c d = ReaderT (RenderGlyphsState c d) (Render c)
  304 
  305 -- | Draw glyphs using font cache.
  306 renderGlyphs :: Context c d => GlyphRenderer d -> RenderableFontCache d -> RenderGlyphsM c d a -> Render c a
  307 renderGlyphs GlyphRenderer
  308   { glyphRendererVertexBuffer = vb
  309   , glyphRendererIndexBuffer = ib
  310   , glyphRendererUniformBuffer = ub
  311   , glyphRendererBlendState = bs
  312   , glyphRendererProgram = program
  313   , glyphRendererCapacity = capacity
  314   , glyphRendererBuffer = buffer
  315   } RenderableFontCache
  316   { renderableFontCacheMaybeFontVar = maybeFontVar
  317   , renderableFontCacheNeededGlyphsVar = neededGlyphsVar
  318   , renderableFontCacheNeedMoreGlyphsVar = needMoreGlyphsVar
  319   } m = bracket (liftIO $ atomically $ takeTMVar maybeFontVar) (liftIO . atomically . putTMVar maybeFontVar) $ \maybeRenderableFont -> renderScope $ do
  320 
  321   bufferIndexRef <- liftIO $ newIORef 0
  322 
  323   let
  324     (textureId, maybeGlyphs, maxGlyphBox) = case maybeRenderableFont of
  325       Just RenderableFont
  326         { renderableFontTexture = tid
  327         , renderableFontGlyphs = glyphs
  328         , renderableFontMaxGlyphBox = mgb
  329         } -> (tid, Just glyphs, mgb)
  330       Nothing -> (nullTexture, Nothing, Vec4 0 0 0 0)
  331 
  332   -- setup stuff
  333   renderVertexBuffer 0 vb
  334   renderIndexBuffer ib
  335   renderUniformBuffer 0 ub
  336   renderSampler 0 textureId nullSamplerState
  337   renderBlendState bs
  338   renderProgram program
  339 
  340   let
  341     flush = do
  342       count <- liftIO $ readIORef bufferIndexRef
  343       when (count > 0) $ do
  344         -- upload data to uniform buffer
  345         let (foreignPtr, len) = VSM.unsafeToForeignPtr0 buffer
  346         bytes <- liftIO $ B.unsafePackCStringLen (castPtr $ unsafeForeignPtrToPtr foreignPtr, len * sizeOf (undefined :: Float4))
  347         renderUploadUniformBuffer ub bytes
  348         liftIO $ touchForeignPtr foreignPtr
  349         -- render batch
  350         renderDrawInstanced count 6
  351       liftIO $ writeIORef bufferIndexRef 0
  352 
  353   Vec4 viewportLeft viewportTop viewportRight viewportBottom <- renderGetViewport
  354   let
  355     viewportScale = xyxy__ $ Vec2 (2 / fromIntegral (viewportRight - viewportLeft)) (2 / fromIntegral (viewportTop - viewportBottom))
  356     viewportOffset = Vec4 (-1) 1 (-1) 1
  357 
  358     addGlyph GlyphToRender
  359       { glyphToRenderPosition = Vec2 x y
  360       , glyphToRenderIndex = index
  361       , glyphToRenderColor = color
  362       } = do
  363       do
  364         bufferIndex <- liftIO $ readIORef bufferIndexRef
  365         when (bufferIndex >= capacity) flush
  366       case maybeGlyphs of
  367         Just (HM.lookup index -> Just RenderableGlyph
  368           { renderableGlyphUV = Vec4 tleft tbottom tright ttop
  369           , renderableGlyphOffset = Vec4 left bottom right top
  370           }) | left < right && top < bottom -> liftIO $ do
  371           bufferIndex <- readIORef bufferIndexRef
  372           -- round glyph bounds to pixel boundaries
  373           let roundedLeft = fromIntegral (floor (left + x) :: Int)
  374           let left' = roundedLeft - x
  375           let roundedTop = fromIntegral (floor (top + y) :: Int)
  376           let top' = roundedTop - y
  377           let roundedRight = fromIntegral (ceiling (right + x) :: Int)
  378           let right' = roundedRight - x
  379           let roundedBottom = fromIntegral (ceiling (bottom + y) :: Int)
  380           let bottom' = roundedBottom - y
  381           -- recalculate texture coordinates for rounded positions
  382           let invWidth = 1 / (right - left)
  383           let invHeight = 1 / (bottom - top)
  384           let kx = (tright - tleft) * invWidth
  385           let bx = (tleft * right - tright * left) * invWidth
  386           let ky = (tbottom - ttop) * invHeight
  387           let by = (ttop * bottom - tbottom * top) * invHeight
  388           let tleft' = kx * left' + bx
  389           let ttop' = ky * top' + by
  390           let tright' = kx * right' + bx
  391           let tbottom' = ky * bottom' + by
  392           -- write values into instanced buffer
  393           VSM.write buffer bufferIndex $ Vec4 roundedLeft roundedBottom roundedRight roundedTop * viewportScale + viewportOffset
  394           VSM.write buffer (bufferIndex + capacity) $ Vec4 tleft' tbottom' tright' ttop'
  395           VSM.write buffer (bufferIndex + capacity * 2) color
  396           -- advance index
  397           writeIORef bufferIndexRef $ bufferIndex + 1
  398         _ -> liftIO $ atomically $ do -- request missing glyphs
  399           neededGlyphs <- readTVar neededGlyphsVar
  400           unless (HS.member index neededGlyphs) $ do
  401             writeTVar neededGlyphsVar $ HS.insert index neededGlyphs
  402             writeTVar needMoreGlyphsVar True
  403 
  404   result <- runReaderT m RenderGlyphsState
  405     { renderGlyphsStateAddGlyph = addGlyph
  406     , renderGlyphsStateMaxGlyphBox = maxGlyphBox
  407     }
  408 
  409   flush
  410 
  411   return result
  412 
  413 data RenderTextCursorX = RenderTextCursorLeft | RenderTextCursorCenter | RenderTextCursorRight
  414 
  415 data RenderTextCursorY = RenderTextCursorBaseline | RenderTextCursorTop | RenderTextCursorMiddle | RenderTextCursorBottom
  416 
  417 -- | Render raw glyphs.
  418 renderTextRun :: V.Vector ShapedGlyph -> Float2 -> Float4 -> RenderGlyphsM c d ()
  419 renderTextRun shapedGlyphs position color = do
  420   RenderGlyphsState
  421     { renderGlyphsStateAddGlyph = addGlyph
  422     } <- ask
  423   forM_ shapedGlyphs $ \ShapedGlyph
  424     { shapedGlyphPosition = glyphPosition
  425     , shapedGlyphIndex = glyphIndex
  426     } -> lift $ addGlyph GlyphToRender
  427     { glyphToRenderPosition = position + glyphPosition
  428     , glyphToRenderIndex = glyphIndex
  429     , glyphToRenderColor = color
  430     }
  431 
  432 -- | Shape multiple text runs and output it in RenderGlyphsM monad.
  433 renderTexts :: FontShaper s => s -> [(T.Text, Float4)] -> FontScript -> Float2 -> RenderTextCursorX -> RenderTextCursorY -> RenderGlyphsM c d ()
  434 renderTexts shaper textsWithColors script (Vec2 px py) cursorX cursorY = do
  435   runsShapedGlyphsAndFinalPositions <- liftIO $ shapeText shaper (map fst textsWithColors) script
  436   RenderGlyphsState
  437     { renderGlyphsStateMaxGlyphBox = Vec4 _boxLeft boxTop _boxRight boxBottom
  438     } <- ask
  439   let
  440     Vec2 ax _ay = case runsShapedGlyphsAndFinalPositions of
  441       [] -> Vec2 0 0
  442       _ -> snd $ last runsShapedGlyphsAndFinalPositions
  443     x = case cursorX of
  444       RenderTextCursorLeft -> px
  445       RenderTextCursorCenter -> px - ax * 0.5
  446       RenderTextCursorRight -> px - ax
  447     y = case cursorY of
  448       RenderTextCursorBaseline -> py
  449       RenderTextCursorTop -> py - boxTop
  450       RenderTextCursorMiddle -> py - (boxTop + boxBottom) * 0.5
  451       RenderTextCursorBottom -> py - boxBottom
  452   forM_ (zip runsShapedGlyphsAndFinalPositions $ map snd textsWithColors) $
  453     \((shapedGlyphs, _advance), color) -> renderTextRun shapedGlyphs (Vec2 x y) color