{-# 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.TrueType.STB
import Graphics.Rendering.MiniTypeset.Common
import Graphics.Rendering.MiniTypeset.FontTexture
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)
data UserFontConfig fontfile style = UserFontConfig
{ _ufcFontFiles :: fontfile -> FilePath
, _ufcCharMap :: style -> Char -> fontfile
, _ufcStyleMap :: BasicStyle -> style
, _ufcLineGapFactor :: !Double
}
data MultiFont fontfile style = MultiFont
{ _mfUserConfig :: !(UserFontConfig fontfile style)
, _mfFontTexs :: !(IORef (Map fontfile (IntMap FontTexture)))
}
mfCharMap :: MultiFont fontfile style -> style -> Char -> fontfile
mfCharMap = _ufcCharMap . _mfUserConfig
mfLineGapFactor :: MultiFont fontfile style -> Double
mfLineGapFactor = _ufcLineGapFactor . _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
encodeXYHeight :: (Int,Int) -> Int
encodeXYHeight (xheight,yheight) = yheight * 32768 + xheight
mfAddNewFontTex :: Ord fontfile => MultiFont fontfile style -> (fontfile,(Int,Int)) -> IO ()
mfAddNewFontTex mf (ffile,(xheight,yheight)) = do
old_table <- readIORef (_mfFontTexs mf)
let fpath = (_ufcFontFiles $ _mfUserConfig mf) ffile
font <- loadFontFile fpath
let idx = encodeXYHeight (xheight,yheight)
ftex <- newFontTexture' font (fromIntegral xheight, fromIntegral yheight) (takeFileName fpath) (stdFontTextureSize yheight) (mfLineGapFactor mf)
let new_table = mapInsert (IntMap.singleton idx ftex) (IntMap.insert idx ftex) ffile old_table
writeIORef (_mfFontTexs mf) new_table
data MultiFontGlyph
= MFG !FontTexture !BufLoc
deriving Show
mfgLineGapFactor :: MultiFontGlyph -> Double
mfgLineGapFactor (MFG ftex _) = _ftexLGapFactor ftex
lkpMultiFont :: Ord fontfile => MultiFont fontfile style -> Int -> style -> Char -> IO MultiFontGlyph
lkpMultiFont multifont height style char = lkpMultiFont' multifont (height,height) style char
lkpMultiFont' :: Ord fontfile => MultiFont fontfile style -> (Int,Int) -> style -> Char -> IO MultiFontGlyph
lkpMultiFont' multifont xyheight style char = do
table <- readIORef (_mfFontTexs multifont)
let fontfile = mfCharMap multifont style char
let idx = encodeXYHeight xyheight
case mapIntLookup fontfile idx table of
Nothing -> do
mfAddNewFontTex multifont (fontfile,xyheight)
lkpMultiFont' multifont xyheight style char
Just ftex -> do
loc <- lookupFontTexture ftex char
return $ MFG ftex loc