paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 15:59:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ FreeType font and freetype font library calls

Browse Source 
+ test program for fonts
This commit is contained in:
luk 2003-09-21 22:06:55 +00:00
parent 07504a9e93
commit 8d26c4604b
3 changed files with 1493 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

850
fcl/image/freetype.pp Normal file
View File

@ -0,0 +1,850 @@
{
$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';
sErrMakingString : string = 'making string bitmaps';
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, [Event,Err]);
end;
{ TMgrFont }
constructor TMgrFont.Create (aMgr:TFontManager; afilename:string; anindex:integer);
var e : integer;
begin
inherited create;
Filename := afilename;
Mgr := aMgr;
FSizes := TList.create;
LastSize := nil;
e := FT_New_Face (aMgr.FTLib, pchar(afilename), anindex, font);
if e <> 0 then
begin
Font := nil;
FTError (format (sErrLoadFont,[afilename,anindex]), e);
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;
e := FT_Get_Kerning (Curfont.Font, prevIndex, g^.GlyphIndex, ft_kerning_default, kern);
if e <> 0 then
FTError (sErrKerning, e);
pre.x := pre.x + kern.x;
end;
// render the glyph
e := FT_Glyph_Copy (g^.glyph, gl);
if e <> 0 then
FTError (sErrMakingString, e);
// placing the glyph
e := FT_Glyph_Transform (gl, nil, @pre);
if e <> 0 then
FTError (sErrMakingString, e);
adv := gl^.advance;
// rotating the glyph
e := FT_Glyph_Transform (gl, @trans, nil);
if e <> 0 then
FTError (sErrMakingString, e);
// rendering the glyph
e := FT_Glyph_To_Bitmap (gl, CurRenderMode, nil, true);
if e <> 0 then
FTError (sErrMakingString, e);
// 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
e := FT_Glyph_Copy (g^.glyph, gl);
if e <> 0 then
FTError (sErrMakingString, e);
e := FT_Glyph_To_Bitmap (gl, CurRenderMode, @pos, true);
if e <> 0 then
FTError (sErrMakingString, e);
// 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.

336
fcl/image/freetypeh.pp Normal file
View File

