4 files changed, 66 insertions(+), 29 deletions(-)

M app/Main.hs
M src/Typograffiti/Atlas.hs
M src/Typograffiti/Store.hs
M src/Typograffiti/Text.hs

@@ 32,14 32,14 @@ main = do
     let text = pack $ case args of
           [] -> unlines [
             "Decoder Ring Theatre brings you the continuing adventures",
-            "of Canada's greatest superhero, that scourage of the underworld,",
+            "of Canada's greatest superhero, that scourge of the underworld,",
             "hunter of those who pray upon the innocent,",
             "that marvelous masked mystery man",
             "known only as The Red Panda!",
             "",
             "The Red Panda, masked crucader for justice, hides his secret identity",
             "as one of the city's wealthiest men in his neverending battle",
-            "against crime & corruption. Only his trust driver, Kit Baxter",
+            "against crime & corruption. Only his trusty driver, Kit Baxter",
             "who joins him in the guise of The Flying Squirrel,",
             "knows who wears the mask of The Red Panda!"]
           _ -> unwords args

@@ 67,13 67,15 @@ data Atlas = Atlas {
     -- ^ The texture holding the pre-rendered glyphs.
     atlasTextureSize :: V2 Int,
     -- ^ The size of the texture.
-    atlasMetrics :: IntMap GlyphMetrics
+    atlasMetrics :: IntMap GlyphMetrics,
     -- ^ Mapping from glyphs to their position in the texture.
+    atlasScale :: (Float, Float)
+    -- ^ Scaling factor for font-units given by Harfbuzz.
 } deriving (Show)
 
 -- | Initializes an empty atlas.
 emptyAtlas :: GLuint -> Atlas
