View Issue Details

IDProjectCategoryView StatusLast Update
0037058LazarusLazUtilspublic2020-05-14 09:32
Reportercircular Assigned ToJuha Manninen  
PrioritynormalSeverityminorReproducibilityalways
Status resolvedResolutionfixed 
Product Version2.0.8 
Summary0037058: LazFreeType: add font kerning
DescriptionFont kerning consists in putting closer letters that fit together like AV.

Note that the format of FreeType has evolved with time, and the patch here is for the 'kern' table. Some fonts may not provide it and provide only the newer 'GPOS' table. This could be implemented in a future patch.

The patch also fixes some dynamic array out of bounds issues for the result of CharsWidth and CharsPosition. The result was initially sized using UTF8Length function but it might happen that the using UTF8CodepointToUnicode would give a different number of characters. Also the CharsWidth function was repeating the entries charlen times but that doesn't make sense as the array is not sized with the byte length but with UTF8Length. Hence calling the function with multibytes characters would cause a bound error. Those functions are tested as well by the test program (cf the colored lines).

This patch also fixes the size of TT_FWord which is supposed to be word-sized as its name suggests but was defined as Integer. Luckily, it has not been used directly for serialization so this change has no side effect as far as I can tell.
Steps To ReproduceApply the patch and run attached project to see the difference with/without kerning, and with/without kerning fallback.
Additional InformationTested with Liberation Sans, Liberation Serif, DejaVu Sans, Arial and Ubuntu.

FreeSans even though it has a 'kern' table seem to have no kerning, which is consistent with how it is displayed in LibreOffice.
TagsNo tags attached.
Fixed in Revisionr63145
LazTarget-
Widgetset
Attached Files

Activities

circular

2020-05-12 15:45

developer  

testfreetype4.zip (606,056 bytes)
kerning_test.png (37,686 bytes)   
kerning_test.png (37,686 bytes)   

circular

2020-05-12 15:55

developer   ~0122732

kerning.diff (25,067 bytes)   
Index: components/lazutils/easylazfreetype.pas
===================================================================
--- components/lazutils/easylazfreetype.pas	(révision 63135)
+++ components/lazutils/easylazfreetype.pas	(copie de travail)
@@ -6,16 +6,10 @@
   for details about the license.
  *****************************************************************************
 
-  Bug list :
-
- - Characters parts may not be well translated, for example i with accent.
- - Encoding is ok for ASCII but is mixed up for extended characters
-
  to do :
 
  - multiple font loading
  - font face cache
- - font style
  - text rotation
 }
 unit EasyLazFreeType;
@@ -57,6 +51,10 @@
 type
   TFreeTypeGlyph = class;
   TFreeTypeFont = class;
+  TFreeTypeKerning = record
+    Kerning, Minimum: TPointF;
+    Found: boolean;
+  end;
 
   EFreeType = class(Exception);
 
@@ -228,6 +226,7 @@
     FOwnedStream: boolean;
     FPointSize: single;
     FHinted: boolean;
+    FKerningEnabled, FKerningFallbackEnabled: boolean;
     FStyleStr: string;
     FWidthFactor: single;
     FClearType: boolean;
@@ -241,6 +240,8 @@
     function GetGlyph(Index: integer): TFreeTypeGlyph;
     function GetGlyphCount: integer;
     function GetInformation(AIndex: TFreeTypeInformation): string;
+    function GetGlyphKerning(AGlyphLeft, AGlyphRight: integer): TFreeTypeKerning;
+    function GetCharKerning(AUnicodeCharLeft, AUnicodeCharRight: integer): TFreeTypeKerning;
     function GetPixelSize: single;
     function GetVersionNumber: string;
     procedure SetDPI(const AValue: integer);
@@ -273,6 +274,7 @@
     FCharMap: TT_CharMap;
     FCharmapOk, FCharmapSymbol: boolean;
     FAscentValue, FDescentValue, FLineGapValue, FLargeLineGapValue, FCapHeight: single;
+    FUnitsPerEM: TT_UShort;
     procedure FaceChanged;
     function GetClearType: boolean; override;
     procedure SetClearType(const AValue: boolean); override;
@@ -312,8 +314,14 @@
     property CapHeight: single read GetCapHeight;
     property Glyph[Index: integer]: TFreeTypeGlyph read GetGlyph;
     property GlyphCount: integer read GetGlyphCount;
+    property CharKerning[AUnicodeCharLeft, AUnicodeCharRight: integer]: TFreeTypeKerning read GetCharKerning;
+    property GlyphKerning[AGlyphLeft, AGlyphRight: integer]: TFreeTypeKerning read GetGlyphKerning;
     property CharIndex[AUnicodeChar: integer]: integer read GetCharIndex;
     property Hinted: boolean read FHinted write SetHinted;
+    { Kerning brings closer certain letters that fit together }
+    property KerningEnabled: boolean read FKerningEnabled write FKerningEnabled;
+    { When enabled, if the kerning is not found between two letters, alternate codes are tried }
+    property KerningFallbackEnabled: boolean read FKerningFallbackEnabled write FKerningFallbackEnabled;
     property WidthFactor: single read FWidthFactor write SetWidthFactor;
     property LineFullHeight: single read GetLineFullHeight write SetLineFullHeight;
     property Information[AIndex: TFreeTypeInformation]: string read GetInformation;
@@ -1045,6 +1053,20 @@
 end;
 {$pop}
 
