{-# LANGUAGE BangPatterns #-}
module Graphics.Rendering.MiniTypeset.Render where
import Data.Word
import Data.Char
import GHC.Float
import Control.Monad
import Data.IORef
import Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.TrueType.STB
import Graphics.Rendering.MiniTypeset.Common
import Graphics.Rendering.MiniTypeset.Box
import Graphics.Rendering.MiniTypeset.FontTexture
import Graphics.Rendering.MiniTypeset.MultiFont
setCol :: Col -> IO ()
setCol !(Col r g b) = color (Color3 r g b)
setColAlpha :: Col -> Float -> IO ()
setColAlpha !(Col r g b) !a = color (Color4 r g b a)
renderQuad :: Quad -> IO ()
renderQuad (Quad (x1,y1) (x2,y2)) =
renderPrimitive Quads $ do
vertex (Vertex2 x1 y1)
vertex (Vertex2 x2 y1)
vertex (Vertex2 x2 y2)
vertex (Vertex2 x1 y2)
renderOuterBoxQuad :: AbsBox -> IO ()
renderOuterBoxQuad = renderQuad . absboxOuterQuad
renderInnerBoxQuad :: AbsBox -> IO ()
renderInnerBoxQuad = renderQuad . absboxInnerQuad
renderGapBoxQuad :: AbsBox -> IO ()
renderGapBoxQuad = renderQuad . absboxGapQuad
renderBoundingBoxQuad :: AbsBox -> IO ()
renderBoundingBoxQuad = renderQuad . absboxBoundingQuad
renderQuadOutline :: Quad -> IO ()
renderQuadOutline (Quad (x1,y1) (x2,y2)) =
renderPrimitive LineLoop $ do
vertex (Vertex2 x1 y1)
vertex (Vertex2 x2 y1)
vertex (Vertex2 x2 y2)
vertex (Vertex2 x1 y2)
renderOuterBoxOutline :: AbsBox -> IO ()
renderOuterBoxOutline = renderQuadOutline . absboxOuterQuad
renderInnerBoxOutline :: AbsBox -> IO ()
renderInnerBoxOutline = renderQuadOutline . absboxInnerQuad
renderGapBoxOutline :: AbsBox -> IO ()
renderGapBoxOutline = renderQuadOutline . absboxGapQuad
renderBoundingBoxOutline :: AbsBox -> IO ()
renderBoundingBoxOutline = renderQuadOutline . absboxBoundingQuad
renderLine :: Col -> Double -> Pos -> Pos -> IO ()
renderLine !col !lwidth !(Pos x1 y1) !(Pos x2 y2) = do
setCol col
lineWidth $= double2Float lwidth
let hwidth = 0.5 * lwidth
renderPrimitive Lines $ do
vertex $ Vertex2 (dround x1) (dround y1)
vertex $ Vertex2 (dround x2) (dround y2)
where
dround :: Double -> Double
dround !x = fromIntegral (round x :: Int)
renderMFG :: Pos -> Col -> MultiFontGlyph -> IO ()
renderMFG !pos !col !(MFG ftex bufloc) = do
setCol col
renderChar' pos ftex bufloc
renderCharAt :: Pos -> FontTexture -> Char -> IO Double
renderCharAt pos ftex ch = do
bufloc <- lookupFontTexture ftex ch
renderChar' pos ftex bufloc
let adv = advanceWidth (_locHM bufloc)
return $ float2Double adv
renderCharAt_ :: Pos -> FontTexture -> Char -> IO ()
renderCharAt_ pos ftex ch = void $ renderCharAt pos ftex ch
renderChar' :: Pos -> FontTexture -> BufLoc -> IO ()
renderChar' !pos@(Pos x0 y0) !ftex !bufloc = do
bufs <- readIORef (_ftexBufs ftex)
let texBuf@(TexBuf texobj texsiz) = bufs!!(_locBufIdx bufloc)
textureBinding Texture2D $=! Just texobj
let (wi,hi) = _locBufSiz bufloc
(s,t) = _locBufXY bufloc
(p,q) = _locBufOfs bufloc
(x,y) = (x0 + fromIntegral p , y0 + fromIntegral q)
wf = fromIntegral wi :: Double
hf = fromIntegral hi :: Double
texture Texture2D $=! Enabled
blend $=! Enabled
blendFunc $=! (SrcAlpha,OneMinusSrcAlpha)
let (texw,texh) = _ftexBufSize ftex
ftexw = fromIntegral texw :: Double
ftexh = fromIntegral texh :: Double
fs, ft :: Int -> Double
fs !j = (fromIntegral j + 1.0) / ftexw
ft !i = (fromIntegral i + 1.0) / ftexh
let g :: Double -> Double
g x = fromIntegral (round x :: Int)
let tc s t = texCoord (TexCoord2 (fs s) (ft t))
vt x y = vertex (Vertex2 (g x) (g y))
renderPrimitive Quads $ do
tc s t ; vt x y
tc (s+wi) t ; vt (x+wf) y
tc (s+wi) (t+hi) ; vt (x+wf) (y+hf)
tc s (t+hi) ; vt x (y+hf)
blend $=! Disabled
texture Texture2D $=! Disabled
return ()