{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
module Monomer.Graphics.FontManager (
makeFontManager
) where
import Control.Monad (foldM, when)
import Control.Lens ((^.))
import Data.Default
import Data.Sequence (Seq)
import Data.Text (Text)
import System.IO.Unsafe
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import Monomer.Common.BasicTypes
import Monomer.Graphics.FFI
import Monomer.Graphics.Types
import Monomer.Helper (putStrLnErr)
import Monomer.Graphics.Lens (fontName, fontPath, fontBytes)
makeFontManager
:: [FontDef]
-> Double
-> IO FontManager
makeFontManager :: [FontDef] -> Double -> IO FontManager
makeFontManager [FontDef]
fonts Double
dpr = do
FMContext
ctx <- Double -> IO FMContext
fmInit Double
dpr
[Text]
validFonts <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (FMContext -> [Text] -> FontDef -> IO [Text]
loadFont FMContext
ctx) [] [FontDef]
fonts
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
validFonts) forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
putStrLnErr [Char]
"Could not find any valid fonts. Text size calculations will fail."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FMContext -> FontManager
newManager FMContext
ctx
newManager :: FMContext -> FontManager
newManager :: FMContext -> FontManager
newManager FMContext
ctx = FontManager {Double -> Font -> FontSize -> TextMetrics
Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
Double -> Font -> FontSize -> FontSpace -> Text -> Size
Font -> FontSize -> TextMetrics
Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
Font -> FontSize -> FontSpace -> Text -> Size
computeGlyphsPos_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeTextSize_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size
computeTextMetrics_ :: Double -> Font -> FontSize -> TextMetrics
computeTextMetrics :: Font -> FontSize -> TextMetrics
computeGlyphsPos_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeTextSize_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size
computeTextMetrics_ :: Double -> Font -> FontSize -> TextMetrics
computeTextMetrics :: Font -> FontSize -> TextMetrics
..} where
computeTextMetrics :: Font -> FontSize -> TextMetrics
computeTextMetrics Font
font FontSize
fontSize =
Double -> Font -> FontSize -> TextMetrics
computeTextMetrics_ Double
1 Font
font FontSize
fontSize
computeTextMetrics_ :: Double -> Font -> FontSize -> TextMetrics
computeTextMetrics_ Double
scale Font
font FontSize
fontSize = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
scale Font
font FontSize
fontSize forall a. Default a => a
def
(Double
asc, Double
desc, Double
lineh) <- FMContext -> IO (Double, Double, Double)
fmTextMetrics FMContext
ctx
Maybe GlyphPosition
lowerX <- forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FMContext -> Double -> Double -> Text -> IO (Seq GlyphPosition)
fmTextGlyphPositions FMContext
ctx Double
0 Double
0 Text
"x"
let heightLowerX :: CFloat
heightLowerX = case Maybe GlyphPosition
lowerX of
Just GlyphPosition
lx -> GlyphPosition -> CFloat
glyphPosMaxY GlyphPosition
lx forall a. Num a => a -> a -> a
- GlyphPosition -> CFloat
glyphPosMinY GlyphPosition
lx
Maybe GlyphPosition
Nothing -> forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
asc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TextMetrics {
_txmAsc :: Double
_txmAsc = Double
asc,
_txmDesc :: Double
_txmDesc = Double
desc,
_txmLineH :: Double
_txmLineH = Double
lineh,
_txmLowerX :: Double
_txmLowerX = forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
heightLowerX
}
computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text =
Double -> Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize_ Double
1 Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text
computeTextSize_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize_ Double
scale Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
scale Font
font FontSize
fontSize FontSpace
fontSpaceH
(Double
x1, Double
y1, Double
x2, Double
y2) <- if Text
text forall a. Eq a => a -> a -> Bool
/= Text
""
then FMContext
-> Double -> Double -> Text -> IO (Double, Double, Double, Double)
fmTextBounds FMContext
ctx Double
0 Double
0 Text
text
else do
(Double
asc, Double
desc, Double
lineh) <- FMContext -> IO (Double, Double, Double)
fmTextMetrics FMContext
ctx
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
0, Double
0, Double
0, Double
lineh)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> Double -> Size
Size (forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
x2 forall a. Num a => a -> a -> a
- Double
x1)) (forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
y2 forall a. Num a => a -> a -> a
- Double
y1))
computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text =
Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos_ Double
1 Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text
computeGlyphsPos_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos_ Double
scale Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
scale Font
font FontSize
fontSize FontSpace
fontSpaceH
Seq GlyphPosition
glyphs <- if Text
text forall a. Eq a => a -> a -> Bool
/= Text
""
then FMContext -> Double -> Double -> Text -> IO (Seq GlyphPosition)
fmTextGlyphPositions FMContext
ctx Double
0 Double
0 Text
text
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Seq a
Seq.empty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Seq.zipWith Char -> GlyphPosition -> GlyphPos
toGlyphPos (forall a. [a] -> Seq a
Seq.fromList (Text -> [Char]
T.unpack Text
text)) Seq GlyphPosition
glyphs
where
toGlyphPos :: Char -> GlyphPosition -> GlyphPos
toGlyphPos Char
chr GlyphPosition
glyph = GlyphPos {
_glpGlyph :: Char
_glpGlyph = Char
chr,
_glpX :: Double
_glpX = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphX GlyphPosition
glyph),
_glpXMin :: Double
_glpXMin = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMinX GlyphPosition
glyph),
_glpXMax :: Double
_glpXMax = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMaxX GlyphPosition
glyph),
_glpYMin :: Double
_glpYMin = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMinY GlyphPosition
glyph),
_glpYMax :: Double
_glpYMax = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMaxY GlyphPosition
glyph),
_glpW :: Double
_glpW = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMaxX GlyphPosition
glyph forall a. Num a => a -> a -> a
- GlyphPosition -> CFloat
glyphPosMinX GlyphPosition
glyph),
_glpH :: Double
_glpH = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMaxY GlyphPosition
glyph forall a. Num a => a -> a -> a
- GlyphPosition -> CFloat
glyphPosMinY GlyphPosition
glyph)
}
loadFont :: FMContext -> [Text] -> FontDef -> IO [Text]
loadFont :: FMContext -> [Text] -> FontDef -> IO [Text]
loadFont FMContext
ctx [Text]
fonts FontDef
fontDef = do
Int
res <- FontDef -> IO Int
createFont FontDef
fontDef
if Int
res forall a. Ord a => a -> a -> Bool
>= Int
0
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
name forall a. a -> [a] -> [a]
: [Text]
fonts
else [Char] -> IO ()
putStrLnErr ([Char]
"Failed to load font: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
name) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
fonts
where
name :: Text
name = FontDef
fontDef forall s a. s -> Getting a s a -> a
^. forall s a. HasFontName s a => Lens' s a
fontName
createFont :: FontDef -> IO Int
createFont FontDefFile{} = FMContext -> Text -> Text -> IO Int
fmCreateFont FMContext
ctx Text
name (FontDef
fontDef forall s a. s -> Getting a s a -> a
^. forall s a. HasFontPath s a => Traversal' s a
fontPath)
createFont FontDefMem{} = FMContext -> Text -> ByteString -> IO Int
fmCreateFontMem FMContext
ctx Text
name (FontDef
fontDef forall s a. s -> Getting a s a -> a
^. forall s a. HasFontBytes s a => Traversal' s a
fontBytes)
setFont :: FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont :: FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
scale (Font Text
name) (FontSize Double
size) (FontSpace Double
spaceH) = do
FMContext -> Double -> IO ()
fmSetScale FMContext
ctx Double
scale
FMContext -> Text -> IO ()
fmFontFace FMContext
ctx Text
name
FMContext -> Double -> IO ()
fmFontSize FMContext
ctx forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
size
FMContext -> Double -> IO ()
fmTextLetterSpacing FMContext
ctx forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
spaceH