+function TFreeTypeFont.GetGlyphKerning(AGlyphLeft, AGlyphRight: integer): TFreeTypeKerning;
+var
+  kerningInfo: TT_KerningInfo;
+  factor: single;
+begin
+  kerningInfo := TT_Get_KerningInfo(FFace, AGlyphLeft, AGlyphRight);
+  factor := SizeInPixels/FUnitsPerEM;
+  result.Kerning.x := kerningInfo.kerning_x*factor;
+  result.Kerning.y := kerningInfo.kerning_y*factor;
+  result.Minimum.x := kerningInfo.minimum_x*factor;
+  result.Minimum.y := kerningInfo.minimum_y*factor;
+  result.Found := kerningInfo.found;
+end;
+
 function TFreeTypeFont.GetLineFullHeight: single;
 begin
   CheckInstance;
@@ -1263,6 +1285,7 @@
     FDescentValue := prop.horizontal^.descender;
     FLineGapValue:= prop.horizontal^.line_gap;
     FLargeLineGapValue:= FLineGapValue;
+    FUnitsPerEM := prop.header^.units_per_EM;
 
     if (FAscentValue = 0) and (FDescentValue = 0) then
     begin
@@ -1291,11 +1314,11 @@
                               else
                                   FCapHeight:=FAscentValue;
 
-    FAscentValue /= prop.header^.units_per_EM;
-    FDescentValue /= -prop.header^.units_per_EM;
-    FLineGapValue /= prop.header^.units_per_EM;
-    FLargeLineGapValue /= prop.header^.units_per_EM;
-    FCapHeight /= prop.header^.units_per_EM;
+    FAscentValue /= FUnitsPerEM;
+    FDescentValue /= -FUnitsPerEM;
+    FLineGapValue /= FUnitsPerEM;
+    FLargeLineGapValue /= FUnitsPerEM;
+    FCapHeight /= FUnitsPerEM;
 
     if FLargeLineGapValue = 0 then
       FLargeLineGapValue := (FAscentValue+FDescentValue)*0.1;
@@ -1306,6 +1329,7 @@
     FDescentValue := 0.5;
     FLineGapValue := 0;
     FLargeLineGapValue:= 0;
+    FUnitsPerEM   := 1;
   end;
 end;
 
@@ -1460,6 +1484,8 @@
   FGlyphTable := TAvlTree.Create;
   FGlyphTable.OnCompare := @GlyphTableOnCompare;
   FHinted := true;
+  FKerningEnabled:= true;
+  FKerningFallbackEnabled:= true;
   FWidthFactor := 1;
   FClearType := false;
   FStyleStr:= 'Regular';
@@ -1492,6 +1518,7 @@
   left,charcode,charlen: integer;
   idx: integer;
   g: TFreeTypeGlyph;
+  prevCharcode, glyphIndex: integer;
 begin
   if not CheckInstance then exit;
   if AText = '' then exit;
@@ -1508,15 +1535,19 @@
   RenderTextDecoration(AText,x,y,ARect,OnRender);
   pstr := @AText[1];
   left := length(AText);
+  prevCharcode := -1;
   while left > 0 do
   begin
     charcode := UTF8CodepointToUnicode(pstr, charlen);
     inc(pstr,charlen);
     dec(left,charlen);
-    g := Glyph[CharIndex[charcode]];
+    glyphIndex := CharIndex[charcode];
+    g := Glyph[glyphIndex];
     if g <> nil then
     with g do
     begin
+      if KerningEnabled and (prevCharcode <> -1) then
+        x += GetCharKerning(prevCharcode, charcode).Kerning.x;
       if Hinted then
        RenderDirectly(x,round(y),ARect,OnRender,quality,FClearType)
       else
@@ -1525,6 +1556,7 @@
         x += Advance/3
       else
         x += Advance;
+      prevCharcode := charcode;
     end;
   end;
 end;
@@ -1571,6 +1603,7 @@
   maxWidth,w: single;
   idx: integer;
   g: TFreeTypeGlyph;
+  prevCharcode, glyphIndex: integer;
 begin
   result := 0;
   if not CheckInstance then exit;
@@ -1593,19 +1626,24 @@
 
   pstr := @AText[1];
   left := length(AText);
+  prevCharcode := -1;
   while left > 0 do
   begin
     charcode := UTF8CodepointToUnicode(pstr, charlen);
     inc(pstr,charlen);
     dec(left,charlen);
-    g := Glyph[CharIndex[charcode]];
+    glyphIndex := CharIndex[charcode];
+    g := Glyph[glyphIndex];
     if g <> nil then
     with g do
     begin
+      if KerningEnabled and (prevCharcode <> -1) then
+        result += GetCharKerning(prevCharcode, charcode).Kerning.x;
       if FClearType then
         result += Advance/3
       else
         result += Advance;
+      prevCharcode := charcode;
     end;
   end;
   if maxWidth > result then
@@ -1656,8 +1694,10 @@
 var
   pstr: pchar;
   left,charcode,charlen: integer;
-  resultIndex,i: integer;
+  resultIndex: integer;
   w: single;
+  prevCharcode,glyphIndex: integer;
+  g: TFreeTypeGlyph;
 begin
   if AText = '' then
   begin
@@ -1668,6 +1708,7 @@
   left := length(AText);
   setlength(result, UTF8Length(AText));
   resultIndex := 0;
+  prevCharcode := -1;
   while left > 0 do
   begin
     charcode := UTF8CodepointToUnicode(pstr, charlen);
@@ -1674,20 +1715,27 @@
     inc(pstr,charlen);
     dec(left,charlen);
 
-    with Glyph[CharIndex[charcode]] do
+    glyphIndex := CharIndex[charcode];
+    g := Glyph[glyphIndex];
+    if g <> nil then
+    with g do
     begin
       if FClearType then
         w := Advance/3
       else
         w := Advance;
-    end;
+      if KerningEnabled and (prevCharcode <> -1) and (resultIndex > 0) then
+        result[resultIndex-1] += GetCharKerning(prevCharcode, charcode).Kerning.x;
+      prevCharcode := charcode;
+    end else
+      w := 0;
 
