MultiFont.hs

-- | Typically, we use multiple fonts to compose a document. 
-- Some examples for this are: 
--
--  * bold, italic, etc typefaces as separate font files
--
--  * greek, cyrillic and other non-latin alphabets
--
--  * a monospace font
--
--  * mathematical symbols
--
-- We can also use different font sizes, for example subscript, superscript, etc.
--
-- This module provides a layer on the top "FontTexture" to support this.
--
-- For a good trade-off between simplicity and generality, we opt to encode
-- a glyph as a Unicode code point together with a user-defined style attribute,
-- and let the user provide a mapping from this to different physical font files.
--

{-# LANGUAGE BangPatterns #-}
module Graphics.Rendering.MiniTypeset.MultiFont where

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

import Control.Monad
import Data.IORef

import qualified Data.Map    as Map    ; import Data.Map    (Map   )
import qualified Data.IntMap as IntMap ; import Data.IntMap (IntMap)

import System.FilePath ( takeFileName )

-- import Graphics.Rendering.OpenGL as GL

import Graphics.Rendering.TrueType.STB

import Graphics.Rendering.MiniTypeset.Common
import Graphics.Rendering.MiniTypeset.FontTexture

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

-- | given a font height (in pixels), we return how big texture(s) should we allocate for this
stdFontTextureSize :: Int -> (Int,Int)
stdFontTextureSize height
  | height <= 12  = ( 128,128)
  | height <= 16  = ( 256,256)
  | height <= 48  = ( 512,512)
  | height <= 128 = (1024,1024)
  | otherwise     = (2048,2048)

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

-- | The user-defined types @fontfile@ and @style@ should encode the available 
-- font files and styles. They should be an enumerated type for efficiency. @fontfile@
-- must have 'Eq' and 'Ord' instances, too.
data UserFontConfig fontfile style = UserFontConfig
  { _ufcFontFiles :: fontfile -> FilePath            -- ^ the mapping from abstract to physical font files
  , _ufcCharMap   :: style -> Char -> fontfile       -- ^ the mapping from characters to font files
  , _ufcStyleMap  :: BasicStyle -> style             -- ^ mapping the basic style into the user styles
  }

data MultiFont fontfile style = MultiFont
  { _mfUserConfig :: !(UserFontConfig fontfile style)              -- ^ the user-defined configuration
  , _mfFontTexs   :: !(IORef (Map fontfile (IntMap FontTexture)))  -- ^ mapping from font files and heights to textures
  }

mfCharMap :: MultiFont fontfile style -> style -> Char -> fontfile
mfCharMap = _ufcCharMap . _mfUserConfig

newMultiFont :: Ord fontfile => UserFontConfig fontfile style -> IO (MultiFont fontfile style)
newMultiFont ufc = do
  tbl <- newIORef Map.empty
  return $ MultiFont ufc tbl

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

loadFontFile :: FilePath -> IO Font
loadFontFile fpath = do
  otfPackage <- loadTTF fpath
  ofsList <- enumerateFonts otfPackage
  font <- case ofsList of
    []    -> error "MultiFont/loadFontFile: fatal error: empty font file"
    [ofs] -> initFont otfPackage ofs
    _     -> error "MultiFont/loadFontFile: multiple fonts in a font file are not (yet?) supported"
  return font

mapInsert :: Ord k => a -> (a -> a) -> k -> Map k a -> Map k a
mapInsert y f k table = Map.alter h k table where
  h Nothing  = Just y
  h (Just x) = Just (f x)

mapIntLookup :: Ord k => k -> Int -> Map k (IntMap a) -> Maybe a
mapIntLookup k j table = case Map.lookup k table of
  Nothing  -> Nothing
  Just sub -> IntMap.lookup j sub

mfAddNewFontTex :: Ord fontfile => MultiFont fontfile style -> (fontfile,Int) -> IO ()
mfAddNewFontTex mf (ffile,height) = do
  old_table <- readIORef (_mfFontTexs mf) 
  let fpath = (_ufcFontFiles $ _mfUserConfig mf) ffile
  font <- loadFontFile fpath
  ftex <- newFontTexture' font (fromIntegral height) (takeFileName fpath) (stdFontTextureSize height) 
  let new_table = mapInsert (IntMap.singleton height ftex) (IntMap.insert height ftex) ffile old_table
  writeIORef (_mfFontTexs mf) new_table

--------------------------------------------------------------------------------
-- * Multifont glyphs

data MultiFontGlyph 
  = MFG !FontTexture !BufLoc 
  deriving Show

{-
mbLkpMultiFont :: Ord fontfile => MultiFont fontfile style -> Int -> style -> Char -> IO (Maybe MultiFontGlyph)
mbLkpMultiFont multifont height style char = do
  table <- readIORef (_mfFontTexs multifont) 
  let fontfile = mfCharMap multifont style char
  case mapIntLookup fontfile height table of
    Nothing -> do
      mfAddNewFontTex multifont (fontfile,height) 
      mbLkpMultiFont multifont height style char 
    Just ftex -> do
      mbloc <- mbLookupFontTexture ftex char
      return $ liftM (\loc -> (MFG ftex loc)) mbloc
-}

lkpMultiFont :: Ord fontfile => MultiFont fontfile style -> Int -> style -> Char -> IO MultiFontGlyph
lkpMultiFont multifont height style char = do
  table <- readIORef (_mfFontTexs multifont) 
  let fontfile = mfCharMap multifont style char
  case mapIntLookup fontfile height table of
    Nothing -> do
      mfAddNewFontTex multifont (fontfile,height) 
      lkpMultiFont multifont height style char 
    Just ftex -> do
      loc <- lookupFontTexture ftex char
      return $ MFG ftex loc

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