FontTexture.hs


-- | Store font glyphs in OpenGL textures
--
-- TODO: add (optional) subpixel rendering support 
-- (pre-render say 4 versions of the same glyphs with fractional horizontal offsets)
--

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'

--------------------------------------------------------------------------------

-- newtype FontIdx = FontIdx { unFontIdx :: Int }

-- | The location of a glyph in a font texture collection
data BufLoc = BufLoc
  { _locGlyph  :: !Glyph              
  , _locBufIdx :: !Int             -- ^ which buffer 
  , _locBufXY  :: !(Int,Int)       -- ^ position within the texture (buffer)
  , _locBufSiz :: !(Int,Int)       -- ^ size of the bounding box
  , _locBufOfs :: !(Int,Int)       -- ^ offset relative to the bounding box
  , _locHM     :: !(HorizontalMetrics Float)   -- ^ for convenience, we cache the glyph metrics
  }
  deriving Show

-- | A single texture buffer
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                    -- ?????

{-
  -- uninitialized texture
  let pd = PixelData Alpha UnsignedByte nullPtr :: PixelData Word8
      fi = fromIntegral :: Int -> GLint
  texImage2D Texture2D NoProxy 0 Alpha8 (TextureSize2D (fi w) (fi h)) 0 pd
-}

  -- texture initialized with zeros
  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

{-
  -- texture initialized with pixel checkerboard (useful for debugging)
  let minta1 = concat $ replicate (div w 2) [ 0x40, 0xc0 :: Word8 ]
      minta2 = concat $ replicate (div w 2) [ 0xc0, 0x40 :: Word8 ]
      minta  = concat $ concat $ replicate (div h 2) [ minta1 , minta2 ]
  withArray minta $ \ptr -> do
    let pd = PixelData Alpha UnsignedByte ptr :: PixelData Word8
        fi = fromIntegral :: Int -> GLint
    texImage2D Texture2D NoProxy 0 Alpha8 (TextureSize2D (fi w) (fi h)) 0 pd
-}

  --print (w,h,texobj)
  atomicModifyIORef' (_ftexBufs ftex) $ \oldList -> (oldList ++ [texbuf],())
  return texbuf

data TexCursor = TexCursor 
  { _curBufIdx :: !Int     -- ^ which buffer we are filling currently
  , _curX      :: !Int     -- ^ next X position
  , _curY      :: !Int     -- ^ current Y position
  , _cutMaxHt  :: !Int     -- ^ maximal bitmap height in this row
  }
  deriving Show

zeroCursor :: TexCursor
zeroCursor = TexCursor 
  { _curBufIdx = 0
  , _curX      = 0
  , _curY      = 0
  , _cutMaxHt  = 0
  }

-- | A font texture collection: possibly several textures containing bitmaps
-- a given font with a given height.
data FontTexture = FontTexture
  { _ftexFont    :: !Font
  , _ftexName    :: !String
  , _ftexHeight  :: !(Float,Float)   -- x and y height
  , _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) -- (128,128) -- (512,512) -- (1024,1024)

newFontTexture :: Font -> Float -> String -> IO FontTexture
newFontTexture font height name = newFontTexture' font (height,height) name defaultTextureSize 1

-- | Creates a new (empty) font texture. We allow different horizontal and vertical scaling,
-- but both are measured in /pixel heights/ 
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

--  print vmu
--  print vms

  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       -- allocate the very first buffer
  return ftex

-- | Finds a character in the font texture (rendering it first if necessary).
-- If the glyph is not present in the font, we return the \"replacement character\"
-- instead. If that doesn't exist either, then we return the \"not defined glyph\"
-- (glyph #0)
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

-- | Finds a character in the font texture (rendering it first if necessary)
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       -- this is cached
    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)

            -- figure out render location and next cursor
            let x' = x + w    + 2
                y' = y + maxh + 2
                w' = w + 2            -- we leave a 1 pixel (texel) border just to be safe
                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
            -- print (oldCur,newCur)

            oldAlign <- get (rowAlignment Unpack)
            rowAlignment Unpack $=! (1 :: GLint)

            -- render character at render location rloc
            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

            -- return location
            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
                  }
            -- putStrLn $ "'" ++ [ch] ++ "' -> "
            -- print bufloc
            return $ Just bufloc

--------------------------------------------------------------------------------

-- | Renders the given font texture as a quad (useful for debugging)
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

--------------------------------------------------------------------------------