-    for i := 1 to charlen do
-    begin
-      result[resultIndex] := w;
-      inc(resultIndex);
-    end;
+    if resultIndex >= length(result) then
+      setlength(result, resultIndex+1);
+    result[resultIndex] := w;
+    inc(resultIndex);
   end;
+  setlength(result, resultIndex);
 end;
 
 function TFreeTypeFont.CharsPosition(AText: string): ArrayOfCharPosition;
@@ -1724,6 +1772,7 @@
   Found: boolean;
   StrLineEnding: string; // a string version of LineEnding, don't remove or else wont compile in UNIXes
   g: TFreeTypeGlyph;
+  prevCharcode, glyphIndex: integer;
 begin
   result := nil;
   if not CheckInstance then exit;
@@ -1746,6 +1795,7 @@
   yTopRel := -Ascent;
   yBottomRel := Descent;
   h := LineFullHeight;
+  prevCharcode := -1;
   while left > 0 do
   begin
     if (left > length(StrLineEnding)) and (pstr^ = StrLineEnding[1]) then
@@ -1777,6 +1827,7 @@
         y += h;
         curX := 0;
         resultLineStart := resultIndex;
+        prevCharcode := -1;
         if left <= 0 then break;
       end;
     end;
@@ -1783,7 +1834,8 @@
     charcode := UTF8CodepointToUnicode(pstr, charlen);
     inc(pstr,charlen);
     dec(left,charlen);
-    g := Glyph[CharIndex[charcode]];
+    glyphIndex := CharIndex[charcode];
+    g := Glyph[glyphIndex];
     if g <> nil then
     with g do
     begin
@@ -1791,8 +1843,13 @@
         w := Advance/3
       else
         w := Advance;
+      if KerningEnabled and (prevCharcode <> -1) then
+        curX += GetCharKerning(prevCharcode, charcode).Kerning.x;
+      prevCharcode := charcode
     end else
       w := 0;
+    if resultIndex >= length(result) then
+      setlength(result, resultIndex+1);
     with result[resultIndex] do
     begin
       x := curX;
@@ -1804,6 +1861,8 @@
     inc(resultIndex);
     curX += w;
   end;
+  if resultIndex >= length(result) then
+    setlength(result, resultIndex+1);
   with result[resultIndex] do
   begin
     x := curX;
@@ -1813,6 +1872,7 @@
     yBottom := y+yBottomRel;
   end;
   inc(resultIndex);
+  setlength(result, resultIndex);
   ApplyHorizAlign;
 
   if ftaBottom in AAlign then
@@ -1902,6 +1962,244 @@
   result := FFaceLoaded;
 end;
 
