freetype: include bearings and invisible characters into text bounds

git-svn-id: trunk@49629 -

packages/fcl-image/examples/textout.pp

@@ -3,10 +3,7 @@
 program textout;
 
 uses
-  {$IFDEF UNIX}cwstring, {$ENDIF} classes, sysutils, FPImage, FPCanvas, FPImgCanv, ftFont, FPWritePNG, freetype;
+  {$IFDEF UNIX}cwstring, {$ENDIF} classes, sysutils, Types, FPImage, FPCanvas, FPImgCanv, ftFont, FPWritePNG, freetype;
-
-const
-  MyColor : TFPColor = (Red: $7FFF; Green: $0000; Blue: $FFFF; Alpha: alphaOpaque);
 
 procedure DoDraw(FN, fnChinese : String);
 
@@ -17,6 +14,7 @@ var
   f : TFreeTypeFont;
   S : String;
   U : UnicodeString;
+  p : TSize;
 
 begin
   f:=Nil;
@@ -48,13 +46,22 @@ begin
       Font.Name:=FN;
       Font.Size:=14;
       Font.FPColor:=colBlack;
+      brush.style:=bsClear;
+      pen.FPColor:=colRed;
       S:='Hello, world!';
       Canvas.TextOut(20,20,S);
       F.Size := 14.5;
       Canvas.TextOut(20,30,S);
-      U:=UTF8Decode('привет, Мир!');
+      F.Angle := -45*2*3.14/360;
+      Canvas.TextOut(160,30,S);
+      p := Canvas.TextExtent(S);
+      Canvas.Rectangle(160,30,160+p.Width-1,30+p.Height-1); // the rectangle is misplaced in the y-direction but that is by design
+      F.Angle := 0;
+      U:=UTF8Decode('привет, Мир!a');
       Font.FPColor:=colBlue;
-      Canvas.TextOut(50,50,U);
+      Canvas.TextOut(30,50,U);
+      p := Canvas.TextExtent(U);
+      Canvas.Rectangle(30,50,30+p.Width-1,50-p.Height+1); // the rectangle is misplaced in the y-direction but that is by design
       if (FNChinese<>'') then
         begin
         Font.Name:=FNChinese;
@@ -82,13 +89,14 @@ begin
 end;
 
 Var
