mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-07-30 11:26:45 +02:00
848 lines
23 KiB
ObjectPascal
848 lines
23 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2003 by the Free Pascal development team
|
|
|
|
Basic canvas definitions.
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
{$mode objfpc}{$h+}
|
|
unit freetype;
|
|
|
|
interface
|
|
|
|
uses sysutils, classes, freetypeh, FPImgCmn;
|
|
|
|
{ TODO : take resolution in account to find the size }
|
|
{ TODO : speed optimization: search glyphs with a hash-function/tree/binary search/... }
|
|
{ TODO : memory optimization: TStringBitmaps keeps for each differnet character
|
|
only 1 bitmap }
|
|
{ TODO : load other files depending on the extention }
|
|
{ possible TODO : different sizes/resolutions for x and y }
|
|
{ possible TODO : TFontmanager can fill a list of all the fonts he can find
|
|
fontfiles and faces available in a fontfile }
|
|
|
|
// determine if file comparison need to be case sensitive or not
|
|
{$ifdef WIN32}
|
|
{$undef CaseSense}
|
|
{$else}
|
|
{$define CaseSense}
|
|
{$endif}
|
|
|
|
type
|
|
|
|
FreeTypeException = class (exception);
|
|
|
|
TBitmapType = (btBlackWhite, bt256Gray);
|
|
TFontBitmap = record
|
|
height, width, pitch,
|
|
x,y, advanceX, advanceY : integer;
|
|
data : PByteArray;
|
|
end;
|
|
PFontBitmap = ^TFontBitmap;
|
|
|
|
|
|
TStringBitMaps = class
|
|
private
|
|
FList : TList;
|
|
FBounds : TRect;
|
|
FText : string;
|
|
FMode : TBitmapType;
|
|
function GetCount : integer;
|
|
function GetBitmap (index:integer) : PFontBitmap;
|
|
procedure CalculateGlobals;
|
|
public
|
|
constructor Create (ACount : integer);
|
|
destructor destroy; override;
|
|
procedure GetBoundRect (var aRect : TRect);
|
|
property Text : string read FText;
|
|
property Mode : TBitmapType read FMode;
|
|
property Count : integer read GetCount;
|
|
property Bitmaps[index:integer] : PFontBitmap read GetBitmap;
|
|
end;
|
|
|
|
TFontManager = class;
|
|
|
|
PMgrGlyph = ^TMgrGlyph;
|
|
TMgrGlyph = record
|
|
Character : char;
|
|
GlyphIndex : FT_UInt;
|
|
Glyph : PFT_Glyph;
|
|
end;
|
|
|
|
PMgrSize = ^TMgrSize;
|
|
TMgrSize = record
|
|
Resolution, Size : integer;
|
|
Glyphs : TList;
|
|
end;
|
|
|
|
TMgrFont = class
|
|
private
|
|
Mgr : TFontManager;
|
|
Font : PFT_Face;
|
|
FSizes : TList;
|
|
Filename : string;
|
|
LastSize : PMgrSize;
|
|
procedure FreeGlyphs;
|
|
public
|
|
constructor Create (aMgr:TFontManager; afilename:string; anindex:integer);
|
|
destructor destroy; override;
|
|
end;
|
|
|
|
TFontManager = class
|
|
private
|
|
FTLib : PFT_Library;
|
|
FList : TList;
|
|
FPaths : TStringList;
|
|
FExtention : string;
|
|
FResolution : integer;
|
|
CurFont : TMgrFont;
|
|
CurSize : PMgrSize;
|
|
CurRenderMode : FT_Render_Mode;
|
|
CurTransform : FT_Matrix;
|
|
UseKerning : boolean;
|
|
function GetSearchPath : string;
|
|
procedure SetSearchPath (AValue : string);
|
|
procedure SetExtention (AValue : string);
|
|
protected
|
|
function GetFontId (afilename:string; anindex:integer) : integer;
|
|
function CreateFont (afilename:string; anindex:integer) : integer;
|
|
function SearchFont (afilename:string) : string;
|
|
function GetFont (FontID:integer) : TMgrFont;
|
|
procedure GetSize (aSize, aResolution : integer);
|
|
function CreateSize (aSize, aResolution : integer) : PMgrSize;
|
|
procedure SetPixelSize (aSize, aResolution : integer);
|
|
function GetGlyph (c : char) : PMgrGlyph;
|
|
function CreateGlyph (c : char) : PMgrGlyph;
|
|
procedure MakeTransformation (angle:real; var Transformation:FT_Matrix);
|
|
procedure InitMakeString (FontID, Size:integer);
|
|
function MakeString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
|
|
function MakeString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
|
|
public
|
|
constructor Create;
|
|
destructor destroy; override;
|
|
function RequestFont (afilename:string) : integer;
|
|
function RequestFont (afilename:string; anindex:integer) : integer;
|
|
function GetFreeTypeFont (aFontID:integer) : PFT_Face;
|
|
function GetString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
|
|
// Black and white
|
|
function GetStringGray (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
|
|
// Anti Aliased gray scale
|
|
function GetString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
|
|
// Black and white, following the direction of the font (left to right, top to bottom, ...)
|
|
function GetStringGray (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
|
|
// Anti Aliased gray scale, following the direction of the font (left to right, top to bottom, ...)
|
|
property SearchPath : string read GetSearchPath write SetSearchPath;
|
|
property DefaultExtention : string read FExtention write SetExtention;
|
|
property Resolution : integer read Fresolution write FResolution;
|
|
end;
|
|
|
|
const
|
|
sErrErrorsInCleanup : string = '%d errors detected while freeing a Font Manager object';
|
|
sErrFontFileNotFound : string = 'Font file "%s" not found';
|
|
sErrFreeType : string = 'Error %d while %s';
|
|
sInitializing : string = 'initializing font engine';
|
|
sDestroying : string = 'destroying font engine';
|
|
sErrErrorInCleanup : string = 'freeing Font Manager object';
|
|
sErrSetPixelSize : string = 'setting pixel size %d (resolution %d)';
|
|
sErrSetCharSize : string = 'setting char size %d (resolution %d)';
|
|
sErrLoadingGlyph : string = 'loading glyph';
|
|
sErrKerning : string = 'determining kerning distance';
|
|
sErrMakingString1 : string = 'making string bitmaps step 1';
|
|
sErrMakingString2 : string = 'making string bitmaps step 2';
|
|
sErrMakingString3 : string = 'making string bitmaps step 3';
|
|
sErrMakingString4 : string = 'making string bitmaps step 4';
|
|
sErrLoadFont : string = 'loading font %d from file %s';
|
|
sErrInitializing : string = 'initializing FreeType';
|
|
sErrDestroying : string = 'finalizing FreeType';
|
|
|
|
DefaultFontExtention : string = '.ttf';
|
|
DefaultSearchPath : string = '';
|
|
{$IFDEF MAC}
|
|
DefaultResolution : integer = 72;
|
|
{$ELSE}
|
|
DefaultResolution : integer = 97;
|
|
{$ENDIF}
|
|
|
|
implementation
|
|
|
|
{$IFDEF win32}uses dos;{$ENDIF}
|
|
|
|
procedure FTError (Event:string; Err:integer);
|
|
begin
|
|
raise FreeTypeException.CreateFmt (sErrFreeType, [Err,Event]);
|
|
end;
|
|
|
|
Function FTCheck (Res: Integer; Msg:string) : Integer;
|
|
|
|
begin
|
|
Result:=Res;
|
|
If (Result<>0) then
|
|
FTError(Msg,Result);
|
|
end;
|
|
|
|
{ TMgrFont }
|
|
|
|
constructor TMgrFont.Create (aMgr:TFontManager; afilename:string; anindex:integer);
|
|
|
|
begin
|
|
inherited create;
|
|
Filename := afilename;
|
|
Mgr := aMgr;
|
|
FSizes := TList.create;
|
|
LastSize := nil;
|
|
Try
|
|
FTCheck(FT_New_Face (aMgr.FTLib, pchar(afilename), anindex, font),format (sErrLoadFont,[anindex,afilename]));
|
|
except
|
|
Font:=Nil;
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
destructor TMgrFont.destroy;
|
|
begin
|
|
try
|
|
FreeGlyphs;
|
|
finally
|
|
FSizes.Free;
|
|
inherited Destroy;
|
|
end;
|
|
end;
|
|
|
|
procedure TMgrFont.FreeGlyphs;
|
|
var r,t : integer;
|
|
S : PMgrSize;
|
|
G : PMgrGlyph;
|
|
begin
|
|
for r := FSizes.count-1 downto 0 do
|
|
begin
|
|
with PMgrSize(FSizes[r])^ do
|
|
begin
|
|
for t := Glyphs.count-1 downto 0 do
|
|
begin
|
|
with PMgrGlyph(Glyphs[t])^ do
|
|
FT_Done_Glyph (Glyph);
|
|
G := PMgrGlyph(Glyphs[t]);
|
|
dispose (G);
|
|
end;
|
|
Glyphs.Free;
|
|
end;
|
|
S := PMgrSize(FSizes[r]);
|
|
dispose (S);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TFontManager }
|
|
|
|
constructor TFontManager.Create;
|
|
var r : integer;
|
|
begin
|
|
inherited create;
|
|
FList := Tlist.Create;
|
|
FPaths := TStringList.Create;
|
|
r := FT_Init_FreeType(FTLib);
|
|
if r <> 0 then
|
|
begin
|
|
FTLib := nil;
|
|
FTError (sErrInitializing, r);
|
|
end;
|
|
SearchPath := DefaultSearchPath;
|
|
DefaultExtention := DefaultFontExtention;
|
|
Resolution := DefaultResolution;
|
|
end;
|
|
|
|
destructor TFontManager.Destroy;
|
|
procedure FreeFontObjects;
|
|
var r : integer;
|
|
begin
|
|
for r := FList.Count-1 downto 0 do
|
|
begin
|
|
GetFont(r).Free;
|
|
end;
|
|
end;
|
|
procedure FreeLibrary;
|
|
var r : integer;
|
|
begin
|
|
r := FT_Done_FreeType (FTlib);
|
|
if r <> 0 then
|
|
FTError (sErrDestroying, r);
|
|
end;
|
|
begin
|
|
FreeFontObjects;
|
|
FList.Free;
|
|
FPaths.Free;
|
|
try
|
|
if assigned(FTLib) then
|
|
FreeLibrary;
|
|
finally
|
|
inherited Destroy;
|
|
end;
|
|
end;
|
|
|
|
function TFontManager.GetSearchPath : string;
|
|
var r : integer;
|
|
begin
|
|
if FPaths.count > 0 then
|
|
begin
|
|
result := FPaths[0];
|
|
for r := 1 to FPaths.count-1 do
|
|
result := result + ';' + FPaths[r];
|
|
end
|
|
else
|
|
result := '';
|
|
end;
|
|
|
|
procedure TFontManager.SetSearchPath (AValue : string);
|
|
procedure AddPath (apath : string);
|
|
begin
|
|
FPaths.Add (IncludeTrailingBackslash(Apath));
|
|
end;
|
|
var p : integer;
|
|
begin
|
|
while (AValue <> '') do
|
|
begin
|
|
p := pos (';', AValue);
|
|
if p = 0 then
|
|
begin
|
|
AddPath (AValue);
|
|
AValue := '';
|
|
end
|
|
else
|
|
begin
|
|
AddPath (copy(AValue,1,p-1));
|
|
delete (AVAlue,1,p);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TFontManager.SetExtention (AValue : string);
|
|
begin
|
|
if AValue <> '' then
|
|
if AValue[1] <> '.' then
|
|
FExtention := '.' + AValue
|
|
else
|
|
FExtention := AValue
|
|
else
|
|
AValue := '';
|
|
end;
|
|
|
|
function TFontManager.SearchFont (afilename:string) : string;
|
|
// returns full filename of font, taking SearchPath in account
|
|
var p,fn : string;
|
|
r : integer;
|
|
begin
|
|
if (pos('.', afilename)=0) and (DefaultFontExtention<>'') then
|
|
fn := afilename + DefaultFontExtention
|
|
else
|
|
fn := aFilename;
|
|
if FileExists(fn) then
|
|
result := ExpandFilename(fn)
|
|
else
|
|
begin
|
|
p := ExtractFilepath(fn);
|
|
if p = '' then
|
|
begin // no path given, look in SearchPaths
|
|
r := FPaths.Count;
|
|
repeat
|
|
dec (r);
|
|
until (r < 0) or FileExists(FPaths[r]+fn);
|
|
if r < 0 then
|
|
raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [fn])
|
|
else
|
|
result := FPaths[r]+fn;
|
|
end
|
|
else
|
|
raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [afilename]);
|
|
end;
|
|
end;
|
|
|
|
function TFontManager.GetFontId (afilename:string; anindex:integer) : integer;
|
|
begin
|
|
result := FList.count-1;
|
|
while (result >= 0) and
|
|
( ({$ifdef CaseSense}CompareText{$else}CompareStr{$endif}
|
|
(TMgrFont(FList[anIndex]).Filename, afilename) <> 0) or
|
|
(anIndex <> TMgrFont(FList[anIndex]).font^.face_index)
|
|
) do
|
|
dec (result);
|
|
end;
|
|
|
|
function TFontManager.CreateFont (afilename:string; anindex:integer) : integer;
|
|
var f : TMgrFont;
|
|
begin
|
|
// writeln ('creating font ',afilename,' (',anindex,')');
|
|
f := TMgrFont.Create (self, afilename, anindex);
|
|
result := FList.Count;
|
|
Flist.Add (f);
|
|
end;
|
|
|
|
function TFontManager.GetFont (FontID:integer) : TMgrFont;
|
|
begin
|
|
result := TMgrFont(FList[FontID]);
|
|
if result <> CurFont then // set last used size of the font as current size
|
|
begin
|
|
CurSize := result.LastSize;
|
|
end;
|
|
end;
|
|
|
|
procedure TFontManager.GetSize (aSize, aResolution : integer);
|
|
var r : integer;
|
|
begin
|
|
if not ( assigned(CurSize) and
|
|
(CurSize^.Size = aSize) and (CurSize^.resolution = aResolution)) then
|
|
begin
|
|
r := CurFont.FSizes.count;
|
|
repeat
|
|
dec (r)
|
|
until (r < 0) or ( (PMgrSize(CurFont.FSizes[r])^.size = aSize) and
|
|
(PMgrSize(CurFont.FSizes[r])^.resolution = FResolution) );
|
|
if r < 0 then
|
|
CurSize := CreateSize (aSize,aResolution)
|
|
else
|
|
CurSize := PMgrSize(CurFont.FSizes[r]);
|
|
CurFont.LastSize := CurSize;
|
|
end;
|
|
end;
|
|
|
|
function TFontManager.CreateSize (aSize, aResolution : integer) : PMgrSize;
|
|
begin
|
|
new (result);
|
|
result^.Size := aSize;
|
|
result^.Size := aResolution;
|
|
result^.Glyphs := Tlist.Create;
|
|
SetPixelSize (aSize,aResolution);
|
|
CurFont.FSizes.Add (result);
|
|
end;
|
|
|
|
procedure TFontManager.SetPixelSize (aSize, aResolution : integer);
|
|
|
|
procedure CheckSize;
|
|
var r : integer;
|
|
begin
|
|
with Curfont.Font^ do
|
|
begin
|
|
r := Num_fixed_sizes;
|
|
repeat
|
|
dec (r);
|
|
until (r < 0) or
|
|
( (available_sizes^[r].height=asize) and
|
|
(available_sizes^[r].width=asize) );
|
|
if r >= 0 then
|
|
raise FreeTypeException.CreateFmt ('Size %d not available for %s %s',
|
|
[aSize, style_name, family_name]);
|
|
end;
|
|
end;
|
|
|
|
var s : longint;
|
|
Err : integer;
|
|
|
|
begin
|
|
with Curfont, Font^ do
|
|
if (face_flags and FT_Face_Flag_Fixed_Sizes) <> 0 then
|
|
begin
|
|
CheckSize;
|
|
Err := FT_Set_pixel_sizes (Font, aSize, aSize);
|
|
if Err <> 0 then
|
|
FTError (format(sErrSetPixelSize,[aSize,aResolution]), Err);
|
|
end
|
|
else
|
|
begin
|
|
s := aSize shl 6;
|
|
Err := FT_Set_char_size (Font, s, s, aResolution, aResolution);
|
|
if Err <> 0 then
|
|
FTError (format(sErrSetCharSize,[aSize,aResolution]), Err);
|
|
end;
|
|
end;
|
|
|
|
procedure TFontManager.MakeTransformation (angle:real; var Transformation:FT_Matrix);
|
|
begin
|
|
with Transformation do
|
|
begin
|
|
xx := round( cos(angle)*$10000);
|
|
xy := round(-sin(angle)*$10000);
|
|
yx := round( sin(angle)*$10000);
|
|
yy := round( cos(angle)*$10000);
|
|
end;
|
|
end;
|
|
|
|
function TFontManager.CreateGlyph (c : char) : PMgrGlyph;
|
|
var e : integer;
|
|
begin
|
|
new (result);
|
|
result^.character := c;
|
|
result^.GlyphIndex := FT_Get_Char_Index (CurFont.font, ord(c));
|
|
e := FT_Load_Glyph (CurFont.font, result^.GlyphIndex, FT_Load_Default);
|
|
if e <> 0 then
|
|
begin
|
|
FTError (sErrLoadingGlyph, e);
|
|
end;
|
|
e := FT_Get_Glyph (Curfont.font^.glyph, result^.glyph);
|
|
if e <> 0 then
|
|
begin
|
|
FTError (sErrLoadingGlyph, e);
|
|
end;
|
|
CurSize^.Glyphs.Add (result);
|
|
end;
|
|
|
|
function TFontManager.GetGlyph (c : char) : PMgrGlyph;
|
|
var r : integer;
|
|
begin
|
|
With CurSize^ do
|
|
begin
|
|
r := FList.Count;
|
|
repeat
|
|
dec (r)
|
|
until (r < 0) or (PMgrGlyph(Flist[r])^.character = c);
|
|
if r < 0 then
|
|
result := CreateGlyph (c)
|
|
else
|
|
result := PMgrGlyph(Flist[r]);
|
|
end;
|
|
end;
|
|
|
|
procedure TFontManager.InitMakeString (FontID, Size:integer);
|
|
begin
|
|
GetSize (size,Resolution);
|
|
UseKerning := ((Curfont.font^.face_flags and FT_FACE_FLAG_KERNING) <> 0);
|
|
end;
|
|
|
|
function TFontManager.MakeString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
|
|
var g : PMgrGlyph;
|
|
bm : PFT_BitmapGlyph;
|
|
gl : PFT_Glyph;
|
|
e, prevIndex, prevx, c, r, rx : integer;
|
|
pre, adv, pos, kern : FT_Vector;
|
|
buf : PByteArray;
|
|
reverse : boolean;
|
|
trans : FT_Matrix;
|
|
begin
|
|
CurFont := GetFont(FontID);
|
|
if (Angle = 0) or // no angle asked, or can't work with angles (not scalable)
|
|
((CurFont.Font^.face_flags and FT_FACE_FLAG_SCALABLE)=0) then
|
|
result := MakeString (FontID, Text, Size)
|
|
else
|
|
begin
|
|
InitMakeString (FontID, Size);
|
|
c := length(text);
|
|
result := TStringBitmaps.Create(c);
|
|
if (CurRenderMode = FT_RENDER_MODE_MONO) then
|
|
result.FMode := btBlackWhite
|
|
else
|
|
result.FMode := bt256Gray;
|
|
MakeTransformation (angle, trans);
|
|
prevIndex := 0;
|
|
prevx := 0;
|
|
pos.x := 0;
|
|
pos.y := 0;
|
|
pre.x := 0;
|
|
pre.y := 0;
|
|
for r := 0 to c-1 do
|
|
begin
|
|
// retrieve loaded glyph
|
|
g := GetGlyph (Text[r+1]);
|
|
// check kerning
|
|
if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
|
|
begin
|
|
prevx := pre.x;
|
|
FTCheck(FT_Get_Kerning (Curfont.Font, prevIndex, g^.GlyphIndex, ft_kerning_default, kern),sErrKerning);
|
|
pre.x := pre.x + kern.x;
|
|
end;
|
|
// render the glyph
|
|
Gl:=Nil;
|
|
FTCheck(FT_Glyph_Copy (g^.glyph, gl),sErrMakingString1);
|
|
// placing the glyph
|
|
FTCheck(FT_Glyph_Transform (gl, nil, @pre),sErrMakingString2);
|
|
adv := gl^.advance;
|
|
// rotating the glyph
|
|
FTCheck(FT_Glyph_Transform (gl, @trans, nil),sErrMakingString3);
|
|
// rendering the glyph
|
|
FTCheck(FT_Glyph_To_Bitmap (gl, CurRenderMode, nil, true),sErrMakingString4);
|
|
// Copy what is needed to record
|
|
bm := PFT_BitmapGlyph(gl);
|
|
with result.Bitmaps[r]^ do
|
|
begin
|
|
with gl^.advance do
|
|
begin
|
|
advanceX := x div 64;
|
|
advanceY := y div 64;
|
|
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
|
|
buf := PByteArray(bitmap.buffer);
|
|
reverse := (bitmap.pitch < 0);
|
|
if reverse then
|
|
begin
|
|
pitch := -bitmap.pitch;
|
|
getmem (data, pitch*height);
|
|
for rx := height-1 downto 0 do
|
|
move (buf^[rx*pitch], data^[(height-rx-1)*pitch], pitch);
|
|
end
|
|
else
|
|
begin
|
|
pitch := bitmap.pitch;
|
|
rx := pitch*height;
|
|
getmem (data, rx);
|
|
move (buf^[0], data^[0], rx);
|
|
end;
|
|
end;
|
|
end;
|
|
// place position for next glyph
|
|
with gl^.advance do
|
|
begin
|
|
pos.x := pos.x + (x div 1024);
|
|
pos.y := pos.y + (y div 1024);
|
|
end;
|
|
with adv do
|
|
pre.x := pre.x + (x div 1024);
|
|
if prevx > pre.x then
|
|
pre.x := prevx;
|
|
// finish rendered glyph
|
|
FT_Done_Glyph (gl);
|
|
end;
|
|
result.FText := Text;
|
|
result.CalculateGlobals;
|
|
end;
|
|
end;
|
|
|
|
function TFontManager.MakeString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
|
|
var g : PMgrGlyph;
|
|
bm : PFT_BitmapGlyph;
|
|
gl : PFT_Glyph;
|
|
e, prevIndex, prevx, c, r, rx : integer;
|
|
pos, kern : FT_Vector;
|
|
buf : PByteArray;
|
|
reverse : boolean;
|
|
begin
|
|
CurFont := GetFont(FontID);
|
|
InitMakeString (FontID, Size);
|
|
c := length(text);
|
|
result := TStringBitmaps.Create(c);
|
|
if (CurRenderMode = FT_RENDER_MODE_MONO) then
|
|
result.FMode := btBlackWhite
|
|
else
|
|
result.FMode := bt256Gray;
|
|
prevIndex := 0;
|
|
prevx := 0;
|
|
pos.x := 0;
|
|
pos.y := 0;
|
|
for r := 0 to c-1 do
|
|
begin
|
|
// retrieve loaded glyph
|
|
g := GetGlyph (Text[r+1]);
|
|
// check kerning
|
|
if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
|
|
begin
|
|
prevx := pos.x;
|
|
e := FT_Get_Kerning (Curfont.Font, prevIndex, g^.GlyphIndex, ft_kerning_default, kern);
|
|
if e <> 0 then
|
|
FTError (sErrKerning, e);
|
|
pos.x := pos.x + kern.x;
|
|
end;
|
|
// render the glyph
|
|
FTCheck(FT_Glyph_Copy (g^.glyph, gl),sErrMakingString1);
|
|
FTCheck(FT_Glyph_To_Bitmap (gl, CurRenderMode, @pos, true),sErrMakingString4);
|
|
// Copy what is needed to record
|
|
bm := PFT_BitmapGlyph(gl);
|
|
with result.Bitmaps[r]^ do
|
|
begin
|
|
with gl^.advance do
|
|
begin
|
|
advanceX := x shr 6;
|
|
advanceY := y shr 6;
|
|
end;
|
|
with bm^ do
|
|
begin
|
|
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
|
|
buf := PByteArray(bitmap.buffer);
|
|
reverse := (bitmap.pitch < 0);
|
|
if reverse then
|
|
begin
|
|
pitch := -bitmap.pitch;
|
|
getmem (data, pitch*height);
|
|
for rx := height-1 downto 0 do
|
|
move (buf^[rx*pitch], data^[(height-rx-1)*pitch], pitch);
|
|
end
|
|
else
|
|
begin
|
|
pitch := bitmap.pitch;
|
|
rx := pitch*height;
|
|
getmem (data, rx);
|
|
move (buf^[0], data^[0], rx);
|
|
end;
|
|
end;
|
|
end;
|
|
// place position for next glyph
|
|
pos.x := pos.x + (gl^.advance.x shr 10);
|
|
// pos.y := pos.y + (gl^.advance.y shr 6); // for angled texts also
|
|
if prevx > pos.x then
|
|
pos.x := prevx;
|
|
// finish rendered glyph
|
|
FT_Done_Glyph (gl);
|
|
end;
|
|
result.FText := Text;
|
|
result.CalculateGlobals;
|
|
end;
|
|
|
|
function TFontManager.GetString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
|
|
// Black and white
|
|
begin
|
|
CurRenderMode := FT_RENDER_MODE_MONO;
|
|
result := MakeString (FontID, text, Size, angle);
|
|
end;
|
|
|
|
function TFontManager.GetStringGray (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
|
|
// Anti Aliased gray scale
|
|
begin
|
|
CurRenderMode := FT_RENDER_MODE_NORMAL;
|
|
result := MakeString (FontID, text, Size, angle);
|
|
end;
|
|
|
|
{ Procedures without angle have own implementation to have better speed }
|
|
|
|
function TFontManager.GetString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
|
|
// Black and white, following the direction of the font (left to right, top to bottom, ...)
|
|
begin
|
|
CurRenderMode := FT_RENDER_MODE_MONO;
|
|
result := MakeString (FontID, text, Size);
|
|
end;
|
|
|
|
function TFontManager.GetStringGray (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
|
|
// Anti Aliased gray scale, following the direction of the font (left to right, top to bottom, ...)
|
|
begin
|
|
CurRenderMode := FT_RENDER_MODE_NORMAL;
|
|
result := MakeString (FontID, text, Size);
|
|
end;
|
|
|
|
function TFontManager.RequestFont (afilename:string) : integer;
|
|
begin
|
|
result := RequestFont (afilename,0);
|
|
end;
|
|
|
|
function TFontManager.RequestFont (afilename:string; anindex:integer) : integer;
|
|
var s : string;
|
|
begin
|
|
if afilename = '' then
|
|
result := -1
|
|
else
|
|
begin
|
|
s := SearchFont (afilename);
|
|
result := GetFontID (s,anindex);
|
|
if result < 0 then
|
|
result := CreateFont (s,anindex);
|
|
end;
|
|
end;
|
|
|
|
function TFontManager.GetFreeTypeFont (aFontID:integer) : PFT_Face;
|
|
begin
|
|
result := GetFont(aFontID).font;
|
|
end;
|
|
|
|
{ TStringBitmaps }
|
|
|
|
function TStringBitmaps.GetCount : integer;
|
|
begin
|
|
result := FList.Count;
|
|
end;
|
|
|
|
function TStringBitmaps.GetBitmap (index:integer) : PFontBitmap;
|
|
begin
|
|
result := PFontBitmap(FList[index]);
|
|
end;
|
|
|
|
constructor TStringBitmaps.Create (ACount : integer);
|
|
var r : integer;
|
|
bm : PFontBitmap;
|
|
begin
|
|
inherited create;
|
|
FList := Tlist.Create;
|
|
FList.Capacity := ACount;
|
|
for r := 0 to ACount-1 do
|
|
begin
|
|
new (bm);
|
|
FList.Add (bm);
|
|
end;
|
|
end;
|
|
|
|
destructor TStringBitmaps.destroy;
|
|
var r : integer;
|
|
bm : PFontBitmap;
|
|
begin
|
|
for r := 0 to Flist.count-1 do
|
|
begin
|
|
bm := PFontBitmap(FList[r]);
|
|
freemem (bm^.data);
|
|
dispose (bm);
|
|
end;
|
|
FList.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TStringBitmaps.CalculateGlobals;
|
|
var r : integer;
|
|
begin
|
|
if count = 0 then
|
|
Exit;
|
|
// check first 2 bitmaps for left side
|
|
// check last 2 bitmaps for right side
|
|
with BitMaps[0]^ do
|
|
begin
|
|
FBounds.left := x;
|
|
FBounds.top := y + height;
|
|
FBounds.bottom := y;
|
|
end;
|
|
with Bitmaps[count-1]^ do
|
|
FBounds.right := x + width;
|
|
if count > 1 then
|
|
begin
|
|
with Bitmaps[1]^ do
|
|
r := x;
|
|
if r < FBounds.left then
|
|
FBounds.left := r;
|
|
with Bitmaps[count-2]^ do
|
|
r := x + width;
|
|
if r > FBounds.right then
|
|
FBounds.right := r;
|
|
end;
|
|
// check top/bottom of other bitmaps
|
|
for r := 1 to count-1 do
|
|
with Bitmaps[r]^ do
|
|
begin
|
|
if FBounds.top < y + height then
|
|
FBounds.top := y + height;
|
|
if FBounds.bottom > y then
|
|
FBounds.bottom := y;
|
|
end;
|
|
end;
|
|
|
|
procedure TStringBitmaps.GetBoundRect (var aRect : TRect);
|
|
begin
|
|
aRect := FBounds;
|
|
end;
|
|
|
|
{$ifdef win32}
|
|
procedure SetWindowsFontPath;
|
|
begin
|
|
DefaultSearchPath := includetrailingbackslash(GetEnv('windir')) + 'fonts';
|
|
end;
|
|
{$endif}
|
|
|
|
initialization
|
|
{$ifdef win32}
|
|
SetWindowsFontPath;
|
|
{$endif}
|
|
end. |