@ -0,0 +1,336 @@
{
$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}
unit freetypeh;
{ These are not all the availlable calls from the dll, but only those
I needed for the TStringBimaps }
interface
const
{$ifdef win32}
freetypedll = 'freetype-6.dll'; // version 2.1.4
{$packrecords c}
{$else}
// I don't know what it will be ??
freetypedll = 'freetype-6.dll';
{$endif}
type
FT_Encoding = array[0..3] of char;
const
FT_FACE_FLAG_SCALABLE = 1 shl 0;
FT_FACE_FLAG_FIXED_SIZES = 1 shl 1;
FT_FACE_FLAG_FIXED_WIDTH = 1 shl 2;
FT_FACE_FLAG_SFNT = 1 shl 3;
FT_FACE_FLAG_HORIZONTAL = 1 shl 4;
FT_FACE_FLAG_VERTICAL = 1 shl 5;
FT_FACE_FLAG_KERNING = 1 shl 6;
FT_FACE_FLAG_FAST_GLYPHS = 1 shl 7;
FT_FACE_FLAG_MULTIPLE_MASTERS = 1 shl 8;
FT_FACE_FLAG_GLYPH_NAMES = 1 shl 9;
FT_FACE_FLAG_EXTERNAL_STREAM = 1 shl 10;
FT_STYLE_FLAG_ITALIC = 1 shl 0;
FT_STYLE_FLAG_BOLD = 1 shl 1;
FT_LOAD_DEFAULT = $0000;
FT_LOAD_NO_SCALE = $0001;
FT_LOAD_NO_HINTING = $0002;
FT_LOAD_RENDER = $0004;
FT_LOAD_NO_BITMAP = $0008;
FT_LOAD_VERTICAL_LAYOUT = $0010;
FT_LOAD_FORCE_AUTOHINT = $0020;
FT_LOAD_CROP_BITMAP = $0040;
FT_LOAD_PEDANTIC = $0080;
FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = $0200;
FT_LOAD_NO_RECURSE = $0400;
FT_LOAD_IGNORE_TRANSFORM = $0800;
FT_LOAD_MONOCHROME = $1000;
FT_LOAD_LINEAR_DESIGN = $2000;
ft_glyph_format_none = $00000000;
ft_glyph_format_composite = $636F6D70; //comp 099 111 109 112
ft_glyph_format_bitmap = $62697473; //bits 098 105 116 115
ft_glyph_format_outline = $6F75746C; //outl 111 117 116 108
ft_glyph_format_plotter = $706C6F74; //plot 112 108 111 116
FT_ENCODING_MS_SYMBOL : FT_Encoding = 'symb';
FT_ENCODING_UNICODE : FT_Encoding = 'unic';
FT_ENCODING_MS_SJIS : FT_Encoding = 'sjis';
FT_ENCODING_MS_GB2312 : FT_Encoding = 'gb ';
FT_ENCODING_MS_BIG5 : FT_Encoding = 'big5';
FT_ENCODING_MS_WANSUNG : FT_Encoding = 'wans';
FT_ENCODING_MS_JOHAB : FT_Encoding = 'joha';
FT_ENCODING_ADOBE_STANDARD : FT_Encoding = 'ADOB';
FT_ENCODING_ADOBE_EXPERT : FT_Encoding = 'ADBE';
FT_ENCODING_ADOBE_CUSTOM : FT_Encoding = 'ADBC';
FT_ENCODING_ADOBE_LATIN_1 : FT_Encoding = 'lat1';
FT_ENCODING_OLD_LATIN_2 : FT_Encoding = 'lat2';
FT_ENCODING_APPLE_ROMAN : FT_Encoding = 'armn';
ft_glyph_bbox_unscaled = 0; //* return unscaled font units */
ft_glyph_bbox_subpixels = 0; //* return unfitted 26.6 coordinates */
ft_glyph_bbox_gridfit = 1; //* return grid-fitted 26.6 coordinates */
ft_glyph_bbox_truncate = 2; //* return coordinates in integer pixels */
ft_glyph_bbox_pixels = 3; //* return grid-fitted pixel coordinates */
FT_KERNING_DEFAULT = 0;
FT_KERNING_UNFITTED = 1;
FT_KERNING_UNSCALED = 2;
type
FT_Bool = boolean;
FT_FWord = smallint;
FT_UFWord = word;
FT_Char = char;
FT_Byte = byte;
FT_String = char;
FT_Short = smallint;
FT_UShort = word;
FT_Int = longint;
FT_UInt = longword;
FT_Long = longint;
FT_ULong = longword;
FT_F2Dot14 = smallint;
FT_F26Dot6 = longint;
FT_Fixed = longint;
FT_Error = longint;
FT_Pointer = pointer;
FT_Pos = longint;
//FT_Offset = size_t;
//FT_PtrDist = size_t;
FT_Render_Mode = (FT_RENDER_MODE_NORMAL, FT_RENDER_MODE_LIGHT,
FT_RENDER_MODE_MONO, FT_RENDER_MODE_LCD, FT_RENDER_MODE_LCD_V,
FT_RENDER_MODE_MAX);
FT_UnitVector_ = record
x : FT_F2Dot14;
y : FT_F2Dot14;
end;
FT_UnitVector = FT_UnitVector_;
FT_Matrix = record
xx : FT_Fixed;
xy : FT_Fixed;
yx : FT_Fixed;
yy : FT_Fixed;
end;
PFT_Matrix = ^FT_Matrix;
FT_Data = record
pointer : ^FT_Byte;
length : FT_Int;
end;
FT_Generic_Finalizer = procedure (AnObject:pointer);cdecl;
FT_Generic = record
data : pointer;
finalizer : FT_Generic_Finalizer;
end;
FT_Glyph_Metrics = record
width : FT_Pos;
height : FT_Pos;
horiBearingX : FT_Pos;
horiBearingY : FT_Pos;
horiAdvance : FT_Pos;
vertBearingX : FT_Pos;
vertBearingY : FT_Pos;
vertAdvance : FT_Pos;
end;
FT_Bitmap_Size = record
height : FT_Short;
width : FT_Short;
end;
AFT_Bitmap_Size = array [0..1023] of FT_Bitmap_Size;
PFT_Bitmap_Size = ^AFT_Bitmap_Size;
FT_Vector = record
x : FT_Pos;
y : FT_Pos;
end;
PFT_Vector = ^FT_Vector;
FT_BBox = record
xMin, yMin : FT_Pos;
xMax, yMax : FT_Pos;
end;
PFT_BBox = ^FT_BBox;
FT_Bitmap = record
rows : integer;
width : integer;
pitch : integer;
buffer : pointer;
num_grays : shortint;
pixel_mode : char;
palette_mode : char;
palette : pointer;
end;
FT_Outline = record
n_contours,
n_points : smallint;
points : PFT_Vector;
tags : pchar;
contours : ^smallint;
flags : integer;
end;
FT_Size_Metrics = record
x_ppem : FT_UShort;
y_ppem : FT_UShort;
x_scale : FT_Fixed;
y_scale : FT_Fixed;
ascender : FT_Pos;
descender : FT_Pos;
height : FT_Pos;
max_advance : FT_Pos;
end;
PFT_Library = ^TFT_Library;
//PPFT_Library = ^PFT_Library;
PFT_Face = ^TFT_Face;
//PPFT_Face = ^PFT_Face;
PFT_Charmap = ^TFT_Charmap;
PPFT_Charmap = ^PFT_Charmap;
PFT_GlyphSlot = ^TFT_GlyphSlot;
PFT_Subglyph = ^TFT_Subglyph;
PFT_Size = ^TFT_Size;
PFT_Glyph = ^TFT_Glyph;
//PPFT_Glyph = ^PFT_Glyph;
PFT_BitmapGlyph = ^TFT_BitmapGlyph;
PFT_OutlineGlyph = ^TFT_OutlineGlyph;
TFT_Library = record
end;
TFT_Charmap = record
face : PFT_Face;
encoding : FT_Encoding;
platform_id, encoding_id : FT_UShort;
end;
TFT_Size = record
face : PFT_Face;
generic : FT_Generic;
metrics : FT_Size_Metrics;
//internal : FT_Size_Internal;
end;
TFT_Subglyph = record // TODO
end;
TFT_GlyphSlot = record
alibrary : PFT_Library;
face : PFT_Face;
next : PFT_GlyphSlot;
flags : FT_UInt;
generic : FT_Generic;
metrics : FT_Glyph_Metrics;
linearHoriAdvance : FT_Fixed;
linearVertAdvance : FT_Fixed;
advance : FT_Vector;
format : longword;
bitmap : FT_Bitmap;
bitmap_left : FT_Int;
bitmap_top : FT_Int;
outline : FT_Outline;
num_subglyphs : FT_UInt;
subglyphs : PFT_SubGlyph;
control_data : pointer;
control_len : longint;
other : pointer;
end;
TFT_Face = record
num_faces : FT_Long;
face_index : FT_Long;
face_flags : FT_Long;
style_flags : FT_Long;
num_glyphs : FT_Long;
family_name : pchar;
style_name : pchar;
num_fixed_sizes : FT_Int;
available_sizes : PFT_Bitmap_Size; // is array
num_charmaps : FT_Int;
charmaps : PPFT_CharMap; // is array
generic : FT_Generic;
bbox : FT_BBox;
units_per_EM : FT_UShort;
ascender : FT_Short;
descender : FT_Short;
height : FT_Short;
max_advance_width : FT_Short;
max_advance_height : FT_Short;
underline_position : FT_Short;
underline_thickness : FT_Short;
glyph : PFT_GlyphSlot;
size : PFT_Size;
charmap : PFT_CharMap;
end;
TFT_Glyph = record
FTlibrary : PFT_Library;
clazz : pointer;
aFormat : longword;
advance : FT_Vector;
end;
TFT_BitmapGlyph = record
root : TFT_Glyph;
left, top : FT_Int;
bitmap : FT_Bitmap;
end;
TFT_OutlineGlyph = record
root : TFT_Glyph;
outline : FT_Outline;
end;
function FT_Init_FreeType(var alibrary:PFT_Library) : integer; cdecl; external freetypedll name 'FT_Init_FreeType';
function FT_Done_FreeType(alibrary:PFT_Library) : integer; cdecl; external freetypedll name 'FT_Done_FreeType';
procedure FT_Library_Version(alibrary:PFT_Library; var amajor,aminor,apatch:integer); cdecl; external freetypedll name 'FT_Library_Version';
function FT_New_Face(alibrary:PFT_Library; filepathname:pchar; face_index:integer; var aface:PFT_Face):integer; cdecl; external freetypedll name 'FT_New_Face';
function FT_Set_Pixel_Sizes(face:PFT_Face; pixel_width,pixel_height:FT_UInt) : integer; cdecl; external freetypedll name 'FT_Set_Pixel_Sizes';
function FT_Set_Char_Size(face:PFT_Face; char_width,char_height:FT_F26dot6;horz_res, vert_res:FT_UInt) : integer; cdecl; external freetypedll name 'FT_Set_Char_Size';
function FT_Get_Char_Index(face:PFT_Face; charcode:FT_ULong):FT_UInt; cdecl; external freetypedll name 'FT_Get_Char_Index';
function FT_Load_Glyph(face:PFT_Face; glyph_index:FT_UInt ;load_flags:longint):integer; cdecl; external freetypedll name 'FT_Load_Glyph';
function FT_Get_Kerning(face:PFT_Face; left_glyph, right_glyph, kern_mode:FT_UInt; var akerning:FT_Vector) : integer; cdecl; external freetypedll name 'FT_Get_Kerning';
function FT_Get_Glyph(slot:PFT_GlyphSlot; var aglyph:PFT_Glyph) : integer; cdecl; external freetypedll name 'FT_Get_Glyph';
function FT_Glyph_Transform(glyph:PFT_Glyph; matrix:PFT_Matrix; delta:PFT_Vector) : integer; cdecl; external freetypedll name 'FT_Glyph_Transform';
function FT_Glyph_Copy(source:PFT_Glyph; var target:PFT_Glyph): integer; cdecl; external freetypedll name 'FT_Glyph_Copy';
procedure FT_Glyph_Get_CBox(glyph:PFT_Glyph;bbox_mode:FT_UInt;var acbox:FT_BBox); cdecl; external freetypedll name 'FT_Glyph_Get_CBox';
function FT_Glyph_To_Bitmap(var the_glyph:PFT_Glyph;render_mode:FT_Render_Mode;origin:PFT_Vector; destroy:FT_Bool):integer; cdecl; external freetypedll name 'FT_Glyph_To_Bitmap';
procedure FT_Done_Glyph (glyph:PFT_Glyph); cdecl; external freetypedll name 'FT_Done_Glyph';
implementation
end.