-  D,FontFile, FontFileChinese : String;
+  FontFile, FontFileChinese : String;
+  {$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
+  D : String;
   Info : TSearchRec;
-
+  {$ENDIF}
 begin
   // Initialize font search path;
-{$IFDEF UNIX}
+{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
-{$IFNDEF DARWIN}
   D := '/usr/share/fonts/truetype/';
   DefaultSearchPath:=D;
   if FindFirst(DefaultSearchPath+AllFilesMask,faDirectory,Info)=0 then
@@ -101,7 +109,6 @@ begin
     finally
       FindClose(Info);
     end;
-{$ENDIF}
 {$ENDIF}
   FontFile:=ParamStr(1);
   if FontFile='' then

packages/fcl-image/src/freetype.pp

@@ -44,7 +44,7 @@ type
   TBitmapType = (btBlackWhite, bt256Gray);
   TFontBitmap = record
     height, width, pitch,
-    x,y, advanceX, advanceY : integer;
+    x,y, bearingX, bearingY, advanceX, advanceY : integer;
     data : PByteArray;
   end;
   PFontBitmap = ^TFontBitmap;
@@ -687,15 +687,20 @@ begin
         begin
         with gl^.advance do
           begin
-          advanceX := x shr 16;
+          // do not use shr 16 - rotated text can have negative advances
-          advanceY := y shr 16;
+          advanceX := x div 65536;
+          advanceY := y div 65536;
           end;
         with bm^ do
           begin
           height := bitmap.rows;
           width := bitmap.width;
-          x := {(pos.x div 64)} + left;  // transformed bitmap has correct x,y
+          // transformed bitmap has correct x,y
-          y := {(pos.y div 64)} - top;   // not transformed has only a relative correction
+          x := {(pos.x div 64)} + left;
+          y := {(pos.y div 64)} - top;
+          // bearings are not supported for rotated text (don't make sense)
+          bearingX := 0;
+          bearingY := 0;
           buf := PByteArray(bitmap.buffer);
           reverse := (bitmap.pitch < 0);
           if reverse then
@@ -783,6 +788,7 @@ var g : PMgrGlyph;
     pos, kern : FT_Vector;
     buf : PByteArray;
     reverse : boolean;
+    bmpr : PFontBitmap;
 begin
   if (CurRenderMode = FT_RENDER_MODE_MONO) then
     ABitmaps.FMode := btBlackWhite
@@ -810,8 +816,10 @@ begin
     FTCheck(FT_Glyph_To_Bitmap (gl, CurRenderMode, PFT_Vector(0), true),sErrMakingString4);
     // Copy what is needed to record
     bm := PFT_BitmapGlyph(gl);
-    with ABitmaps.Bitmaps[r]^ do
+    bmpr := ABitmaps.Bitmaps[r];
+    with bmpr^ do
       begin
+      // glyph size including bearings all around
       with gl^.advance do
         begin
         advanceX := x shr 16;
@@ -819,10 +827,15 @@ begin
         end;
       with bm^ do
         begin
+        // glyph pixel size
         height := bitmap.rows;
         width := bitmap.width;
-        x := (pos.x shr 6) + left;   // transformed bitmap has correct x,y
+        // origin of the glyph
-        y := (pos.y shr 6) - top;    // not transformed has only a relative correction
+        x := pos.x shr 6;
+        y := pos.y shr 6;
+        // bearing - where the pixels start relative to x/y origin
+        bearingX := left;
+        bearingY := top;
         buf := PByteArray(bitmap.buffer);
         reverse := (bitmap.pitch < 0);
         if reverse then
@@ -987,39 +1000,41 @@ end;
 
 procedure TBAseStringBitmaps.CalculateGlobals;
 var
-  l,r : integer;
+  r : integer;
+  Bmp : PFontBitmap;
 
 begin
   if count = 0 then
     Exit;
-  l:=0;
+  Bmp := Bitmaps[0];
-  // Find first non-empty bitmap. Bitmaps can be empty for spaces.
+  with Bmp^ do
-  While (l<Count) and (BitMaps[l]^.Width=0) and (BitMaps[l]^.Height=0) do
+    begin
-    Inc(l);
+    FBounds.left := x;
-  if L<Count then
+    FBounds.top := y + bearingY;
-    with BitMaps[L]^ do
+    FBounds.bottom := y + bearingY - height;
-      begin
+    end;
-      FBounds.left := x;
+  Bmp := Bitmaps[Count-1];
-      FBounds.top := y + height;
+  With Bmp^ do
-      FBounds.bottom := y;
+    begin
-      FBounds.right := x + width;
+    FBounds.right := x + advanceX;
-      end;
+    // typographically it is not correct to check the real width of the character
-  // Find last non-empty bitmap
+    //   because accents can exceed the advance (e.g. í - the dash goes beyond the character
-  r:=Count-1;
+    //   but i and í should have the same width)
-  While (R>l) and (BitMaps[r]^.Width=0) and (BitMaps[r]^.Height=0) do
+    // on the other hand for some fonts the advance is always 1px short also for normal characters
-    Dec(r);
+    //   and also with this we support rotated text
-  if R>L then
+    if FBounds.right < x + bearingX + width then
-    With Bitmaps[R]^ do
+      FBounds.right := x + bearingX + width;
-      FBounds.right := x + width;
+    end;
   // check top/bottom of other bitmaps
   for r := 1 to count-1 do
     begin
-    with Bitmaps[r]^ do
+    Bmp := Bitmaps[r];
+    with Bmp^ do
       begin
-      if FBounds.top < y + height then
+      if FBounds.top < y + bearingY then
-        FBounds.top := y + height;
+        FBounds.top := y + bearingY;
-      if FBounds.bottom > y then
+      if FBounds.bottom > y + bearingY - height then
-        FBounds.bottom := y;
+        FBounds.bottom := y + bearingY - height;
       end;
     end;
 end;

packages/fcl-image/src/ftfont.pp

@@ -182,7 +182,7 @@ begin
   FLastText.GetBoundRect (r);
   with r do
     begin
-    w := right - left;
+    w := right;
     h := top - bottom;
     end;
 end;
@@ -202,7 +202,7 @@ begin
   GetText (text);
   FLastText.GetBoundRect (r);
   with r do
-    result := right - left;
+    result := right;
 end;
 
 procedure TFreeTypeFont.DoGetTextSize (text:unicodestring; var w,h:integer);
@@ -212,7 +212,7 @@ begin
   FLastText.GetBoundRect (r);
   with r do
     begin
-    w := right - left;
+    w := right;
     h := top - bottom;
     end;
 end;
@@ -232,7 +232,7 @@ begin
   GetText (text);
   FLastText.GetBoundRect (r);
   with r do
-    result := right - left;
+    result := right;
 end;
 
 procedure TFreeTypeFont.SetFlags (index:integer; AValue:boolean);
@@ -358,9 +358,9 @@ begin
       with Bitmaps[r]^ do
         begin
         if mode = btBlackWhite then
-          DrawCharBW (atX+x, atY+y, data, pitch, width, height)
+          DrawCharBW (atX+x+bearingX, atY+y-bearingY, data, pitch, width, height)
         else
-          DrawChar (atX+x, atY+y, data, pitch, width, height);
+          DrawChar (atX+x+bearingX, atY+y-bearingY, data, pitch, width, height);
         end;
 end;