+function TFreeTypeFont.GetCharKerning(AUnicodeCharLeft, AUnicodeCharRight: integer): TFreeTypeKerning;
+const
+  UpperCaseKerningLeft = 'FPTVWY';
+  UpperCaseKerningRight = 'TVWY';
+  LowerCaseKerningLeftA = 'bcehmnops';
+  LowerCaseKerningRightA = 'cdegoqs';
+  LowerCaseKerningLeftU = 'gkqrvwxyz';
+  LowerCaseKerningRightU = 'mnprvwxyz';
+  LowerCaseKerningLeftACircumflex = 'ĉêôŝ';
+  LowerCaseKerningRightACircumflex = 'ĉêĝôŝ';
+  LowerCaseKerningLeftUCircumflex = 'ĝŵŷẑ';
+  LowerCaseKerningRightUCircumflex = 'ŵŷẑ';
+  LowerCaseKerningLeftADiaresis = 'ëö';
+  LowerCaseKerningRightADiaresis = 'ëö';
+  LowerCaseKerningLeftUDiaresis = 'ẅẍÿ';
+  LowerCaseKerningRightUDiaresis = 'ẅẍÿ';
+  LowerCaseKerningLeftAAcute = 'ćéḿńóṕś';
+  LowerCaseKerningRightAAcute = 'ćéǵóś';
+  LowerCaseKerningLeftUAcute = 'ǵŕẃýź';
+  LowerCaseKerningRightUAcute = 'ḿńṕŕẃýź';
+  LowerCaseKerningLeftAGrave = 'èǹò';
+  LowerCaseKerningRightAGrave = 'èò';
+  LowerCaseKerningLeftUGrave = 'ẁỳ';
+  LowerCaseKerningRightUGrave = 'ǹẁỳ';
+type
+  TKerningFallbackInfo = record
+    u: integer;      //composed charcode
+    fb: integer;     //fallback code
+  end;
+const
+  KerningFallbackInfo : array[0..195] of TKerningFallbackInfo = (
+  (u:$C0; fb:$41), (u:$C1; fb:$41), (u:$C2; fb:$41), (u:$C3; fb:$41), (u:$C4; fb:$41),
+  (u:$C5; fb:$41), (u:$C7; fb:$43), (u:$C8; fb:$45), (u:$C9; fb:$45), (u:$CA; fb:$45),
+  (u:$CB; fb:$45), (u:$CC; fb:$49), (u:$CD; fb:$49), (u:$CE; fb:$49), (u:$CF; fb:$49),
+  (u:$D1; fb:$4E), (u:$D2; fb:$4F), (u:$D3; fb:$4F), (u:$D4; fb:$4F), (u:$D5; fb:$4F),
+  (u:$D6; fb:$4F), (u:$D9; fb:$55), (u:$DA; fb:$55), (u:$DB; fb:$55), (u:$DC; fb:$55),
+  (u:$DD; fb:$59), (u:$100; fb:$41), (u:$102; fb:$41), (u:$104; fb:$41),
+  (u:$106; fb:$43), (u:$108; fb:$43), (u:$10A; fb:$43), (u:$10C; fb:$43),
+  (u:$10E; fb:$44), (u:$112; fb:$45), (u:$114; fb:$45), (u:$116; fb:$45),
+  (u:$118; fb:$45), (u:$11A; fb:$45), (u:$11C; fb:$47), (u:$11E; fb:$47),
+  (u:$120; fb:$47), (u:$122; fb:$47), (u:$124; fb:$48), (u:$128; fb:$49),
+  (u:$12A; fb:$49), (u:$12C; fb:$49), (u:$12E; fb:$49), (u:$130; fb:$49),
+  (u:$134; fb:$4A), (u:$136; fb:$4B), (u:$139; fb:$4C), (u:$13B; fb:$4C),
+  (u:$13D; fb:$4C), (u:$143; fb:$4E), (u:$145; fb:$4E), (u:$147; fb:$4E),
+  (u:$14C; fb:$4F), (u:$14E; fb:$4F), (u:$150; fb:$4F), (u:$154; fb:$52),
+  (u:$156; fb:$52), (u:$158; fb:$52), (u:$15A; fb:$53), (u:$15C; fb:$53),
+  (u:$15E; fb:$53), (u:$160; fb:$53), (u:$162; fb:$54), (u:$164; fb:$54),
+  (u:$168; fb:$55), (u:$16A; fb:$55), (u:$16C; fb:$55), (u:$16E; fb:$55),
+  (u:$170; fb:$55), (u:$172; fb:$55), (u:$174; fb:$57), (u:$176; fb:$59),
+  (u:$178; fb:$59), (u:$179; fb:$5A), (u:$17B; fb:$5A), (u:$17D; fb:$5A),
+  (u:$1CD; fb:$41), (u:$1CF; fb:$49), (u:$1D1; fb:$4F), (u:$1D3; fb:$55),
+  (u:$1E2; fb:$C6), (u:$1E6; fb:$47), (u:$1E8; fb:$4B), (u:$1EA; fb:$4F),
+  (u:$1F4; fb:$47), (u:$1F8; fb:$4E), (u:$1FC; fb:$C6), (u:$200; fb:$41),
+  (u:$202; fb:$41), (u:$204; fb:$45), (u:$206; fb:$45), (u:$208; fb:$49),
+  (u:$20A; fb:$49), (u:$20C; fb:$4F), (u:$20E; fb:$4F), (u:$210; fb:$52),
+  (u:$212; fb:$52), (u:$214; fb:$55), (u:$216; fb:$55), (u:$218; fb:$53),
+  (u:$21A; fb:$54), (u:$21E; fb:$48), (u:$226; fb:$41), (u:$228; fb:$45),
+  (u:$22E; fb:$4F), (u:$232; fb:$59), (u:$38F; fb:$3A9), (u:$403; fb:$413),
+  (u:$476; fb:$474), (u:$4EA; fb:$4E8), (u:$1E00; fb:$41), (u:$1E02; fb:$42),
+  (u:$1E04; fb:$42), (u:$1E06; fb:$42), (u:$1E08; fb:$C7), (u:$1E0A; fb:$44),
+  (u:$1E0C; fb:$44), (u:$1E0E; fb:$44), (u:$1E10; fb:$44), (u:$1E12; fb:$44),
+  (u:$1E18; fb:$45), (u:$1E1A; fb:$45), (u:$1E1E; fb:$46), (u:$1E20; fb:$47),
+  (u:$1E22; fb:$48), (u:$1E24; fb:$48), (u:$1E26; fb:$48), (u:$1E28; fb:$48),
+  (u:$1E2A; fb:$48), (u:$1E2C; fb:$49), (u:$1E30; fb:$4B), (u:$1E32; fb:$4B),
+  (u:$1E34; fb:$4B), (u:$1E36; fb:$4C), (u:$1E3A; fb:$4C), (u:$1E3C; fb:$4C),
+  (u:$1E3E; fb:$4D), (u:$1E40; fb:$4D), (u:$1E42; fb:$4D), (u:$1E44; fb:$4E),
+  (u:$1E46; fb:$4E), (u:$1E48; fb:$4E), (u:$1E4A; fb:$4E), (u:$1E54; fb:$50),
+  (u:$1E56; fb:$50), (u:$1E58; fb:$52), (u:$1E5A; fb:$52), (u:$1E5E; fb:$52),
+  (u:$1E60; fb:$53), (u:$1E62; fb:$53), (u:$1E6A; fb:$54), (u:$1E6C; fb:$54),
+  (u:$1E6E; fb:$54), (u:$1E70; fb:$54), (u:$1E72; fb:$55), (u:$1E74; fb:$55),
+  (u:$1E76; fb:$55), (u:$1E7C; fb:$56), (u:$1E7E; fb:$56), (u:$1E80; fb:$57),
+  (u:$1E82; fb:$57), (u:$1E84; fb:$57), (u:$1E86; fb:$57), (u:$1E88; fb:$57),
+  (u:$1E8A; fb:$58), (u:$1E8C; fb:$58), (u:$1E8E; fb:$59), (u:$1E90; fb:$5A),
+  (u:$1E92; fb:$5A), (u:$1E94; fb:$5A), (u:$1EA0; fb:$41), (u:$1EA2; fb:$41),
+  (u:$1EB8; fb:$45), (u:$1EBA; fb:$45), (u:$1EBC; fb:$45), (u:$1EC8; fb:$49),
+  (u:$1ECA; fb:$49), (u:$1ECC; fb:$4F), (u:$1ECE; fb:$4F), (u:$1EE4; fb:$55),
+  (u:$1EE6; fb:$55), (u:$1EF2; fb:$59), (u:$1EF4; fb:$59), (u:$1EF6; fb:$59),
+  (u:$1EF8; fb:$59), (u:$1F68; fb:$3A9), (u:$1F69; fb:$3A9), (u:$1FFA; fb:$3A9),
+  (u:$1FFC; fb:$3A9), (u:$2126; fb:$3A9), (u:$212A; fb:$4B));
+
+  function FindFallback(var ACode: integer): boolean;
+  var
+    minIdx, maxIdx, midIdx: Integer;
+  begin
+    minIdx := low(KerningFallbackInfo);
+    maxIdx := high(KerningFallbackInfo);
+    while minIdx < maxIdx do
+    begin
+      midIdx := (minIdx+maxIdx) shr 1;
+      if ACode > KerningFallbackInfo[midIdx].u then
+        minIdx := midIdx+1
+      else
+        maxIdx := midIdx;
+    end;
+    if KerningFallbackInfo[minIdx].u = ACode then
+    begin
+      ACode := KerningFallbackInfo[minIdx].fb;
+      if ACode = $C7 {C WITH CEDILLA} then ACode := ord('C');
+      result := true;
+    end
+    else result := false;
+  end;
+var
+  glyphLeft, glyphRight: integer;
+  isFallback: Boolean;
+  leftUTF8, rightUTF8: String;
+begin
+  glyphLeft := CharIndex[AUnicodeCharLeft];
+  glyphRight := CharIndex[AUnicodeCharRight];
+  result := GetGlyphKerning(glyphLeft, glyphRight);
+  if not result.Found and KerningFallbackEnabled then
+  begin
+    //try to find glyphs without accents
+    isFallback := false;
+    if FindFallback(AUnicodeCharLeft) then
+    begin
+      glyphLeft := CharIndex[AUnicodeCharLeft];
+      isFallback := true;
+    end;
+    if FindFallback(AUnicodeCharRight) then
+    begin
+      glyphRight := CharIndex[AUnicodeCharRight];
+      isFallback := true;
+    end;
+    if isFallback then
+    begin
+      result := GetGlyphKerning(glyphLeft, glyphRight);
+      if result.Found then exit;
+    end;
+
+    //try to find equivalence for kernings that were not forseen by the font (ex: AE, Vs)
+    if AUnicodeCharRight = $C6 {AE} then
+    begin
+      AUnicodeCharRight := ord('A');
+      glyphRight := CharIndex[AUnicodeCharRight];
+      result := GetGlyphKerning(glyphLeft, glyphRight);
+      if result.Found then exit;
+    end else
+    if AUnicodeCharRight = $152 {OE} then
+    begin
+      AUnicodeCharRight := ord('O');
+      glyphRight := CharIndex[AUnicodeCharRight];
+      result := GetGlyphKerning(glyphLeft, glyphRight);
+      if result.Found then exit;
+    end;
+
+    if (AUnicodeCharLeft < 128) and (AUnicodeCharRight < 128) then
+    begin
+      if (pos(chr(AUnicodeCharLeft), UpperCaseKerningLeft) <> 0) and
+         (pos(chr(AUnicodeCharRight), LowerCaseKerningRightA) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, ord('a')));
+
+      if (pos(chr(AUnicodeCharLeft), LowerCaseKerningLeftA) <> 0) and
+         (pos(chr(AUnicodeCharRight), UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning(ord('a'), AUnicodeCharRight));
+
+      if (pos(chr(AUnicodeCharLeft), UpperCaseKerningLeft) <> 0) and
+         (pos(chr(AUnicodeCharRight), LowerCaseKerningRightU) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, ord('u')));
+
+      if (pos(chr(AUnicodeCharLeft), LowerCaseKerningLeftU) <> 0) and
+         (pos(chr(AUnicodeCharRight), UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning(ord('u'), AUnicodeCharRight));
+    end else
+    begin
+      leftUTF8 := UnicodeToUTF8(AUnicodeCharLeft);
+      rightUTF8 := UnicodeToUTF8(AUnicodeCharRight);
+
+      if (pos(leftUTF8, UpperCaseKerningLeft) <> 0) and
+         (pos(rightUTF8, LowerCaseKerningRightACircumflex) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, $E2));
+
+      if (pos(leftUTF8, LowerCaseKerningLeftACircumflex) <> 0) and
+         (pos(rightUTF8, UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning($E2, AUnicodeCharRight));
+
+      if (pos(leftUTF8, UpperCaseKerningLeft) <> 0) and
+         (pos(rightUTF8, LowerCaseKerningRightUCircumflex) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, $FB));
+
+      if (pos(leftUTF8, LowerCaseKerningLeftUCircumflex) <> 0) and
+         (pos(rightUTF8, UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning($FB, AUnicodeCharRight));
+
+
+      if (pos(leftUTF8, UpperCaseKerningLeft) <> 0) and
+         (pos(rightUTF8, LowerCaseKerningRightADiaresis) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, $E4));
+
+      if (pos(leftUTF8, LowerCaseKerningLeftADiaresis) <> 0) and
+         (pos(rightUTF8, UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning($E4, AUnicodeCharRight));
+
+      if (pos(leftUTF8, UpperCaseKerningLeft) <> 0) and
+         (pos(rightUTF8, LowerCaseKerningRightUDiaresis) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, $FC));
+
+      if (pos(leftUTF8, LowerCaseKerningLeftUDiaresis) <> 0) and
+         (pos(rightUTF8, UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning($FC, AUnicodeCharRight));
+
+
+      if (pos(leftUTF8, UpperCaseKerningLeft) <> 0) and
+         (pos(rightUTF8, LowerCaseKerningRightAAcute) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, $E1));
+
+      if (pos(leftUTF8, LowerCaseKerningLeftAAcute) <> 0) and
+         (pos(rightUTF8, UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning($E1, AUnicodeCharRight));
+
+      if (pos(leftUTF8, UpperCaseKerningLeft) <> 0) and
+         (pos(rightUTF8, LowerCaseKerningRightUAcute) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, $FA));
+
+      if (pos(leftUTF8, LowerCaseKerningLeftUAcute) <> 0) and
+         (pos(rightUTF8, UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning($FA, AUnicodeCharRight));
+
+
+      if (pos(leftUTF8, UpperCaseKerningLeft) <> 0) and
+         (pos(rightUTF8, LowerCaseKerningRightAGrave) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, $E0));
+
+      if (pos(leftUTF8, LowerCaseKerningLeftAGrave) <> 0) and
+         (pos(rightUTF8, UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning($E0, AUnicodeCharRight));
+
+      if (pos(leftUTF8, UpperCaseKerningLeft) <> 0) and
+         (pos(rightUTF8, LowerCaseKerningRightUGrave) <> 0) then
+         exit(GetCharKerning(AUnicodeCharLeft, $F9));
+
+      if (pos(leftUTF8, LowerCaseKerningLeftUGrave) <> 0) and
+         (pos(rightUTF8, UpperCaseKerningRight) <> 0) then
+         exit(GetCharKerning($F9, AUnicodeCharRight));
+    end;
+  end;
+end;
+
 function TFreeTypeFont.CheckInstance: boolean;
 begin
   result := CheckFace and FInstanceCreated;
Index: components/lazutils/lazfreetype.pas
===================================================================
--- components/lazutils/lazfreetype.pas	(révision 63135)
+++ components/lazutils/lazfreetype.pas	(copie de travail)
@@ -351,6 +351,12 @@
                                 nbPhantomPoints : integer = 0 ) : TT_Error;
 
   (*****************************************************************)
