paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-11 20:29:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

freetype: include bearings and invisible characters into text bounds

Browse Source 
git-svn-id: trunk@49629 -
This commit is contained in:
ondrej 2021-07-22 05:12:18 +00:00
parent 41d6374bb6
commit b9db32ca05
3 changed files with 72 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
packages/fcl-image/examples/textout.pp
View File

@ -3,10 +3,7 @@
program textout;
uses
{$IFDEF UNIX}cwstring, {$ENDIF} classes, sysutils, FPImage, FPCanvas, FPImgCanv, ftFont, FPWritePNG, freetype;
const
MyColor : TFPColor = (Red: $7FFF; Green: $0000; Blue: $FFFF; Alpha: alphaOpaque);
{$IFDEF UNIX}cwstring, {$ENDIF} classes, sysutils, Types, FPImage, FPCanvas, FPImgCanv, ftFont, FPWritePNG, freetype;
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}
{$IFNDEF DARWIN}
{$IF DEFINED(UNIX) AND NOT DEFINED(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

81
packages/fcl-image/src/freetype.pp
View File

@ -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;
advanceY := y shr 16;
// do not use shr 16 - rotated text can have negative advances
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
y := {(pos.y div 64)} - top; // not transformed has only a relative correction
// transformed bitmap has correct x,y
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
y := (pos.y shr 6) - top; // not transformed has only a relative correction
// origin of the glyph
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;
// Find first non-empty bitmap. Bitmaps can be empty for spaces.
While (l<Count) and (BitMaps[l]^.Width=0) and (BitMaps[l]^.Height=0) do
Inc(l);
if L<Count then
with BitMaps[L]^ do
begin
FBounds.left := x;
FBounds.top := y + height;
FBounds.bottom := y;
FBounds.right := x + width;
end;
// Find last non-empty bitmap
r:=Count-1;
While (R>l) and (BitMaps[r]^.Width=0) and (BitMaps[r]^.Height=0) do
Dec(r);
if R>L then
With Bitmaps[R]^ do
FBounds.right := x + width;
Bmp := Bitmaps[0];
with Bmp^ do
begin
FBounds.left := x;
FBounds.top := y + bearingY;
FBounds.bottom := y + bearingY - height;
end;
Bmp := Bitmaps[Count-1];
With Bmp^ do
begin
FBounds.right := x + advanceX;
// typographically it is not correct to check the real width of the character
// because accents can exceed the advance (e.g. í - the dash goes beyond the character
// but i and í should have the same width)
// on the other hand for some fonts the advance is always 1px short also for normal characters
// and also with this we support rotated text
if FBounds.right < x + bearingX + width then
FBounds.right := x + bearingX + 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
FBounds.top := y + height;
if FBounds.bottom > y then
FBounds.bottom := y;
if FBounds.top < y + bearingY then
FBounds.top := y + bearingY;
if FBounds.bottom > y + bearingY - height then
FBounds.bottom := y + bearingY - height;
end;
end;
end;

12
packages/fcl-image/src/ftfont.pp
View File

@ -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;