module Graphics.Rendering.MiniTypeset.FontTexture where
import Data.Word
import Data.Char
import GHC.Float
import Foreign.Ptr
import Foreign.Storable
import Foreign.C
import Foreign.Marshal.Array
import Control.Monad
import Control.Concurrent
import Data.IORef
import System.IO.Unsafe as Unsafe
import Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.TrueType.STB
replacementCharacter :: Char
replacementCharacter = '\xfffd'
data BufLoc = BufLoc
{ _locGlyph :: !Glyph
, _locBufIdx :: !Int
, _locBufXY :: !(Int,Int)
, _locBufSiz :: !(Int,Int)
, _locBufOfs :: !(Int,Int)
, _locHM :: !(HorizontalMetrics Float)
}
deriving Show
data TexBuf = TexBuf
{ _bufTexObj :: !TextureObject
, _bufSize :: !(Int,Int)
}
deriving Show
allocateTexBuf :: FontTexture -> IO TexBuf
allocateTexBuf ftex = do
let (w,h) = _ftexBufSize ftex
texobj <- genObjectName
let texbuf = TexBuf
{ _bufTexObj = texobj
, _bufSize = (w,h)
}
textureBinding Texture2D $=! Just texobj
textureLevelRange Texture2D $=! (0,0)
textureFilter Texture2D $=! ((Nearest,Nothing),Nearest)
textureWrapMode Texture2D S $=! (Repeated,ClampToBorder)
textureWrapMode Texture2D T $=! (Repeated,ClampToBorder)
textureWrapMode Texture2D R $=! (Repeated,ClampToBorder)
textureBorderColor Texture2D $=! (Color4 0 0 0 0)
generateMipmap Texture2D $= Disabled
let zeros = replicate (div (w*h+7) 8) (0::Word64)
withArray zeros $ \ptr -> do
let pd = PixelData Alpha UnsignedByte (castPtr ptr) :: PixelData Word8
fi = fromIntegral :: Int -> GLint
texImage2D Texture2D NoProxy 0 Alpha8 (TextureSize2D (fi w) (fi h)) 0 pd
atomicModifyIORef' (_ftexBufs ftex) $ \oldList -> (oldList ++ [texbuf],())
return texbuf
data TexCursor = TexCursor
{ _curBufIdx :: !Int
, _curX :: !Int
, _curY :: !Int
, _cutMaxHt :: !Int
}
deriving Show
zeroCursor :: TexCursor
zeroCursor = TexCursor
{ _curBufIdx = 0
, _curX = 0
, _curY = 0
, _cutMaxHt = 0
}
data FontTexture = FontTexture
{ _ftexFont :: !Font
, _ftexName :: !String
, _ftexHeight :: !(Float,Float)
, _ftexScaling :: !Scaling
, _ftexVM :: !(VerticalMetrics Float)
, _ftexChars :: !(UnicodeCache (Maybe BufLoc))
, _ftexBufSize :: !(Int,Int)
, _ftexCursor :: !(IORef TexCursor)
, _ftexBufs :: !(IORef [TexBuf])
, _ftexLGapFactor :: !Double
}
instance Show FontTexture where
show ftex = "FontTexture:<" ++ _ftexName ftex ++ ">"
scaleU :: Float -> Unscaled -> Float
scaleU s x = s * fromIntegral x
defaultTextureSize :: (Int,Int)
defaultTextureSize = (512,512)
newFontTexture :: Font -> Float -> String -> IO FontTexture
newFontTexture font height name = newFontTexture' font (height,height) name defaultTextureSize 1
newFontTexture' :: Font -> (Float,Float) -> String -> (Int,Int) -> Double -> IO FontTexture
newFontTexture' font (xheight,yheight) name size lgapfactor = do
uc <- newUnicodeCache
vmu <- getFontVerticalMetrics font
let sx = scaleForPixelHeight vmu xheight
sy = scaleForPixelHeight vmu yheight
vms = fmap (scaleU sy) vmu
cur <- newIORef zeroCursor
texbufref <- newIORef []
let ftex = FontTexture
{ _ftexFont = font
, _ftexName = name
, _ftexHeight = (xheight,yheight)
, _ftexScaling = (sx,sy)
, _ftexVM = vms
, _ftexChars = uc
, _ftexBufSize = size
, _ftexCursor = cur
, _ftexBufs = texbufref
, _ftexLGapFactor = lgapfactor
}
void $ allocateTexBuf ftex
return ftex
lookupFontTexture :: FontTexture -> Char -> IO BufLoc
lookupFontTexture ftex ch = do
mb <- mbLookupFontTexture ftex ch
case mb of
Just bufloc -> return bufloc
Nothing -> do
mb <- mbLookupFontTexture ftex replacementCharacter
case mb of
Just bufloc -> return bufloc
Nothing -> lookupFontTexture ftex notDefinedGlyphChar
mbLookupFontTexture :: FontTexture -> Char -> IO (Maybe BufLoc)
mbLookupFontTexture ftex ch = lookupUnicodeCache ch allocate (_ftexChars ftex) where
font = _ftexFont ftex
(texw,texh) = _ftexBufSize ftex
scaling@(hs,vs) = _ftexScaling ftex
allocate :: Char -> IO (Maybe BufLoc)
allocate ch = do
mbglyph <- findGlyph font ch
case mbglyph of
Nothing -> return Nothing
Just glyph -> do
mb <- getGlyphBoundingBox font glyph
case mb of
Nothing -> return Nothing
Just {} -> do
(bm,bmofs) <- newGlyphBitmap font glyph scaling
let (w,h) = bitmapSize bm
oldCur@(TexCursor bufidx x y maxh) <- readIORef (_ftexCursor ftex)
let x' = x + w + 2
y' = y + maxh + 2
w' = w + 2
h' = h + 2
(rloc,newCur) <- if x' < texw && y' < texh
then return ( (bufidx,x,y) , TexCursor bufidx x' y (max h maxh) )
else if y' + h' < texh
then return ( (bufidx,0,y') , TexCursor bufidx w' y' h )
else do
void $ allocateTexBuf ftex
let bufidx' = bufidx + 1
return ( (bufidx',0,0) , TexCursor bufidx' w' 0 h )
writeIORef (_ftexCursor ftex) newCur
oldAlign <- get (rowAlignment Unpack)
rowAlignment Unpack $=! (1 :: GLint)
let (rbuf,rx,ry) = rloc
bufs <- readIORef (_ftexBufs ftex)
let texBuf@(TexBuf texobj texsiz) = bufs!!rbuf
withBitmap bm $ \_ _ ptr -> do
let pd = PixelData Alpha UnsignedByte ptr
fi = fromIntegral :: Int -> GLint
textureBinding Texture2D $=! Just texobj
texSubImage2D Texture2D 0
(TexturePosition2D (fi rx + 1) (fi ry + 1))
(TextureSize2D (fi w ) (fi h ))
pd
rowAlignment Unpack $=! oldAlign
hmu <- getGlyphHorizontalMetrics font glyph
let hms = fmap (scaleU hs) hmu
let bufloc = BufLoc
{ _locGlyph = glyph
, _locBufIdx = rbuf
, _locBufXY = (rx,ry)
, _locBufSiz = (w,h)
, _locBufOfs = bmofs
, _locHM = hms
}
return $ Just bufloc
testRenderFullTextureQuad :: FontTexture -> Int -> IO ()
testRenderFullTextureQuad ftex idx = do
bufs <- readIORef (_ftexBufs ftex)
let buf = bufs!!idx
matrixMode $= Projection
loadIdentity
ortho 0 1 1 0 (-1) 1
texture Texture2D $= Enabled
textureBinding Texture2D $= Just (_bufTexObj buf)
textureFunction $= Modulate
blend $= Enabled
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
color (Color4 1 1 1 (1::Double))
let a = 0 :: Double
b = 1 :: Double
c = 0.1 :: Double
d = 0.9 :: Double
renderPrimitive Quads $ do
texCoord (TexCoord2 a a) ; vertex (Vertex2 c c)
texCoord (TexCoord2 a b) ; vertex (Vertex2 c d)
texCoord (TexCoord2 b b) ; vertex (Vertex2 d d)
texCoord (TexCoord2 b a) ; vertex (Vertex2 d c)
texture Texture2D $= Disabled