+  (*  Get the kerning between two glyph                            *)
+  (*                                                               *)
+  function TT_Get_KerningInfo( _Face: TT_Face;
+                           glyph_left, glyph_right: Word) : TT_KerningInfo;
+
+  (*****************************************************************)
   (*  Create a new glyph outline                                   *)
   (*                                                               *)
   function TT_New_Outline( n_points   : integer;
@@ -467,6 +473,7 @@
   TTObjs,
   TTLoad,
   TTGLoad,
+  TTKern,
   TTRaster;
 
   (*****************************************************************)
@@ -1382,8 +1389,25 @@
   end;
 
   (*****************************************************************)
+  (*  Get the kerning between two glyph                            *)
   (*                                                               *)
+  function TT_Get_KerningInfo( _Face: TT_Face;
+                           glyph_left, glyph_right: Word) : TT_KerningInfo;
+  var
+    p: PFace;
+  begin
+    p := PFace(_Face.z);
+    if p^.kernings = nil then
+    begin
+      p^.kernings := TKerningTables.Create;
+      LoadKerningTables(p, TKerningTables(p^.kernings));
+    end;
+    result := TKerningTables(p^.kernings).GetKerning(glyph_left, glyph_right);
+  end;
+
+  (*****************************************************************)
   (*                                                               *)
+  (*                                                               *)
   function TT_Translate_Outline( var out : TT_Outline;
                                  x, y    : TT_F26Dot6 ) : TT_Error;
   var
Index: components/lazutils/ttobjs.pas
===================================================================
--- components/lazutils/ttobjs.pas	(révision 63135)
+++ components/lazutils/ttobjs.pas	(copie de travail)
@@ -481,6 +481,7 @@
 
             instances : TCache;
             glyphs    : TCache;
+            kernings  : TObject;
             (* various caches for this face's child objects *)
 
             extension : Pointer;
@@ -1755,6 +1756,8 @@
 
     Cache_Destroy( face^.instances );
     Cache_Destroy( face^.glyphs    );
+    face^.kernings.Free;
+    face^.kernings := nil;
 
     (* freeing the tables directory *)
     Free( face^.dirTables );
Index: components/lazutils/tttypes.pas
===================================================================
--- components/lazutils/tttypes.pas	(révision 63135)
+++ components/lazutils/tttypes.pas	(copie de travail)
@@ -36,7 +36,7 @@
 
   TT_Fixed  = LongInt;  (* Signed Fixed 16.16 Float *)
 
-  TT_FWord  = Integer;  (* Distance in FUnits *)
+  TT_FWord  = SmallInt; (* Distance in FUnits *)
   TT_UFWord = Word;     (* Unsigned Distance  *)
 
   TT_F2Dot14 = Integer; (* signed fixed float 2.14 used for *)
@@ -97,6 +97,15 @@
   end;
 
   (******************************************************)
+  (*  kerning info between two glyphs                   *)
+  (*                                                    *)
+  TT_KerningInfo = record
+    kerning_x, kerning_y: TT_FWord;
+    minimum_x, minimum_y: TT_FWord;
+    found: boolean;
+  end;
+
+  (******************************************************)
   (*  the engine's error condition type - 0 always      *)
   (*  means success.                                    *)
   (*                                                    *)
kerning.diff (25,067 bytes)   

Juha Manninen

2020-05-12 20:38

developer   ~0122740

Last edited: 2020-05-12 20:45

View 2 revisions

It appears a new unit TTKern is missing.
IMO the FreeType stuff would deserve its own package. It is expanding and has many units already. It has only few dependencies.
The LazUtils package also has expanded for various reasons.

circular

2020-05-13 07:34

developer   ~0122754

Ah yes, indeed. Here is the missing unit.

About making a separate package, well, why not.
ttkern.pas (8,377 bytes)   
unit TTKern;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, EasyLazFreeType, TTTypes, TTFile, TTObjs, fgl;

type
  { TCustomKerningTable }

  TCustomKerningTable = class
  private
    function GetIsCrossStream: boolean;
    function GetIsHorizontal: boolean;
    function GetIsMinimum: boolean;
    function GetIsOverride: boolean;
  protected
    FCoverage: UShort;
  public
    constructor Create(ACoverage: UShort);
    procedure LoadFromStream(AStream: TFreeTypeStream; ASize: UShort); virtual; abstract;
    property IsMinimum: boolean read GetIsMinimum;
    property IsHorizontal: boolean read GetIsHorizontal;
    property IsCrossStream: boolean read GetIsCrossStream;
    property IsOverride: boolean read GetIsOverride;
    function GetKerning(ALeftGlyph, ARightGlyph: UShort; var AInfo: TT_KerningInfo): boolean; virtual; abstract;
  end;

  { TKerningTables }

  TKerningTables = class(specialize TFPGObjectList<TCustomKerningTable>)
    function GetKerning(ALeftGlyph, ARightGlyph: UShort): TT_KerningInfo;
  end;

procedure LoadKerningTables(AFace: PFace; AKerningTables: TKerningTables);

implementation

uses
  TTLoad;

const
  COVERAGE_HORIZONTAL = 1;
  COVERAGE_MINIMUM = 2;
  COVERAGE_CROSS_STREAM = 4;
  COVERAGE_OVERRIDE = 8;
  SUBTABLE_FORMAT_BINARY_SEARCH = 0;
  SUBTABLE_FORMAT_TWO_DIMENSIONAL = 2;

type
  TKerningPair = record
    leftGlyph, rightGlyph: UShort;
    value: TT_FWord;
  end;

operator <(const APair1, APair2: TKerningPair): boolean;
begin
  result := (APair1.leftGlyph < APair2.leftGlyph) or
            ((APair1.leftGlyph = APair2.leftGlyph) and
             (APair1.rightGlyph < APair2.rightGlyph));
end;

type
  { TBinarySearchKerningTable }

  TBinarySearchKerningTable = class(TCustomKerningTable)
    nPairs, searchRange, entrySelector, rangeShift: UShort;
    pairs: array of TKerningPair;
    procedure SortPairs;
    procedure LoadFromStream(AStream: TFreeTypeStream; ASize: UShort); override;
    function GetKerning(ALeftGlyph, ARightGlyph: UShort; var AInfo: TT_KerningInfo): boolean; override;
  end;

{ TKerningTables }

function TKerningTables.GetKerning(ALeftGlyph, ARightGlyph: UShort): TT_KerningInfo;
var
  i: Integer;
  found: Boolean;
begin
  result.kerning_x:= 0;
  result.kerning_y:= 0;
  result.minimum_x:= -32767;
  result.minimum_y:= -32767;
  result.found := false;
  for i := 0 to Count-1 do
    if Items[I].GetKerning(ALeftGlyph, ARightGlyph, result) then
      result.found := true;
end;

{ TBinarySearchKerningTable }

procedure TBinarySearchKerningTable.SortPairs;
var
  i,j,k: UShort;
  temp: TKerningPair;
begin
  if nPairs > 0 then
  for i := 1 to nPairs-1 do
  begin
    j := i;
    while (j > 0) and (pairs[i] < pairs[j-1]) do dec(j);
    if j < i then
    begin
      temp := pairs[i];
      for k := i downto j+1 do
       pairs[k] := pairs[k-1];
      pairs[j] := temp;
    end;
  end;
end;

procedure TBinarySearchKerningTable.LoadFromStream(AStream: TFreeTypeStream;
  ASize: UShort);
var
  endPosition: LongInt;
  i: UShort;
begin
  if ASize <= 8 then
  begin
    nPairs := 0;
    searchRange := 0;
    entrySelector:= 0;
    rangeShift:= 0;
  end else
  begin
    endPosition := AStream.Position + ASize;
    nPairs := AStream.GET_UShort;
    searchRange := AStream.GET_UShort;
    entrySelector := AStream.GET_UShort;
    rangeShift := AStream.GET_UShort;
    if nPairs > 0 then
    begin
      setlength(pairs, nPairs);
      for i := 0 to nPairs-1 do
        if AStream.Position + 6 > endPosition then
        begin
          nPairs := i;
          setlength(pairs, nPairs);
          break;
        end else
        begin
          pairs[i].leftGlyph:= AStream.GET_UShort;
          pairs[i].rightGlyph:= AStream.GET_UShort;
          pairs[i].value:= AStream.GET_Short;
        end;
      SortPairs;
    end;
  end;
end;

function TBinarySearchKerningTable.GetKerning(ALeftGlyph, ARightGlyph: UShort; var AInfo: TT_KerningInfo): boolean;
var
  maxIndex, minIndex, midIndex: integer;
  searchedPair: TKerningPair;

  function ClampShort(AValue, AMin, AMax: integer): integer;
  begin
    if AValue < AMin then result := AMin else
    if AValue > AMax then result := AMax else
      result := AValue;
  end;

begin
  searchedPair.leftGlyph:= ALeftGlyph;
  searchedPair.rightGlyph:= ARightGlyph;
  minIndex := 0;
  maxIndex := nPairs-1;
  while minIndex < maxIndex do
  begin
    midIndex := (minIndex+maxIndex+1) shr 1;
    if searchedPair < pairs[midIndex] then
      maxIndex := midIndex-1
    else
      minIndex := midIndex;
  end;
  searchedPair := pairs[minIndex];
  if (searchedPair.leftGlyph = ALeftGlyph) and
     (searchedPair.rightGlyph = ARightGlyph) then
  begin
    if IsCrossStream then
    begin
      if IsMinimum then
      begin
        if IsOverride then
          AInfo.minimum_y:= searchedPair.value
        else
          AInfo.minimum_y:= ClampShort(AInfo.minimum_y + searchedPair.value, -32768, 32767);
      end else
      begin
        if IsOverride then
          AInfo.kerning_y:= searchedPair.value
        else
          AInfo.kerning_y:= ClampShort(AInfo.kerning_y + searchedPair.value, AInfo.minimum_y, 32767);
      end;
    end else
    begin
      if IsMinimum then
      begin
        if IsOverride then
          AInfo.minimum_x:= searchedPair.value
        else
          AInfo.minimum_x:= ClampShort(AInfo.minimum_x + searchedPair.value, -32768, 32767);
      end else
      begin
        if IsOverride then
          AInfo.kerning_x:= searchedPair.value
        else
          AInfo.kerning_x:= ClampShort(AInfo.kerning_x + searchedPair.value, AInfo.minimum_y, 32767);
      end;
    end;
    result := true;
  end else
    result := false;
end;

{ TCustomKerningTable }

function TCustomKerningTable.GetIsCrossStream: boolean;
begin
  result := (FCoverage and COVERAGE_CROSS_STREAM) <> 0;
end;

function TCustomKerningTable.GetIsHorizontal: boolean;
begin
  result := (FCoverage and COVERAGE_HORIZONTAL) <> 0;
end;

function TCustomKerningTable.GetIsMinimum: boolean;
begin
  result := (FCoverage and COVERAGE_MINIMUM) <> 0;
end;

function TCustomKerningTable.GetIsOverride: boolean;
begin
  result := (FCoverage and COVERAGE_OVERRIDE) <> 0;
end;

constructor TCustomKerningTable.Create(ACoverage: UShort);
begin
  FCoverage:= ACoverage;
end;

procedure LoadKerningTables(AFace: PFace; AKerningTables: TKerningTables);
var
  kernTableIndex: Int;
  substream: TFreeTypeStream;
  kernTableOffset: Long;

  procedure ParseKernTable;
  var version, nTables, byteSize, coverage: UShort;
    i: UShort;
    subtableFormat: byte;
    nextTablePos: Longint;
    newTable: TCustomKerningTable;
  begin
    if substream.SeekFile(kernTableOffset) <> Success then exit;
    if substream.AccessFrame(4) <> Success then exit;
    try
      version := substream.GET_UShort;
      nTables := substream.GET_UShort;
    finally
      substream.ForgetFrame;
    end;
    if (version <> 0) or (nTables = 0) then exit;
    for i := 0 to nTables-1 do
    begin
      if substream.AccessFrame(6) <> Success then exit;
      try
        version := substream.GET_UShort;
        byteSize:= substream.GET_UShort;
        coverage:= substream.GET_UShort;
      finally
        substream.ForgetFrame;
      end;
      subtableFormat := coverage shr 8;
      nextTablePos:= substream.Position + byteSize;
      if (version = 0) or (coverage AND COVERAGE_HORIZONTAL = 0) then
      begin
        newTable := nil;
        case subtableFormat of
        SUBTABLE_FORMAT_BINARY_SEARCH: newTable := TBinarySearchKerningTable.Create(coverage);
        end;
        if Assigned(newTable) then
        begin
          if substream.AccessFrame(byteSize) = Success then
          begin
            try
              newTable.LoadFromStream(substream, byteSize);
              AKerningTables.Add(newTable);
              newTable := nil;
            finally
              substream.ForgetFrame;
            end;
          end;
        end;
        newTable.Free;
      end;
      substream.SeekFile(nextTablePos)
    end;
  end;

begin
  kernTableIndex:= LookUp_TrueType_Table(AFace, 'kern');
  if kernTableIndex >= 0 then
  begin
    kernTableOffset:= AFace^.dirTables^[kernTableIndex].Offset;
    if TT_Use_Stream(AFace^.stream, substream) = Success then
      try
        ParseKernTable;
      finally
        TT_Done_Stream( AFace^.stream );
      end;
  end;
end;

end.

ttkern.pas (8,377 bytes)   

Juha Manninen

2020-05-13 23:06

developer   ~0122772

Thanks. I applied it. Please test everybody.

circular

2020-05-14 09:32

developer   ~0122783

Hmm I think we need to add ttkern.pas to the LazUtils package as well. So that if the file is changed, it will be recompiled.

Issue History

Date Modified Username Field Change
2020-05-12 15:45 circular New Issue
2020-05-12 15:45 circular File Added: kerning.diff
2020-05-12 15:45 circular File Added: testfreetype4.zip
2020-05-12 15:45 circular File Added: kerning_test.png
2020-05-12 15:49 circular File Deleted: kerning.diff
2020-05-12 15:55 circular Note Added: 0122732
2020-05-12 15:55 circular File Added: kerning.diff
2020-05-12 20:20 Juha Manninen Assigned To => Juha Manninen
2020-05-12 20:20 Juha Manninen Status new => assigned
2020-05-12 20:38 Juha Manninen Status assigned => feedback
2020-05-12 20:38 Juha Manninen LazTarget => -
2020-05-12 20:38 Juha Manninen Note Added: 0122740
2020-05-12 20:45 Juha Manninen Note Edited: 0122740 View Revisions
2020-05-13 07:34 circular Note Added: 0122754
2020-05-13 07:34 circular File Added: ttkern.pas
2020-05-13 07:34 circular Status feedback => assigned
2020-05-13 23:06 Juha Manninen Status assigned => resolved
2020-05-13 23:06 Juha Manninen Resolution open => fixed
2020-05-13 23:06 Juha Manninen Fixed in Revision => r63145
2020-05-13 23:06 Juha Manninen Note Added: 0122772
2020-05-14 09:32 circular Note Added: 0122783