307
fcl/image/ftfont.pp Normal file
View File

@ -0,0 +1,307 @@
{
$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 ftfont;
interface
uses classes, FPCanvas, fpimgcmn, freetype, freetypeh;
type
FreeTypeFontException = class (TFPFontException);
TFreeTypeFont = class (TFPCustomDrawFont)
private
FResolution : longword;
FAntiAliased : boolean;
FLastText : TStringBitmaps;
FIndex, FFontID : integer;
FFace : PFT_Face;
FAngle : real;
procedure DrawChar (x,y:integer; data:PByteArray; pitch, width, height:integer);
procedure DrawCharBW (x,y:integer; data:PByteArray; pitch, width, height:integer);
procedure ClearLastText;
protected
procedure SetName (AValue:string); override;
procedure SetIndex (AValue : integer);
procedure SetSize (AValue : integer); override;
function GetFlags (index:integer) : boolean; override;
procedure SetFlags (index:integer; AValue:boolean); override;
procedure DoAllocateResources; override;
procedure DoDeAllocateResources; override;
procedure DoCopyProps (From:TFPCanvasHelper); override;
procedure DoDrawText (atx,aty:integer; atext:string); override;
procedure DoGetTextSize (text:string; var w,h:integer); override;
function DoGetTextHeight (text:string) : integer; override;
function DoGetTextWidth (text:string) : integer; override;
procedure GetText (aText:string);
procedure GetFace;
public
constructor create; override;
property FontIndex : integer read FIndex write SetIndex;
property Resolution : longword read FResolution write FResolution;
property AntiAliased : boolean read FAntiAliased write FAntiAliased;
property Angle : real read FAngle write FAngle;
end;
implementation
uses sysutils, fpimage;
var
FontMgr : TFontManager;
procedure InitEngine;
begin
if not assigned (FontMgr) then
FontMgr := TFontManager.create;
end;
procedure DoneEngine;
begin
if assigned (FontMgr) then
FontMgr.Free;
end;
constructor TFreeTypeFont.Create;
begin
inherited;
FFontID := -1;
FAntiAliased := True;
FResolution := DefaultResolution;
end;
procedure TFreeTypeFont.DoCopyProps (From:TFPCanvasHelper);
var f : TFreeTypeFont;
begin
inherited;
if from is TFreeTypeFont then
begin
f := TFreeTypeFont(from);
FIndex := F.Findex;
FAntiAliased := f.FAntiAliased;
FResolution := f.FResolution;
FAngle := f.FAngle;
end;
end;
procedure TFreeTypeFont.SetName (AValue:string);
begin
inherited;
ClearLastText;
if allocated then
FFontID := FontMgr.RequestFont(Name, FIndex);
end;
procedure TFreeTypeFont.SetIndex (AValue : integer);
begin
FIndex := AValue;
ClearLastText;
if allocated then
FFontID := FontMgr.RequestFont(Name, FIndex);
end;
procedure TFreeTypeFont.SetSize (AValue : integer);
begin
ClearLastText;
inherited;
end;
procedure TFreeTypeFont.ClearLastText;
begin
if assigned(FLastText) then
begin
FLastText.Free;
FlastText := nil;
end;
end;
procedure TFreeTypeFont.DoAllocateResources;
begin
InitEngine;
FFontID := FontMgr.RequestFont(Name, FIndex);
end;
procedure TFreeTypeFont.DoDeAllocateResources;
begin
end;
procedure TFreeTypeFont.DoGetTextSize (text:string; var w,h:integer);
var r : TRect;
begin
GetText (text);
FLastText.GetBoundRect (r);
with r do
begin
w := right - left;
h := top - bottom;
end;
end;
function TFreeTypeFont.DoGetTextHeight (text:string) : integer;
var r : TRect;
begin
GetText (text);
FLastText.GetBoundRect (r);
with r do
result := top - bottom;
end;
function TFreeTypeFont.DoGetTextWidth (text:string) : integer;
var r : TRect;
begin
GetText (text);
FLastText.GetBoundRect (r);
with r do
result := right - left;
end;
procedure TFreeTypeFont.SetFlags (index:integer; AValue:boolean);
begin
if not (index in [5,6]) then // bold,italic
inherited SetFlags (index, AValue);
end;
procedure TFreeTypeFont.GetFace;
begin
if not assigned(FFace) then
FFace := FontMgr.GetFreeTypeFont (FFontID);
end;
function TFreeTypeFont.GetFlags (index:integer) : boolean;
begin
if index = 5 then //bold
begin
GetFace;
result := (FFace^.style_flags and FT_STYLE_FLAG_BOLD) <> 0;
end
else if index = 6 then //italic
begin
GetFace;
result := (FFace^.style_flags and FT_STYLE_FLAG_ITALIC) <> 0;
end
else
result := inherited GetFlags (index);
end;
procedure TFreeTypeFont.GetText (aText:string);
var b : boolean;
begin
if assigned (FLastText) then
begin
if CompareStr(FLastText.Text,aText) <> 0 then
begin
FLastText.Free;
b := true;
end
else
begin
if FAntiAliased then
b := (FLastText.mode <> bt256Gray)
else
b := (FLastText.mode <> btBlackWhite);
if b then
FLastText.Free;
end;
end
else
b := true;
if b then
begin
FontMgr.Resolution := FResolution;
if FAntiAliased then
FLastText := FontMgr.GetStringGray (FFontId, aText, Size, Angle)
else
FLastText := FontMgr.GetString (FFontId, aText, Size, Angle);
end;
end;
procedure TFreeTypeFont.DoDrawText (atX,atY:integer; atext:string);
var r,i : integer;
f : longint;
begin
GetText (atext);
with FLastText do
for r := 0 to count-1 do
with Bitmaps[r]^ do
begin
if mode = btBlackWhite then
DrawCharBW (atX+x, atY+y, data, pitch, width, height)
else
DrawChar (atX+x, atY+y, data, pitch, width, height);
end;
end;
const
//bits : array[0..7] of byte = (1,2,4,8,16,32,64,128);
bits : array[0..7] of byte = (128,64,32,16,8,4,2,1);
procedure TFreeTypeFont.DrawChar (x,y:integer; data:PByteArray; pitch, width, height:integer);
procedure Combine (canv:TFPCustomCanvas; x,y:integer; c : TFPColor; t:longword);
var a,r,g,b:longword;
begin
if t = 255 then
canv.colors[x,y] := c
else if t <> 0 then
begin
with canv.colors[x,y] do
begin
a := 255-t;
r := ((red * a) + (c.red * t)) div 255;
g := ((green * a) + (c.green * t)) div 255;
b := ((blue * a) + (c.blue * t)) div 255;
end;
canv.colors[x,y] := FPcolor(r,g,b,alphaOpaque);
end;
end;
var b,rx,ry : integer;
begin
b := 0;
for ry := 0 to height-1 do
begin
for rx := 0 to width-1 do
combine (canvas, x+rx, y+ry, color, data^[b+rx]);
inc (b, pitch);
end;
end;
procedure TFreeTypeFont.DrawCharBW (x,y:integer; data:PByteArray; pitch, width, height:integer);
var rb : byte;
rx,ry,b,l : integer;
begin
b := 0;
for ry := 0 to height-1 do
begin
l := 0;
for rx := 0 to width-1 do
begin
rb := rx mod 8;
if (data^[b+l] and bits[rb]) <> 0 then
canvas.colors[x+rx,y+ry] := color;
if rb = 7 then
inc (l);
end;
inc (b, pitch);
end;
end;
finalization
DoneEngine;
end.