-emptyAtlas t = Atlas t 0 mempty
+emptyAtlas t = Atlas t 0 mempty (0, 0)
 
 -- | Precomputed positioning of glyphs in an `Atlas` texture.
 data AtlasMeasure = AM {


@@ 165,8 167,8 @@ texturize cb xymap atlas@Atlas{..} glyph
 -- might need during the life of the 'Atlas'. Character texturization only
 -- happens once.
 allocAtlas :: (MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
-    GlyphRetriever m -> [Word32] -> m Atlas
-allocAtlas cb glyphs = do
+    GlyphRetriever m -> [Word32] -> (Float, Float) -> m Atlas
+allocAtlas cb glyphs scale = do
     AM {..} <- foldM (measure cb 512) emptyAM glyphs
     let V2 w h = amWH
         xymap = amMap


@@ 186,7 188,7 @@ allocAtlas cb glyphs = do
     glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR
     glBindTexture GL_TEXTURE_2D 0
     glPixelStorei GL_UNPACK_ALIGNMENT 4
-    return atlas { atlasTextureSize = V2 w h }
+    return atlas { atlasTextureSize = V2 w h, atlasScale = scale }
 
 -- | Releases all resources associated with the given 'Atlas'.
 freeAtlas :: MonadIO m => Atlas -> m ()


@@ 202,8 204,8 @@ makeCharQuad Atlas {..} (penx, peny, mLast) (GlyphInfo {codepoint=glyph}, GlyphP
     case IM.lookup iglyph atlasMetrics of
         Nothing -> throwError $ TypograffitiErrorNoMetricsForGlyph iglyph
         Just GlyphMetrics {..} -> do
-            let x = penx + f x_offset
-                y = peny + f y_offset
+            let x = penx + f x_offset*fst atlasScale
+                y = peny + f y_offset*snd atlasScale
                 V2 w h = f' <$> glyphSize
                 V2 aszW aszH = f' <$> atlasTextureSize
                 V2 texL texT = f' <$> fst glyphTexBB


@@ 214,11 216,11 @@ makeCharQuad Atlas {..} (penx, peny, mLast) (GlyphInfo {codepoint=glyph}, GlyphP
                 br = (V2 (x+w) y, V2 (texR/aszW) (texB/aszH))
                 bl = (V2 (x) y, V2 (texL/aszW) (texB/aszH))
 
-            return (penx + f x_advance/150, peny + f y_advance/150,
+            return (penx + f x_advance*fst atlasScale, peny + f y_advance*snd atlasScale,
                     UV.fromList [tl, tr, br, tl, br, bl] : mLast)
   where
     f :: Int32 -> Float
-    f = fromIntegral
+    f =  fromIntegral
     f' :: Int -> Float
     f' = fromIntegral
 

@@ 31,8 31,9 @@ import           Data.Text.Glyphize     (defaultBuffer, Buffer(..), shape,
                                         GlyphInfo(..), GlyphPos(..), FontOptions)
 import qualified Data.Text.Glyphize     as HB
 import qualified Data.Text.Lazy         as Txt
+import           Foreign.Storable       (peek)
 import           FreeType.Core.Base
-import           FreeType.Core.Types    (FT_Fixed)
+import           FreeType.Core.Types    (FT_Fixed, FT_UShort)
 import           FreeType.Format.Multiple (ft_Set_Var_Design_Coordinates)
 
 import           Typograffiti.Atlas


@@ 55,8 56,12 @@ data Font = Font {
     -- ^ Font as represented by Harfbuzz.
     freetype :: FT_Face,
     -- ^ Font as represented by FreeType.
-    atlases :: TMVar [(IS.IntSet, Atlas)]
+    atlases :: TMVar [(IS.IntSet, Atlas)],
     -- ^ Glyphs from the font rendered into GPU atleses.
+    lineHeight :: Float,
+    -- ^ Default lineheight for this font.
+    fontScale :: (Float, Float)
+    -- ^ Scaling parameters for Harfbuzz layout.
   }
 
 -- | Opens a font sized to given value & prepare to render text in it.


@@ 67,8 72,11 @@ makeDrawTextCached :: (MonadIO m, MonadFail m, MonadError TypograffitiError m,
     m (RichText -> n (AllocatedRendering [TextTransform]))
 makeDrawTextCached store filepath index fontsize SampleText {..} = do
     s <- liftIO $ atomically $ readTMVar $ fontMap store
-    font <- case M.lookup (filepath, fontsize, index, fontOptions) s of
-        Nothing -> allocFont store filepath index fontsize fontOptions
+    let fontOpts' = fontOptions {
+        HB.optionScale = Nothing, HB.optionPtEm = Nothing, HB.optionPPEm = Nothing
+      }
+    font <- case M.lookup (filepath, fontsize, index, fontOpts') s of
+        Nothing -> allocFont store filepath index fontsize fontOpts'
         Just font -> return font
 
     let glyphs = map (codepoint . fst) $


@@ 80,9 88,10 @@ makeDrawTextCached store filepath index fontsize SampleText {..} = do
     a <- liftIO $ atomically $ readTMVar $ atlases font
     atlas <- case [a' | (gs, a') <- a, glyphset `IS.isSubsetOf` gs] of
         (atlas:_) -> return atlas
-        _ -> allocAtlas' (atlases font) (freetype font) glyphset
+        _ -> allocAtlas' (atlases font) (freetype font) glyphset (fontScale font)
 
-    return $ drawLinesWrapper tabwidth minLineHeight $
+    let lh = if minLineHeight == 0 then lineHeight font else minLineHeight
+    return $ drawLinesWrapper tabwidth lh $
         \RichText {..} -> drawGlyphs store atlas $
             shape (harfbuzz font) defaultBuffer { HB.text = text } []
 


@@ 104,8 113,14 @@ allocFont FontStore {..} filepath index fontsize options = liftFreetype $ do
     let designCoords = map float2fixed $ HB.fontVarCoordsDesign font'
     unless (null designCoords) $ liftIO $ ft_Set_Var_Design_Coordinates font designCoords
 
+    font_ <- liftIO $ peek font
+    size <- srMetrics <$> liftIO (peek $ frSize font_)
+    let lineHeight = fixed2float $ smHeight size
+    let upem = short2float $ frUnits_per_EM font_
+    let scale = (short2float (smX_ppem size)/upem/2, short2float (smY_ppem size)/upem/2)
+
     atlases <- liftIO $ atomically $ newTMVar []
-    let ret = Font font' font atlases
+    let ret = Font font' font atlases lineHeight scale
 
     atomically $ do
         map <- takeTMVar fontMap


@@ 114,15 129,20 @@ allocFont FontStore {..} filepath index fontsize options = liftFreetype $ do
   where
     x2 = (*2)
     float2fixed :: Float -> FT_Fixed
-    float2fixed = toEnum . fromEnum . (*65536)
+    float2fixed = toEnum . fromEnum . (*bits16)
+    fixed2float :: FT_Fixed -> Float
+    fixed2float = (/bits16) . toEnum . fromEnum
+    bits16 = 2**16
+    short2float :: FT_UShort -> Float
+    short2float = toEnum . fromEnum
 
 -- | Allocates a new Atlas for the given font & glyphset,
 -- loading it into the atlas cache before returning.
 allocAtlas' :: (MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
-    TMVar [(IS.IntSet, Atlas)] -> FT_Face -> IS.IntSet -> m Atlas
-allocAtlas' atlases font glyphset = do
+    TMVar [(IS.IntSet, Atlas)] -> FT_Face -> IS.IntSet -> (Float, Float) -> m Atlas
+allocAtlas' atlases font glyphset scale = do
     let glyphs = map toEnum $ IS.toList glyphset
-    atlas <- allocAtlas (glyphRetriever font) glyphs
+    atlas <- allocAtlas (glyphRetriever font) glyphs scale
 
     liftIO $ atomically $ do
         a <- takeTMVar atlases

@@ 25,11 25,12 @@ import           Data.Text.Glyphize     (defaultBuffer, shape, GlyphInfo (..),
                                         FontOptions (..), defaultFontOptions)
 import qualified Data.Text.Glyphize     as HB
 import           FreeType.Core.Base
-import           FreeType.Core.Types    (FT_Fixed)
+import           FreeType.Core.Types    (FT_Fixed, FT_UShort)
 import           FreeType.Format.Multiple (ft_Set_Var_Design_Coordinates)
 import           Data.Text.Lazy         (Text, pack)
 import qualified Data.Text.Lazy         as Txt
 import           Data.Word              (Word32)
+import           Foreign.Storable       (peek)
 
 import           Typograffiti.Atlas
 import           Typograffiti.Cache


@@ 58,12 59,12 @@ data SampleText = SampleText {
     -- ^ Additional font options offered by Harfbuzz.
     minLineHeight :: Float
     -- ^ Number of pixels tall each line should be at minimum.
-    -- Defaults to 10px.
+    -- Defaults to 0 indicate to use the font's default lineheight.
 }
 
 -- | Constructs a `SampleText` with default values.
 defaultSample :: SampleText
-defaultSample = SampleText [] (pack $ map toEnum [32..126]) 4 defaultFontOptions 10
+defaultSample = SampleText [] (pack $ map toEnum [32..126]) 4 defaultFontOptions 0
 -- | Appends an OpenType feature callers may use to the `Sample` ensuring its
 -- glyphs are available. Call after setting `sampleText`.
 addSampleFeature :: String -> Word32 -> SampleText -> SampleText


@@ 133,8 134,17 @@ makeDrawText lib filepath index fontsize SampleText {..} = do
                                                     (floor $ 26.6 * 2 * h)
                                                     (toEnum dpix) (toEnum dpiy)
 
+    font_ <- liftIO $ peek font
+    size <- srMetrics <$> liftIO (peek $ frSize font_)
+    let lineHeight = if minLineHeight == 0 then fixed2float $ smHeight size else minLineHeight
+    let upem = short2float $ frUnits_per_EM font_
+    let scale = (short2float (smX_ppem size)/upem/2, short2float (smY_ppem size)/upem/2)
+
     bytes <- liftIO $ B.readFile filepath
-    let font' = HB.createFontWithOptions fontOptions $ HB.createFace bytes $ toEnum index
+    let fontOpts' = fontOptions {
+            HB.optionScale = Nothing, HB.optionPtEm = Nothing, HB.optionPPEm = Nothing
+      }
+    let font' = HB.createFontWithOptions fontOpts' $ HB.createFace bytes $ toEnum index
     let glyphs = map (codepoint . fst) $
             shape font' defaultBuffer {
                 HB.text = Txt.replicate (toEnum $ succ $ length sampleFeatures) sampleText


@@ 145,17 155,22 @@ makeDrawText lib filepath index fontsize SampleText {..} = do
     unless (null designCoords) $
         liftFreetype $ ft_Set_Var_Design_Coordinates font designCoords
 
-    atlas <- allocAtlas (glyphRetriever font) glyphs'
+    atlas <- allocAtlas (glyphRetriever font) glyphs' scale
     liftFreetype $ ft_Done_Face font
 
     drawGlyphs <- makeDrawGlyphs
-    return $ freeAtlasWrapper atlas $ drawLinesWrapper tabwidth minLineHeight
+    return $ freeAtlasWrapper atlas $ drawLinesWrapper tabwidth lineHeight
         $ \RichText {..} ->
             drawGlyphs atlas $ shape font' defaultBuffer { HB.text = text } features
   where
     x2 = (*2)
     float2fixed :: Float -> FT_Fixed
-    float2fixed = toEnum . fromEnum . (*65536)
+    float2fixed = toEnum . fromEnum . (*bits16)
+    fixed2float :: FT_Fixed -> Float
+    fixed2float = (/bits16) . toEnum . fromEnum
+    bits16 = 2**16
+    short2float :: FT_UShort -> Float
+    short2float = toEnum . fromEnum
 
 -- | Variant of `makeDrawText` which initializes FreeType itself.
 makeDrawText' a b c d =