{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gelatin.Core.Rendering.Font (
compileFontCache,
fontGeom,
findFont,
allFonts,
withFontAsync,
withFont,
concaveTriangles
) where
import Gelatin.Core.Rendering.Types
import Gelatin.Core.Rendering.Geometrical
import Prelude hiding (init)
import Control.Concurrent.Async
import Linear
import Graphics.Text.TrueType
import qualified Data.Vector.Unboxed as UV
compileFontCache :: IO (Async FontCache)
compileFontCache = async $ do
putStrLn "Loading font cache."
a <- buildCache
putStrLn "Font cache loaded."
return a
findFont :: Async FontCache -> FontDescriptor -> IO (Maybe FilePath)
findFont afCache desc = do
mfCache <- poll afCache
return $ do efCache <- mfCache
case efCache of
Left _ -> Nothing
Right cache -> findFontInCache cache desc
allFonts :: Async FontCache -> IO (Maybe [FontDescriptor])
allFonts afcache = do
mfcache <- poll afcache
return $ do efcache <- mfcache
case efcache of
Left _ -> Nothing
Right fcache -> Just $ enumerateFonts fcache
withFontAsync :: Async FontCache -> FontDescriptor -> (Font -> IO a) -> IO (Maybe a)
withFontAsync afcache desc f = do
mPath <- findFont afcache desc
case mPath of
Nothing -> return Nothing
Just path -> do ef <- loadFontFile path
case ef of
Left err -> putStrLn err >> return Nothing
Right font -> Just `fmap` f font
withFont :: FontCache -> FontDescriptor -> (Font -> IO a) -> IO (Maybe a)
withFont cache desc f = do
case findFontInCache cache desc of
Nothing -> return Nothing
Just fp -> do ef <- loadFontFile fp
case ef of
Left err -> putStrLn err >> return Nothing
Right font -> Just `fmap` f font
type Contours = [Bezier (V2 Float)]
type CharacterOutline = [Contours]
type StringOutline = [CharacterOutline]
fontGeom :: Dpi -> FontString -> ([Bezier (V2 Float)], [Triangle (V2 Float)])
fontGeom dpi (FontString font px offset str) =
let sz = pixelSizeInPointAtDpi px dpi
cs = getStringCurveAtPoint dpi offset [(font, sz, str)]
bs = beziers cs
ts = concatMap (concatMap (concaveTriangles . onContourPoints)) bs
in (concat $ concat bs,ts)
fromFonty :: (UV.Unbox b1, Functor f1, Functor f) => ([V2 b1] -> b) -> f (f1 (UV.Vector (b1, b1))) -> f (f1 b)
fromFonty f = fmap $ fmap $ f . UV.toList . UV.map (uncurry V2)
beziers :: [[UV.Vector (Float, Float)]] -> StringOutline
beziers = fromFonty (toBeziers . (fmap (fmap realToFrac)))
concaveTriangles :: [a] -> [Triangle a]
concaveTriangles [] = []
concaveTriangles (a:as) = tris a as
where tris p (p':p'':ps) = Triangle p p' p'' : tris p (p'':ps)
tris _ _ = []
onContourPoints :: [Bezier a] -> [a]
onContourPoints [] = []
onContourPoints ((Bezier LT a b c):bs) = [a,b,c] ++ onContourPoints bs
onContourPoints ((Bezier _ a _ c):bs) = [a,c] ++ onContourPoints bs