mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-05 02:43:49 +02:00
2643 lines
78 KiB
ObjectPascal
2643 lines
78 KiB
ObjectPascal
{
|
|
*****************************************************************************
|
|
This file is part of LazUtils.
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
|
|
to do :
|
|
|
|
- multiple font loading
|
|
- font face cache
|
|
- text rotation
|
|
}
|
|
unit EasyLazFreeType;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, fpimage, AVL_Tree,
|
|
// LazUtils
|
|
LazUTF8,
|
|
// FreeType
|
|
LazFreeType, TTRASTER, TTTypes, TTObjs,
|
|
Types; // Note: Types must be after TTTypes for PByte.
|
|
|
|
type
|
|
TGlyphRenderQuality = (grqMonochrome, grqLowQuality, grqHighQuality);
|
|
ArrayOfSingle= array of single;
|
|
TCharPosition= record
|
|
x,width,
|
|
yTop,yBase,yBottom: single;
|
|
end;
|
|
ArrayOfCharPosition = array of TCharPosition;
|
|
TFreeTypeAlignment = (ftaLeft,ftaCenter,ftaRight,ftaJustify,ftaTop,ftaVerticalCenter,ftaBaseline,ftaBottom);
|
|
TFreeTypeAlignments = set of TFreeTypeAlignment;
|
|
|
|
TFreeTypeInformation = (ftiCopyrightNotice, ftiFamily, ftiStyle, ftiIdentifier, ftiFullName,
|
|
ftiVersionString, ftiPostscriptName, ftiTrademark, ftiManufacturer, ftiDesigner,
|
|
ftiVendorURL, ftiDesignerURL, ftiLicenseDescription, ftiLicenseInfoURL);
|
|
|
|
TFreeTypeStyle = (ftsBold, ftsItalic);
|
|
TFreeTypeStyles = set of TFreeTypeStyle;
|
|
TFreeTypeWordBreakHandler = procedure(var ABefore, AAfter: string) of object;
|
|
|
|
const
|
|
FreeTypeInformationStr : array[TFreeTypeInformation] of string =
|
|
('Copyright notice', 'Family', 'Style', 'Identifier', 'Full name',
|
|
'Version string', 'Postscript name', 'Trademark', 'Manufacturer', 'Designer',
|
|
'Vendor URL', 'Designer URL', 'License description', 'License info URL');
|
|
|
|
type
|
|
TFreeTypeGlyph = class;
|
|
TFreeTypeFont = class;
|
|
TFreeTypeKerning = record
|
|
Kerning, Minimum: TPointF;
|
|
Found: boolean;
|
|
end;
|
|
|
|
EFreeType = class(Exception);
|
|
|
|
TFontCollectionItemDestroyProc = procedure() of object;
|
|
TFontCollectionItemDestroyListener = record
|
|
TargetObject: TObject;
|
|
NotifyProc: TFontCollectionItemDestroyProc;
|
|
end;
|
|
|
|
function FontCollectionItemDestroyListener(ATargetObject: TObject; ANotifyProc: TFontCollectionItemDestroyProc): TFontCollectionItemDestroyListener;
|
|
|
|
type
|
|
ArrayOfFontCollectionItemDestroyListener = array of TFontCollectionItemDestroyListener;
|
|
TCustomFamilyCollectionItem = class;
|
|
|
|
{ TCustomFontCollectionItem }
|
|
|
|
TCustomFontCollectionItem = class
|
|
protected
|
|
FFamily: TCustomFamilyCollectionItem;
|
|
function GetBold: boolean; virtual; abstract;
|
|
function GetInformation(AIndex: TFreeTypeInformation): string; virtual; abstract;
|
|
function GetItalic: boolean; virtual; abstract;
|
|
function GetStyleCount: integer; virtual; abstract;
|
|
function GetStyles: string; virtual; abstract;
|
|
function GetFilename: string; virtual; abstract;
|
|
function GetVersionNumber: string; virtual; abstract;
|
|
function GetStyle(AIndex: integer): string; virtual; abstract;
|
|
procedure NotifyDestroy; virtual; abstract;
|
|
public
|
|
function HasStyle(AStyle: string): boolean; virtual; abstract;
|
|
function CreateFont: TFreeTypeFont; virtual; abstract;
|
|
function QueryFace(AListener: TFontCollectionItemDestroyListener): TT_Face; virtual; abstract;
|
|
procedure ReleaseFace(AListener: TFontCollectionItemDestroyListener); virtual; abstract;
|
|
|
|
property Styles: string read GetStyles;
|
|
property Italic: boolean read GetItalic;
|
|
property Bold: boolean read GetBold;
|
|
property Filename: string read GetFilename;
|
|
property Information[AIndex: TFreeTypeInformation]: string read GetInformation;
|
|
property VersionNumber: string read GetVersionNumber;
|
|
property Style[AIndex: integer]: string read GetStyle;
|
|
property StyleCount: integer read GetStyleCount;
|
|
property Family: TCustomFamilyCollectionItem read FFamily write FFamily;
|
|
end;
|
|
|
|
IFreeTypeFontEnumerator = interface
|
|
function MoveNext: boolean;
|
|
function GetCurrent: TCustomFontCollectionItem;
|
|
property Current: TCustomFontCollectionItem read GetCurrent;
|
|
end;
|
|
|
|
{ TCustomFamilyCollectionItem }
|
|
|
|
TCustomFamilyCollectionItem = class
|
|
protected
|
|
function GetFontByIndex(AIndex: integer): TCustomFontCollectionItem; virtual; abstract;
|
|
function GetStyle(AIndex: integer): string; virtual; abstract;
|
|
function GetStyles: string; virtual; abstract;
|
|
function GetFamilyName: string; virtual; abstract;
|
|
function GetFontCount: integer; virtual; abstract;
|
|
function GetStyleCount: integer; virtual; abstract;
|
|
public
|
|
function GetFont(const AStyles: array of string; NeedAllStyles: boolean = false; NoMoreStyle: boolean = false): TCustomFontCollectionItem; virtual; abstract; overload;
|
|
function GetFont(AStyle: string; NeedAllStyles: boolean = false; NoMoreStyle: boolean = false): TCustomFontCollectionItem; virtual; abstract; overload;
|
|
function GetFontIndex(const AStyles: array of string; NeedAllStyles: boolean = false; NoMoreStyle: boolean = false): integer; virtual; abstract; overload;
|
|
function GetFontIndex(AStyle: string; NeedAllStyles: boolean = false; NoMoreStyle: boolean = false): integer; virtual; abstract; overload;
|
|
function HasStyle(AName: string): boolean; virtual; abstract;
|
|
property FamilyName: string read GetFamilyName;
|
|
property Font[AIndex: integer]: TCustomFontCollectionItem read GetFontByIndex;
|
|
property FontCount: integer read GetFontCount;
|
|
property Style[AIndex: integer]: string read GetStyle;
|
|
property StyleCount: integer read GetStyleCount;
|
|
property Styles: string read GetStyles;
|
|
end;
|
|
|
|
IFreeTypeFamilyEnumerator = interface
|
|
function MoveNext: boolean;
|
|
function GetCurrent: TCustomFamilyCollectionItem;
|
|
property Current: TCustomFamilyCollectionItem read GetCurrent;
|
|
end;
|
|
|
|
{ TCustomFreeTypeFontCollection }
|
|
|
|
TCustomFreeTypeFontCollection = class
|
|
protected
|
|
function GetFont(AFileName: string): TCustomFontCollectionItem; virtual; abstract;
|
|
function GetFamily(AName: string): TCustomFamilyCollectionItem; virtual; abstract;
|
|
function GetFamilyCount: integer; virtual; abstract;
|
|
function GetFontCount: integer; virtual; abstract;
|
|
public
|
|
constructor Create; virtual; abstract;
|
|
procedure Clear; virtual; abstract;
|
|
procedure BeginUpdate; virtual; abstract;
|
|
procedure AddFolder(AFolder: string; AIncludeSubdirs: Boolean = false); virtual; abstract;
|
|
procedure RemoveFolder(AFolder: string); virtual; abstract;
|
|
function AddFile(AFilename: string): TCustomFontCollectionItem; virtual; abstract;
|
|
function RemoveFile(AFilename: string): boolean; virtual; abstract;
|
|
function AddStream(AStream: TStream; AOwned: boolean): boolean; virtual; abstract;
|
|
procedure EndUpdate; virtual; abstract;
|
|
function FontFileEnumerator: IFreeTypeFontEnumerator; virtual; abstract;
|
|
function FamilyEnumerator: IFreeTypeFamilyEnumerator; virtual; abstract;
|
|
property FontFileCount: integer read GetFontCount;
|
|
property FontFile[AFileName: string]: TCustomFontCollectionItem read GetFont;
|
|
property FamilyCount: integer read GetFamilyCount;
|
|
property Family[AName: string]: TCustomFamilyCollectionItem read GetFamily;
|
|
end;
|
|
|
|
{***************************** Rendering classes *********************************}
|
|
|
|
TOnRenderTextHandler = procedure(AText: string; x,y: single) of object;
|
|
|
|
{ TFreeTypeRenderableFont }
|
|
|
|
TFreeTypeRenderableFont = class
|
|
protected
|
|
FWordBreakHandler: TFreeTypeWordBreakHandler;
|
|
FOnRenderText: TOnRenderTextHandler;
|
|
function GetClearType: boolean; virtual; abstract;
|
|
procedure SetClearType(const AValue: boolean); virtual; abstract;
|
|
function GetLineFullHeight: single; virtual; abstract;
|
|
function GetAscent: single; virtual; abstract;
|
|
function GetDescent: single; virtual; abstract;
|
|
function GetLineSpacing: single; virtual; abstract;
|
|
procedure DefaultWordBreakHandler(var ABefore, AAfter: string);
|
|
function GetHinted: boolean; virtual; abstract;
|
|
procedure SetHinted(const AValue: boolean); virtual; abstract;
|
|
public
|
|
UnderlineDecoration,StrikeOutDecoration: boolean;
|
|
Orientation: integer;
|
|
function TextWidth(AText: string): single; virtual; abstract;
|
|
function TextHeight(AText: string): single; virtual; abstract;
|
|
function CharWidthFromUnicode(AUnicode: integer): single; virtual; abstract;
|
|
procedure SplitText(var AText: string; AMaxWidth: single; out ARemains: string);
|
|
procedure GetTextSize(AText: string; out w,h: single); virtual;
|
|
procedure RenderText(AText: string; x,y: single; ARect: TRect; OnRender : TDirectRenderingFunction); virtual; abstract;
|
|
property ClearType: boolean read GetClearType write SetClearType;
|
|
property Ascent: single read GetAscent;
|
|
property Descent: single read GetDescent;
|
|
property LineSpacing: single read GetLineSpacing;
|
|
property LineFullHeight: single read GetLineFullHeight;
|
|
property Hinted: boolean read GetHinted write SetHinted;
|
|
property OnWordBreak: TFreeTypeWordBreakHandler read FWordBreakHandler write FWordBreakHandler;
|
|
property OnRenderText: TOnRenderTextHandler read FOnRenderText write FOnRenderText;
|
|
end;
|
|
|
|
{ TFreeTypeDrawer }
|
|
|
|
TFreeTypeDrawer = class
|
|
procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor; AOpacity: Byte); virtual; overload;
|
|
procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor; AOpacity: Byte; AAlign: TFreeTypeAlignments); virtual; overload;
|
|
procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); virtual; abstract; overload;
|
|
procedure DrawText(AText: string; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor; AAlign: TFreeTypeAlignments); virtual; overload;
|
|
procedure DrawTextWordBreak(AText: string; AFont: TFreeTypeRenderableFont; x, y, AMaxWidth: Single; AColor: TFPColor; AAlign: TFreeTypeAlignments);
|
|
procedure DrawTextRect(AText: string; AFont: TFreeTypeRenderableFont; X1,Y1,X2,Y2: Single; AColor: TFPColor; AAlign: TFreeTypeAlignments);
|
|
procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor); virtual; abstract; overload;
|
|
procedure DrawGlyph(AGlyph: integer; AFont: TFreeTypeRenderableFont; x,y: single; AColor: TFPColor; AAlign: TFreeTypeAlignments); virtual; overload;
|
|
end;
|
|
|
|
{********************************* Font implementation **********************************}
|
|
|
|
{ TFreeTypeFont }
|
|
|
|
TFreeTypeFont = class(TFreeTypeRenderableFont)
|
|
private
|
|
FName: String;
|
|
FFaceChanged: boolean;
|
|
FDPI: integer;
|
|
FStream: TStream;
|
|
FOwnedStream: boolean;
|
|
FPointSize: single;
|
|
FHinted: boolean;
|
|
FKerningEnabled, FKerningFallbackEnabled: boolean;
|
|
FStyleStr: string;
|
|
FWidthFactor: single;
|
|
FClearType: boolean;
|
|
FNamesArray: array of string;
|
|
FCollection: TCustomFreeTypeFontCollection;
|
|
function FindGlyphNode(Index: Integer): TAvlTreeNode;
|
|
function GetCharIndex(AUnicodeChar: integer): integer;
|
|
function GetDPI: integer;
|
|
function GetFamily: string;
|
|
function GetFreeTypeStyles: TFreeTypeStyles;
|
|
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);
|
|
procedure SetFreeTypeStyles(AValue: TFreeTypeStyles);
|
|
procedure SetLineFullHeight(AValue: single);
|
|
procedure SetStyleAsString(AValue: string);
|
|
procedure LoadFace;
|
|
procedure SetName(const AValue: String);
|
|
procedure DiscardFace;
|
|
procedure DiscardInstance;
|
|
procedure DiscardStream;
|
|
procedure SetPixelSize(const AValue: single);
|
|
procedure SetPointSize(AValue: single);
|
|
function LoadGlyphInto(_glyph : TT_Glyph;
|
|
glyph_index : Word): boolean;
|
|
procedure SetWidthFactor(const AValue: single);
|
|
procedure UpdateInstance;
|
|
procedure UpdateSizeInPoints;
|
|
procedure UpdateMetrics;
|
|
procedure UpdateCharmap;
|
|
procedure RenderTextDecoration(AText: string; x,y: single; ARect: TRect; OnRender : TDirectRenderingFunction);
|
|
procedure FillRect(ARect: TRect; OnRender : TDirectRenderingFunction);
|
|
protected
|
|
FFace: TT_Face;
|
|
FFaceItem: TCustomFontCollectionItem;
|
|
FFaceLoaded: boolean;
|
|
FInstance: TT_Instance;
|
|
FInstanceCreated : boolean;
|
|
FGlyphTable: TAvlTree;
|
|
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;
|
|
function GetLineFullHeight: single; override;
|
|
function GetAscent: single; override;
|
|
function GetDescent: single; override;
|
|
function GetLineSpacing: single; override;
|
|
function GetCapHeight: single;
|
|
procedure SetHinted(const AValue: boolean); override;
|
|
function GetHinted: boolean; override;
|
|
procedure OnDestroyFontItem;
|
|
procedure FetchNames;
|
|
function GetCollection: TCustomFreeTypeFontCollection;
|
|
function CheckFace: boolean;
|
|
public
|
|
Quality : TGlyphRenderQuality;
|
|
SmallLinePadding: boolean;
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure AccessFromStream(AStream: TStream; AStreamOwner: boolean);
|
|
procedure RenderText(AText: string; x,y: single; ARect: TRect; OnRender : TDirectRenderingFunction); override;
|
|
procedure RenderGlyph(AGlyph: Integer; x,y: single; ARect: TRect; OnRender : TDirectRenderingFunction);
|
|
procedure SetNameAndStyle(AName: string; AStyle: string); overload;
|
|
procedure SetNameAndStyle(AName: string; AStyle: TFreeTypeStyles); overload;
|
|
function TextWidth(AText: string): single; override;
|
|
function TextHeight(AText: string): single; override;
|
|
function CharWidthFromUnicode(AUnicodeChar: integer): single; override;
|
|
function CharWidthFromGlyph(AGlyph: integer): single;
|
|
function CharsWidth(AText: string): ArrayOfSingle;
|
|
function CharsPosition(AText: string): ArrayOfCharPosition; overload;
|
|
function CharsPosition(AText: string; AAlign: TFreeTypeAlignments): ArrayOfCharPosition; overload;
|
|
function CheckInstance: boolean;
|
|
property Name: String read FName write SetName;
|
|
property DPI: integer read GetDPI write SetDPI;
|
|
property SizeInPoints: single read FPointSize write SetPointSize;
|
|
property SizeInPixels: single read GetPixelSize write SetPixelSize;
|
|
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;
|
|
property VersionNumber: string read GetVersionNumber;
|
|
property Family: string read GetFamily;
|
|
property Collection: TCustomFreeTypeFontCollection read GetCollection write FCollection;
|
|
property StyleAsString: string read FStyleStr write SetStyleAsString;
|
|
property Style: TFreeTypeStyles read GetFreeTypeStyles write SetFreeTypeStyles;
|
|
end;
|
|
|
|
{ TFreeTypeGlyph }
|
|
|
|
TFreeTypeGlyph = class
|
|
private
|
|
FLoaded: boolean;
|
|
FGlyphData: TT_Glyph;
|
|
FIndex: integer;
|
|
FOrientation: Integer;
|
|
function GetAdvance: single;
|
|
function GetBounds: TRect;
|
|
function GetBoundsWithOffset(x, y: single): TRect;
|
|
{%H-}constructor create;
|
|
public
|
|
constructor Create(AFont: TFreeTypeFont; AIndex: integer);
|
|
function RenderDirectly(x,y: single; Rect: TRect; OnRender : TDirectRenderingFunction; quality : TGlyphRenderQuality; ClearType: boolean = false): boolean;
|
|
function RenderDirectly(ARasterizer: TFreeTypeRasterizer; x,y: single; Rect: TRect; OnRender : TDirectRenderingFunction; quality : TGlyphRenderQuality; ClearType: boolean = false): boolean;
|
|
function Clone(AOrientation:Integer): TFreeTypeGlyph;
|
|
destructor Destroy; override;
|
|
property Loaded: boolean read FLoaded;
|
|
property Data: TT_Glyph read FGlyphData;
|
|
property Index: integer read FIndex;
|
|
property Bounds: TRect read GetBounds;
|
|
property BoundsWithOffset[x,y: single]: TRect read GetBoundsWithOffset;
|
|
property Advance: single read GetAdvance;
|
|
end;
|
|
|
|
{ TFreeTypeRasterMap }
|
|
|
|
TFreeTypeRasterMap = class
|
|
protected
|
|
map: TT_Raster_Map;
|
|
FRasterizer: TFreeTypeRasterizer;
|
|
function GetHeight: integer; virtual;
|
|
function GetWidth: integer; virtual;
|
|
function GetScanLine(y: integer): pointer;
|
|
procedure Init(AWidth,AHeight: integer); virtual; abstract;
|
|
public
|
|
constructor Create(AWidth,AHeight: integer); virtual;
|
|
constructor Create(ARasterizer: TFreeTypeRasterizer; AWidth,AHeight: integer); virtual;
|
|
procedure Clear;
|
|
procedure Fill;
|
|
function RenderGlyph(glyph : TFreeTypeGlyph; x,y: single) : boolean; virtual; abstract;
|
|
procedure ScanMoveTo(x,y: integer); virtual; abstract;
|
|
destructor Destroy; override;
|
|
|
|
property Width: integer read GetWidth;
|
|
property Height: integer read GetHeight;
|
|
property ScanLine[y: integer]: pointer read GetScanLine;
|
|
end;
|
|
|
|
{ TFreeTypeMonochromeMap }
|
|
|
|
TFreeTypeMonochromeMap = class(TFreeTypeRasterMap)
|
|
private
|
|
ScanPtrStart,ScanPtrCur: pbyte;
|
|
ScanBit: byte;
|
|
ScanX: integer;
|
|
function GetPixelsInHorizlineNoBoundsChecking(x,y,x2: integer) : integer; inline;
|
|
protected
|
|
procedure Init(AWidth,AHeight: integer); override;
|
|
public
|
|
function RenderGlyph(glyph : TFreeTypeGlyph; x,y: single) : boolean; override;
|
|
procedure ScanMoveTo(x,y: integer); override;
|
|
function ScanNextPixel: boolean;
|
|
function GetPixel(x,y: integer): boolean;
|
|
procedure SetPixel(x,y: integer; value: boolean);
|
|
function GetPixelsInRect(x,y,x2,y2: integer): integer;
|
|
function GetPixelsInHorizline(x,y,x2: integer): integer;
|
|
procedure TogglePixel(x,y: integer);
|
|
end;
|
|
|
|
{ TFreeTypeGrayscaleMap }
|
|
|
|
TFreeTypeGrayscaleMap = class(TFreeTypeRasterMap)
|
|
private
|
|
ScanPtrStart: pbyte;
|
|
ScanX: integer;
|
|
protected
|
|
procedure Init(AWidth, AHeight: integer); override;
|
|
public
|
|
RenderQuality: TGlyphRenderQuality;
|
|
function RenderGlyph(glyph : TFreeTypeGlyph; x,y: single) : boolean; override;
|
|
procedure ScanMoveTo(x,y: integer); override;
|
|
function ScanNextPixel: byte;
|
|
function GetPixel(x,y: integer): byte;
|
|
procedure SetPixel(x,y: integer; value: byte);
|
|
procedure XorPixel(x,y: integer; value: byte);
|
|
end;
|
|
|
|
var
|
|
FontCollection: TCustomFreeTypeFontCollection;
|
|
|
|
type
|
|
ArrayOfString = array of string;
|
|
|
|
function StylesToArray(AStyles: string): ArrayOfString;
|
|
|
|
const FreeTypeMinPointSize = 1;
|
|
|
|
implementation
|
|
|
|
uses Math;
|
|
|
|
const
|
|
TT_PLATFORM_APPLE_UNICODE = 0;
|
|
//TT_PLATFORM_MACINTOSH = 1;
|
|
TT_PLATFORM_ISO = 2; // deprecated
|
|
TT_PLATFORM_MICROSOFT = 3;
|
|
//TT_PLATFORM_CUSTOM = 4;
|
|
//TT_PLATFORM_ADOBE = 7; // artificial
|
|
|
|
function FontCollectionItemDestroyListener(ATargetObject: TObject;
|
|
ANotifyProc: TFontCollectionItemDestroyProc
|
|
): TFontCollectionItemDestroyListener;
|
|
begin
|
|
result.TargetObject := ATargetObject;
|
|
result.NotifyProc := ANotifyProc;
|
|
end;
|
|
|
|
function StylesToArray(AStyles: string): ArrayOfString;
|
|
var
|
|
StartIndex, EndIndex: integer;
|
|
Count: integer;
|
|
|
|
procedure AddStyle(AName: string);
|
|
begin
|
|
if (AName = 'Normal') or (AName = 'Regular') or (AName = 'Roman') or (AName = 'Plain') or (AName = 'Book') then exit;
|
|
if Count = length(result) then
|
|
setlength(result, length(result)+4);
|
|
result[Count] := AName;
|
|
inc(Count);
|
|
end;
|
|
|
|
begin
|
|
Count := 0;
|
|
result := nil;
|
|
StartIndex := 1;
|
|
while StartIndex <= length(AStyles) do
|
|
begin
|
|
while (StartIndex < length(AStyles)) and (AStyles[StartIndex] = ' ') do inc(StartIndex);
|
|
if AStyles[StartIndex] <> ' ' then
|
|
begin
|
|
EndIndex := StartIndex;
|
|
while (EndIndex < length(AStyles)) and (AStyles[EndIndex+1] <> ' ') do inc(EndIndex);
|
|
AddStyle(copy(AStyles, StartIndex, EndIndex-StartIndex+1));
|
|
StartIndex := EndIndex+1;
|
|
end;
|
|
end;
|
|
setlength(result,Count);
|
|
end;
|
|
|
|
var
|
|
BitCountTable: packed array[0..255] of byte;
|
|
RegularGray5: TT_Gray_Palette;
|
|
FreeTypeInitialized,FreeTypeCannotInitialize : boolean;
|
|
|
|
procedure EnsureFreeTypeInitialized;
|
|
begin
|
|
if not FreeTypeInitialized and not FreeTypeCannotInitialize then
|
|
begin
|
|
FreeTypeInitialized := (TT_Init_FreeType = TT_Err_Ok);
|
|
FreeTypeCannotInitialize := not FreeTypeInitialized;
|
|
end;
|
|
if FreeTypeCannotInitialize then
|
|
raise EFreeType.Create('FreeType cannot be initialized');
|
|
end;
|
|
|
|
function GlyphTableOnCompare(Item1, Item2: Pointer): Integer;
|
|
var
|
|
G1: TFreeTypeGlyph absolute Item1;
|
|
G2: TFreeTypeGlyph absolute Item2;
|
|
begin
|
|
if G1.Index > G2.Index then
|
|
Result := 1
|
|
else if G1.Index < G2.Index then
|
|
Result := -1
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{ TFreeTypeRenderableFont }
|
|
|
|
procedure TFreeTypeRenderableFont.DefaultWordBreakHandler(var ABefore, AAfter: string);
|
|
var p: integer;
|
|
begin
|
|
if (AAfter <> '') and (ABefore <> '') and (AAfter[1]<> ' ') and (ABefore[length(ABefore)] <> ' ') then
|
|
begin
|
|
p := length(ABefore);
|
|
while (p > 1) and (ABefore[p-1] <> ' ') do dec(p);
|
|
if p > 1 then //can put the word after
|
|
begin
|
|
AAfter := copy(ABefore,p,length(ABefore)-p+1)+AAfter;
|
|
SetLength(ABefore, p-1);
|
|
end else
|
|
begin //cannot put the word after, so before
|
|
|
|
end;
|
|
end;
|
|
while (ABefore <> '') and (ABefore[length(ABefore)] =' ') do
|
|
SetLength(ABefore, length(ABefore)-1);
|
|
while (AAfter <> '') and (AAfter[1] =' ') do
|
|
Delete(AAfter,1,1);
|
|
end;
|
|
|
|
procedure TFreeTypeRenderableFont.SplitText(var AText: string;
|
|
AMaxWidth: single; out ARemains: string);
|
|
var
|
|
pstr: pchar;
|
|
left,charlen: integer;
|
|
totalWidth: single;
|
|
firstChar: boolean;
|
|
glyphWidth: single;
|
|
glyphCode: cardinal;
|
|
|
|
procedure WordBreak(ADropCount: Integer = 0);
|
|
begin
|
|
ARemains:= copy(AText, length(AText) - left + 1 + ADropCount, left);
|
|
SetLength(AText, length(AText) - left);
|
|
end;
|
|
|
|
begin
|
|
ARemains := '';
|
|
if AText = '' then
|
|
exit;
|
|
totalWidth := 0;
|
|
pstr := @AText[1];
|
|
left := length(AText);
|
|
firstChar := true;
|
|
while left > 0 do
|
|
begin
|
|
if pstr[0] in [#13, #10] then
|
|
begin
|
|
if (left > 1) and ([pstr[0], pstr[1]] = [#13, #10]) then
|
|
WordBreak(2)
|
|
else
|
|
WordBreak(1);
|
|
exit;
|
|
end;
|
|
|
|
charlen := UTF8CodepointSize(pstr);
|
|
glyphCode := UTF8CodepointToUnicode(pstr, charlen);
|
|
inc(pstr,charlen);
|
|
|
|
glyphWidth := CharWidthFromUnicode(glyphCode);
|
|
if glyphWidth <> 0 then
|
|
begin
|
|
totalWidth += glyphWidth;
|
|
if (totalWidth > AMaxWidth) and not firstChar then
|
|
begin
|
|
WordBreak;
|
|
if Assigned(FWordBreakHandler) then
|
|
FWordBreakHandler(AText,ARemains)
|
|
else
|
|
DefaultWordBreakHandler(AText,ARemains);
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
dec(left,charlen);
|
|
firstChar := false;
|
|
end;
|
|
ARemains := ''; //no split
|
|
end;
|
|
|
|
procedure TFreeTypeRenderableFont.GetTextSize(AText: string; out w, h: single);
|
|
begin
|
|
w := TextWidth(AText);
|
|
h := TextHeight(AText);
|
|
end;
|
|
|
|
{ TFreeTypeDrawer }
|
|
|
|
procedure TFreeTypeDrawer.DrawText(AText: string;
|
|
AFont: TFreeTypeRenderableFont; x, y: single; AColor: TFPColor; AOpacity: Byte);
|
|
var col: TFPColor;
|
|
begin
|
|
col := AColor;
|
|
col.alpha := col.alpha*AOpacity div 255;
|
|
DrawText(AText, AFont, x,y, col, []);
|
|
end;
|
|
|
|
procedure TFreeTypeDrawer.DrawText(AText: string;
|
|
AFont: TFreeTypeRenderableFont; x, y: single; AColor: TFPColor; AOpacity: Byte; AAlign: TFreeTypeAlignments);
|
|
var col: TFPColor;
|
|
begin
|
|
col := AColor;
|
|
col.alpha := col.alpha*AOpacity div 255;
|
|
DrawText(AText, AFont, x,y, col, AAlign);
|
|
end;
|
|
|
|
procedure TFreeTypeDrawer.DrawText(AText: string;
|
|
AFont: TFreeTypeRenderableFont; x, y: single; AColor: TFPColor; AAlign: TFreeTypeAlignments);
|
|
var idx : integer;
|
|
delta: single;
|
|
begin
|
|
if not (ftaBaseline in AAlign) then
|
|
begin
|
|
if ftaTop in AAlign then
|
|
y += AFont.Ascent else
|
|
if ftaBottom in AAlign then
|
|
y += AFont.Ascent - AFont.TextHeight(AText) else
|
|
if ftaVerticalCenter in AAlign then
|
|
y += AFont.Ascent - AFont.TextHeight(AText)*0.5;
|
|
end;
|
|
AAlign -= [ftaTop,ftaBaseline,ftaBottom,ftaVerticalCenter];
|
|
|
|
idx := pos(LineEnding, AText);
|
|
while idx <> 0 do
|
|
begin
|
|
DrawText(copy(AText,1,idx-1), AFont, x,y, AColor, AAlign);
|
|
delete(AText,1,idx+length(LineEnding)-1);
|
|
idx := pos(LineEnding, AText);
|
|
y += AFont.LineFullHeight;
|
|
end;
|
|
|
|
if not (ftaLeft in AAlign) then
|
|
begin
|
|
delta := 0;
|
|
if ftaCenter in AAlign then
|
|
delta := -AFont.TextWidth(AText)/2 else
|
|
if ftaRight in AAlign then
|
|
delta := -AFont.TextWidth(AText);
|
|
if AFont.Hinted then delta := round(delta);
|
|
x += delta;
|
|
end;
|
|
DrawText(AText, AFont, x,y, AColor);
|
|
end;
|
|
|
|
procedure TFreeTypeDrawer.DrawTextWordBreak(AText: string;
|
|
AFont: TFreeTypeRenderableFont; x, y, AMaxWidth: Single;
|
|
AColor: TFPColor; AAlign: TFreeTypeAlignments);
|
|
var ARemains: string;
|
|
stepX,stepY: single;
|
|
lines: TStringList;
|
|
i: integer;
|
|
lineShift: single;
|
|
lineAlignment: TFreeTypeAlignments;
|
|
begin
|
|
if (AText = '') or (AMaxWidth <= 0) then exit;
|
|
|
|
stepX := 0;
|
|
stepY := AFont.LineFullHeight;
|
|
|
|
AAlign -= [ftaBaseline]; //ignored
|
|
if AAlign * [ftaTop,ftaVerticalCenter,ftaBottom] = [] then AAlign += [ftaTop]; //top by default
|
|
lineAlignment := AAlign * [ftaLeft,ftaCenter,ftaRight] + [ftaVerticalCenter];
|
|
|
|
if ftaTop in AAlign then
|
|
begin
|
|
lineShift := 0.5;
|
|
X += stepX*lineShift;
|
|
Y += stepY*lineShift;
|
|
repeat
|
|
AFont.SplitText(AText, AMaxWidth, ARemains);
|
|
DrawText(AText,AFont,X,Y,AColor,lineAlignment);
|
|
AText := ARemains;
|
|
X+= stepX;
|
|
Y+= stepY;
|
|
until ARemains = '';
|
|
end else
|
|
begin
|
|
lines := TStringList.Create;
|
|
repeat
|
|
AFont.SplitText(AText, AMaxWidth, ARemains);
|
|
lines.Add(AText);
|
|
AText := ARemains;
|
|
until ARemains = '';
|
|
if ftaVerticalCenter in AAlign then lineShift := lines.Count/2-0.5
|
|
else if ftaBottom in AAlign then lineShift := lines.Count-0.5
|
|
else lineShift := -0.5;
|
|
|
|
X -= stepX*lineShift;
|
|
Y -= stepY*lineShift;
|
|
for i := 0 to lines.Count-1 do
|
|
begin
|
|
DrawText(lines[i],AFont,X,Y,AColor,lineAlignment);
|
|
X+= stepX;
|
|
Y+= stepY;
|
|
end;
|
|
lines.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeDrawer.DrawTextRect(AText: string;
|
|
AFont: TFreeTypeRenderableFont; X1, Y1, X2, Y2: Single; AColor: TFPColor;
|
|
AAlign: TFreeTypeAlignments);
|
|
var X,Y: single;
|
|
begin
|
|
if X2 <= X1 then exit;
|
|
if ftaVerticalCenter in AAlign then Y := (Y1+Y2)/2 else
|
|
if ftaBottom in AAlign then Y := Y2 else
|
|
Y := Y1;
|
|
if ftaCenter in AAlign then X := (X1+X2)/2 else
|
|
if ftaRight in AAlign then X := X2 else
|
|
X := X1;
|
|
DrawTextWordBreak(AText,AFont,X,Y,X2-X1,AColor,AAlign);
|
|
end;
|
|
|
|
procedure TFreeTypeDrawer.DrawGlyph(AGlyph: integer;
|
|
AFont: TFreeTypeRenderableFont; x, y: single; AColor: TFPColor;
|
|
AAlign: TFreeTypeAlignments);
|
|
var f: TFreeTypeFont;
|
|
begin
|
|
if not (AFont is TFreeTypeFont) then exit;
|
|
f := TFreeTypeFont(Afont);
|
|
|
|
if ftaTop in AAlign then
|
|
y += AFont.Ascent
|
|
else if ftaVerticalCenter in AALign then
|
|
y += AFont.Ascent - AFont.LineFullHeight*0.5
|
|
else if ftaBottom in AAlign then
|
|
y += AFont.Ascent - AFont.LineFullHeight;
|
|
|
|
if ftaCenter in AAlign then
|
|
x -= f.CharWidthFromGlyph(AGlyph)*0.5
|
|
else if ftaRight in AAlign then
|
|
x -= f.CharWidthFromGlyph(AGlyph);
|
|
|
|
DrawGlyph(AGlyph, AFont, x,y, AColor);
|
|
end;
|
|
|
|
{ TFreeTypeGlyph }
|
|
|
|
function TFreeTypeGlyph.GetBounds: TRect;
|
|
begin
|
|
result := GetBoundsWithOffset(0, 0);
|
|
end;
|
|
|
|
function TFreeTypeGlyph.GetAdvance: single;
|
|
var
|
|
metrics: TT_Glyph_Metrics;
|
|
begin
|
|
if TT_Get_Glyph_Metrics(FGlyphData, metrics) = TT_Err_Ok then
|
|
result := metrics.advance/64
|
|
else
|
|
result := 0;
|
|
end;
|
|
|
|
function TFreeTypeGlyph.GetBoundsWithOffset(x, y: single): TRect;
|
|
var
|
|
metrics: TT_Glyph_Metrics;
|
|
outline: TT_Outline;
|
|
bbox: TT_BBox;
|
|
error: TT_Error;
|
|
begin
|
|
|
|
if FOrientation<>0 then
|
|
begin
|
|
error := TT_Get_Glyph_Outline(FGlyphData, outline{%H-});
|
|
if error=TT_Err_Ok then
|
|
error := TT_Get_Outline_BBox(outline, bbox{%H-});
|
|
end else
|
|
begin
|
|
error := TT_Get_Glyph_Metrics(FGlyphData, metrics);
|
|
if error=TT_Err_Ok then
|
|
bbox := metrics.bbox;
|
|
end;
|
|
|
|
if error=TT_Err_Ok then
|
|
with bbox do
|
|
result := rect(IncludeFullGrainMin(xMin+round(x*64),64) div 64,
|
|
IncludeFullGrainMin(-yMax+round(y*64),64) div 64,
|
|
(IncludeFullGrainMax(xMax+round(x*64),64)+1) div 64,
|
|
(IncludeFullGrainMax(-yMin+round(y*64),64)+1) div 64)
|
|
else
|
|
result := TRect.Empty;
|
|
end;
|
|
|
|
constructor TFreeTypeGlyph.Create(AFont: TFreeTypeFont; AIndex: integer);
|
|
begin
|
|
if not AFont.CheckFace or (TT_New_Glyph(AFont.FFace, FGlyphData) <> TT_Err_Ok) then
|
|
raise EFreeType.Create('Cannot create empty glyph');
|
|
FLoaded := AFont.LoadGlyphInto(FGlyphData, AIndex);
|
|
FIndex := AIndex;
|
|
end;
|
|
|
|
constructor TFreeTypeGlyph.create;
|
|
begin
|
|
end;
|
|
|
|
function TFreeTypeGlyph.Clone(AOrientation: Integer): TFreeTypeGlyph;
|
|
begin
|
|
if not FLoaded then
|
|
raise EFreeType.Create('Cannot create a clone of an empty glyph');
|
|
|
|
result := TFreeTypeGlyph.create;
|
|
result.FLoaded := FLoaded;
|
|
result.FIndex := FIndex;
|
|
result.FOrientation := AOrientation;
|
|
|
|
TT_Copy_Glyph(FGlyphData, result.FGlyphData);
|
|
end;
|
|
|
|
function TFreeTypeGlyph.RenderDirectly(x, y: single; Rect: TRect;
|
|
OnRender: TDirectRenderingFunction; quality : TGlyphRenderQuality; ClearType: boolean): boolean;
|
|
begin
|
|
result := RenderDirectly(TTGetDefaultRasterizer, x,y, Rect, OnRender, quality, ClearType);
|
|
end;
|
|
|
|
function TFreeTypeGlyph.RenderDirectly(ARasterizer: TFreeTypeRasterizer; x,
|
|
y: single; Rect: TRect; OnRender: TDirectRenderingFunction;
|
|
quality: TGlyphRenderQuality; ClearType: boolean): boolean;
|
|
var mono: TFreeTypeMonochromeMap;
|
|
tx,xb,yb: integer;
|
|
pdest: pbyte;
|
|
buf: pointer;
|
|
glyphBounds: TRect;
|
|
begin
|
|
if ClearType then
|
|
begin
|
|
Rect.Left *= 3;
|
|
Rect.Right *= 3;
|
|
x *= 3;
|
|
end;
|
|
|
|
glyphBounds := BoundsWithOffset[x,y];
|
|
|
|
if ClearType then
|
|
begin
|
|
InflateRect(glyphBounds,1,0);
|
|
glyphBounds.Left := IncludeFullGrainMin( glyphBounds.Left, 3);
|
|
glyphBounds.Right := IncludeFullGrainMax( glyphBounds.Right-1, 3) + 1;
|
|
end;
|
|
if not IntersectRect(Rect,Rect,glyphBounds) then exit(False);
|
|
|
|
case quality of
|
|
grqMonochrome:
|
|
begin
|
|
tx := rect.right-rect.left;
|
|
mono := TFreeTypeMonochromeMap.Create(ARasterizer,tx,rect.bottom-rect.top);
|
|
result := mono.RenderGlyph(self,x-rect.left,y-rect.top);
|
|
if result then
|
|
begin
|
|
getmem(buf, tx);
|
|
for yb := mono.Height-1 downto 0 do
|
|
begin
|
|
mono.ScanMoveTo(0,yb);
|
|
pdest := pbyte(buf);
|
|
for xb := tx-1 downto 0 do
|
|
begin
|
|
if mono.ScanNextPixel then
|
|
pdest^ := $ff
|
|
else
|
|
pdest^ := 0;
|
|
inc(pdest);
|
|
end;
|
|
OnRender(rect.Left,rect.top+yb,tx,buf);
|
|
end;
|
|
freemem(buf);
|
|
end;
|
|
mono.Free;
|
|
end;
|
|
grqLowQuality:
|
|
begin
|
|
ARasterizer.Set_Raster_Palette(RegularGray5);
|
|
result := TT_Render_Directly_Glyph_Gray(FGlyphData,
|
|
round((x-rect.left)*64), round((rect.bottom-y)*64),
|
|
rect.left, rect.top, rect.right-rect.left, rect.bottom-rect.top,
|
|
OnRender, ARasterizer) = TT_Err_Ok;
|
|
end;
|
|
grqHighQuality:
|
|
result := TT_Render_Directly_Glyph_HQ(FGlyphData,
|
|
round((x-rect.left)*64), round((rect.bottom-y)*64),
|
|
rect.left, rect.top, rect.right-rect.left, rect.bottom-rect.top,
|
|
OnRender, ARasterizer) = TT_Err_Ok;
|
|
else
|
|
result := false;
|
|
end;
|
|
end;
|
|
|
|
destructor TFreeTypeGlyph.Destroy;
|
|
begin
|
|
if FreeTypeInitialized then
|
|
TT_Done_Glyph(FGlyphData);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TFreeTypeFont }
|
|
|
|
procedure TFreeTypeFont.LoadFace;
|
|
var errorNum: TT_Error;
|
|
familyItem: TCustomFamilyCollectionItem;
|
|
fontItem: TCustomFontCollectionItem;
|
|
begin
|
|
DiscardFace;
|
|
if FStream <> nil then
|
|
begin
|
|
errorNum := TT_Open_Face(FStream,False,FFace);
|
|
if errorNum <> TT_Err_Ok then
|
|
raise EFreeType.Create('Cannot open font (TT_Error ' + intToStr(errorNum)+') <Stream>');
|
|
end else
|
|
begin
|
|
if Pos(PathDelim, FName) <> 0 then
|
|
begin
|
|
errorNum := TT_Open_Face(FName,FFace);
|
|
if errorNum <> TT_Err_Ok then
|
|
raise EFreeType.Create('Cannot open font (TT_Error ' + intToStr(errorNum)+') "'+FName+'"');
|
|
end else
|
|
begin
|
|
familyItem := Collection.Family[FName];
|
|
if familyItem = nil then
|
|
raise EFreeType.Create('Font family not found ("'+FName+'")');
|
|
fontItem := familyItem.GetFont(FStyleStr);
|
|
if fontItem = nil then
|
|
raise EFreeType.Create('Font style not found ("'+FStyleStr+'")');
|
|
FFace := fontItem.QueryFace(FontCollectionItemDestroyListener(self,@OnDestroyFontItem));
|
|
FFaceItem := fontItem;
|
|
end;
|
|
end;
|
|
|
|
FFaceLoaded:= true;
|
|
UpdateInstance;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetName(const AValue: String);
|
|
begin
|
|
DiscardStream;
|
|
if FName=AValue then exit;
|
|
FName := AValue;
|
|
FaceChanged;
|
|
end;
|
|
|
|
{$push}
|
|
{$hints off}
|
|
function TFreeTypeFont.GetDPI: integer;
|
|
var metrics: TT_Instance_Metrics;
|
|
begin
|
|
if not CheckInstance then
|
|
begin
|
|
result := FDPI;
|
|
end
|
|
else
|
|
begin
|
|
if TT_Get_Instance_Metrics(FInstance,metrics) = TT_Err_Ok then
|
|
result := metrics.y_resolution
|
|
else
|
|
result := FDPI;
|
|
end;
|
|
end;
|
|
{$pop}
|
|
|
|
function TFreeTypeFont.GetFamily: string;
|
|
begin
|
|
result := Information[ftiFamily];
|
|
end;
|
|
|
|
function TFreeTypeFont.GetFreeTypeStyles: TFreeTypeStyles;
|
|
var a: array of string;
|
|
i: integer;
|
|
begin
|
|
result := [];
|
|
a := StylesToArray(StyleAsString);
|
|
for i := 0 to high(a) do
|
|
if a[i] = 'Bold' then result += [ftsBold] else
|
|
if (a[i] = 'Italic') or (a[i] = 'Oblique') then result += [ftsItalic];
|
|
end;
|
|
|
|
function TFreeTypeFont.FindGlyphNode(Index: Integer): TAvlTreeNode;
|
|
var DataValue: integer;
|
|
begin
|
|
Result:=FGlyphTable.Root;
|
|
while (Result<>nil) do begin
|
|
DataValue := TFreeTypeGlyph(Result.Data).Index;
|
|
if Index=DataValue then exit;
|
|
if Index<DataValue then begin
|
|
Result:=Result.Left
|
|
end else begin
|
|
Result:=Result.Right
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetAscent: single;
|
|
begin
|
|
CheckInstance;
|
|
result := FAscentValue*SizeInPixels;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetCapHeight: single;
|
|
begin
|
|
CheckInstance;
|
|
result := FCapHeight*SizeInPixels;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetClearType: boolean;
|
|
begin
|
|
Result:= FClearType;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetCharIndex(AUnicodeChar: integer): integer;
|
|
begin
|
|
if not CheckInstance then
|
|
begin
|
|
result := 0;
|
|
exit;
|
|
end;
|
|
if FCharmapOk then
|
|
begin
|
|
if FCharmapSymbol then
|
|
result := TT_Char_Index(FCharMap, AUnicodeChar or $F000)
|
|
else
|
|
result := TT_Char_Index(FCharMap, AUnicodeChar);
|
|
end
|
|
else
|
|
result := 0;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetDescent: single;
|
|
begin
|
|
CheckInstance;
|
|
result := FDescentValue*SizeInPixels;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetGlyph(Index: integer): TFreeTypeGlyph;
|
|
var
|
|
node: TAvlTreeNode;
|
|
lGlyph: TFreeTypeGlyph;
|
|
begin
|
|
if not CheckInstance then
|
|
begin
|
|
result := nil;
|
|
exit;
|
|
end;
|
|
node := FindGlyphNode(Index);
|
|
if node = nil then
|
|
begin
|
|
lGlyph := TFreeTypeGlyph.Create(self, Index);;
|
|
FGlyphTable.Add(lGlyph);
|
|
end else
|
|
lGlyph := TFreeTypeGlyph(node.Data);
|
|
result := lGlyph;
|
|
end;
|
|
|
|
{$push}
|
|
{$hints off}
|
|
function TFreeTypeFont.GetGlyphCount: integer;
|
|
var prop : TT_Face_Properties;
|
|
begin
|
|
if not CheckFace then
|
|
result := 0
|
|
else
|
|
begin
|
|
if TT_Get_Face_Properties(FFace, prop) <> TT_Err_Ok then
|
|
result := 0
|
|
else
|
|
result := prop.num_glyphs;
|
|
end;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetInformation(AIndex: TFreeTypeInformation): string;
|
|
begin
|
|
if FNamesArray = nil then FetchNames;
|
|
if (ord(AIndex) < 0) or (ord(AIndex) > high(FNamesArray)) then
|
|
result := ''
|
|
else
|
|
result := FNamesArray[ord(AIndex)];
|
|
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;
|
|
result := (FAscentValue + FDescentValue)*SizeInPixels + GetLineSpacing;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetLineSpacing: single;
|
|
begin
|
|
CheckInstance;
|
|
if not SmallLinePadding then
|
|
result := FLargeLineGapValue*SizeInPixels
|
|
else
|
|
result := FLineGapValue*SizeInPixels;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.OnDestroyFontItem;
|
|
begin
|
|
DiscardFace;
|
|
FaceChanged;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetPixelSize: single;
|
|
begin
|
|
result := SizeInPoints * DPI / 72;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetVersionNumber: string;
|
|
var VersionStr: string;
|
|
idxStart,idxEnd: integer;
|
|
begin
|
|
VersionStr := Information[ftiVersionString];
|
|
idxStart := 1;
|
|
while (idxStart < length(VersionStr)) and not (VersionStr[idxStart] in['0'..'9']) do
|
|
inc(idxStart);
|
|
idxEnd := idxStart;
|
|
while (idxEnd < length(VersionStr)) and (VersionStr[idxEnd+1] in['0'..'9']) do inc(idxEnd);
|
|
if (idxEnd < length(VersionStr)) and (VersionStr[idxEnd+1] = '.') then inc(idxEnd);
|
|
while (idxEnd < length(VersionStr)) and (VersionStr[idxEnd+1] in['0'..'9']) do inc(idxEnd);
|
|
result := copy(VersionStr,idxStart,idxEnd-idxStart+1);
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetClearType(const AValue: boolean);
|
|
begin
|
|
if FClearType=AValue then exit;
|
|
FClearType:=AValue;
|
|
UpdateSizeInPoints;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetDPI(const AValue: integer);
|
|
begin
|
|
if FDPI = AValue then exit;
|
|
FDPI := AValue;
|
|
if FInstanceCreated then
|
|
begin
|
|
TT_Set_Instance_Resolutions(FInstance, AValue,AValue);
|
|
UpdateSizeInPoints;
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetFreeTypeStyles(AValue: TFreeTypeStyles);
|
|
var str: string;
|
|
begin
|
|
str := '';
|
|
if ftsBold in AValue then str += 'Bold ';
|
|
if ftsItalic in AValue then str += 'Italic ';
|
|
StyleAsString := trim(str);
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetHinted(const AValue: boolean);
|
|
begin
|
|
if FHinted=AValue then exit;
|
|
FHinted:=AValue;
|
|
FGlyphTable.FreeAndClear;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetHinted: boolean;
|
|
begin
|
|
result := FHinted;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetLineFullHeight(AValue: single);
|
|
var Ratio: single;
|
|
begin
|
|
CheckInstance;
|
|
Ratio := FAscentValue + FDescentValue;
|
|
if not SmallLinePadding then
|
|
Ratio += FLargeLineGapValue
|
|
else
|
|
Ratio += FLineGapValue;
|
|
if Ratio <> 0 then
|
|
SizeInPixels := AValue / Ratio
|
|
else
|
|
SizeInPixels := AValue;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetStyleAsString(AValue: string);
|
|
begin
|
|
AValue := Trim(AValue);
|
|
if FStyleStr=AValue then Exit;
|
|
FStyleStr:=AValue;
|
|
FaceChanged;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.DiscardFace;
|
|
begin
|
|
if FFaceLoaded then
|
|
begin
|
|
DiscardInstance;
|
|
if FFaceItem <> nil then
|
|
begin
|
|
FFaceItem.ReleaseFace(FontCollectionItemDestroyListener(self,@OnDestroyFontItem));
|
|
FFaceItem := nil;
|
|
end
|
|
else
|
|
TT_Close_Face(FFace);
|
|
FFaceLoaded := false;
|
|
FNamesArray := nil;
|
|
end;
|
|
FCharmapOk := false;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.DiscardInstance;
|
|
begin
|
|
if FInstanceCreated then
|
|
begin
|
|
if FreeTypeInitialized then
|
|
TT_Done_Instance(FInstance);
|
|
FInstanceCreated := false;
|
|
FGlyphTable.FreeAndClear;
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.DiscardStream;
|
|
begin
|
|
if FStream <> nil then
|
|
begin
|
|
DiscardFace;
|
|
if FOwnedStream then FStream.Free;
|
|
FStream := nil;
|
|
FOwnedStream:= false;
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetPixelSize(const AValue: single);
|
|
begin
|
|
SizeInPoints := AValue*72/DPI;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetPointSize(AValue: single);
|
|
begin
|
|
if AValue < FreeTypeMinPointSize then AValue := FreeTypeMinPointSize;
|
|
if FPointSize=AValue then exit;
|
|
FPointSize:=AValue;
|
|
UpdateSizeInPoints;
|
|
end;
|
|
|
|
function TFreeTypeFont.LoadGlyphInto(_glyph: TT_Glyph; glyph_index: Word): boolean;
|
|
var flags: integer;
|
|
begin
|
|
if not CheckInstance then
|
|
raise EFreeType.Create('No font instance');
|
|
flags := TT_Load_Scale_Glyph;
|
|
if FHinted then flags := flags or TT_Load_Hint_Glyph;
|
|
result := (TT_Load_Glyph(FInstance, _glyph, glyph_index, flags) = TT_Err_Ok);
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetWidthFactor(const AValue: single);
|
|
begin
|
|
if FWidthFactor=AValue then exit;
|
|
FWidthFactor:=AValue;
|
|
FGlyphTable.FreeAndClear;
|
|
UpdateSizeInPoints;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.UpdateInstance;
|
|
var
|
|
errorNum: TT_Error;
|
|
begin
|
|
DiscardInstance;
|
|
|
|
errorNum := TT_New_Instance(FFace, FInstance);
|
|
if errorNum = TT_Err_Ok then
|
|
begin
|
|
FInstanceCreated := true;
|
|
TT_Set_Instance_Resolutions(FInstance, FDPI,FDPI);
|
|
UpdateSizeInPoints;
|
|
UpdateMetrics;
|
|
UpdateCharmap;
|
|
end else
|
|
raise EFreeType.Create('Cannot create font instance (TT_Error ' + intToStr(errorNum)+')');
|
|
end;
|
|
|
|
procedure TFreeTypeFont.UpdateSizeInPoints;
|
|
var charsizex: integer;
|
|
begin
|
|
if FInstanceCreated then
|
|
begin
|
|
if not FClearType then
|
|
charsizex := round(FPointSize*64*FWidthFactor)
|
|
else
|
|
charsizex := round(FPointSize*64*FWidthFactor*3);
|
|
|
|
if TT_Set_Instance_CharSizes(FInstance,charsizex,round(FPointSize*64)) <> TT_Err_Ok then
|
|
raise EFreeType.Create('Unable to set point size');
|
|
FGlyphTable.FreeAndClear;
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.UpdateMetrics;
|
|
var prop: TT_Face_Properties;
|
|
begin
|
|
if CheckFace then
|
|
begin
|
|
TT_Get_Face_Properties(FFace,prop);
|
|
FAscentValue := prop.horizontal^.ascender;
|
|
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
|
|
if prop.os2^.version <> $ffff then
|
|
begin
|
|
if (prop.os2^.usWinAscent <> 0) or (prop.os2^.usWinDescent <> 0) then
|
|
begin
|
|
FAscentValue := prop.os2^.usWinAscent;
|
|
FDescentValue := -prop.os2^.usWinDescent;
|
|
end else
|
|
begin
|
|
FAscentValue := prop.os2^.sTypoAscender;
|
|
FDescentValue := prop.os2^.sTypoDescender;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
if prop.os2^.version <> $ffff then
|
|
if prop.os2^.sTypoLineGap > FLargeLineGapValue then
|
|
FLargeLineGapValue := prop.os2^.sTypoLineGap;
|
|
|
|
if prop.os2^.version >= 2 then
|
|
FCapHeight:=prop.os2^.sCapHeight
|
|
else
|
|
FCapHeight:=FAscentValue;
|
|
|
|
FAscentValue /= FUnitsPerEM;
|
|
FDescentValue /= -FUnitsPerEM;
|
|
FLineGapValue /= FUnitsPerEM;
|
|
FLargeLineGapValue /= FUnitsPerEM;
|
|
FCapHeight /= FUnitsPerEM;
|
|
|
|
if FLargeLineGapValue = 0 then
|
|
FLargeLineGapValue := (FAscentValue+FDescentValue)*0.1;
|
|
|
|
end else
|
|
begin
|
|
FAscentValue := -0.5;
|
|
FDescentValue := 0.5;
|
|
FLineGapValue := 0;
|
|
FLargeLineGapValue:= 0;
|
|
FUnitsPerEM := 1;
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.UpdateCharmap;
|
|
var i,n: integer;
|
|
lPlatform,encoding: integer;
|
|
begin
|
|
if FCharmapOk then exit;
|
|
if not FFaceLoaded then
|
|
begin
|
|
FCharmapOk := false;
|
|
exit;
|
|
end;
|
|
|
|
n := TT_Get_CharMap_Count(FFace);
|
|
lPlatform := -1;
|
|
encoding := 0;
|
|
FCharmapSymbol := false;
|
|
|
|
//MS Unicode
|
|
for i := 0 to n-1 do
|
|
begin
|
|
if TT_Get_CharMap_ID(FFace, i, lPlatform, encoding) = TT_Err_Ok then
|
|
begin
|
|
if (lPlatform = TT_PLATFORM_MICROSOFT) and (encoding = 1) then
|
|
begin
|
|
if TT_Get_CharMap(FFace, i, FCharMap) = TT_Err_Ok then
|
|
begin
|
|
FCharmapOk := true;
|
|
exit;
|
|
end
|
|
end else
|
|
if (lPlatform = TT_PLATFORM_MICROSOFT) and (encoding = 0) then
|
|
begin
|
|
if TT_Get_CharMap(FFace, i, FCharMap) = TT_Err_Ok then
|
|
begin
|
|
FCharmapOk := true;
|
|
FCharmapSymbol:= true;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//Apple Unicode
|
|
for i := 0 to n-1 do
|
|
begin
|
|
if TT_Get_CharMap_ID(FFace, i, lPlatform, encoding) = TT_Err_Ok then
|
|
begin
|
|
if (lPlatform = TT_PLATFORM_APPLE_UNICODE) then
|
|
if TT_Get_CharMap(FFace, i, FCharMap) = TT_Err_Ok then
|
|
begin
|
|
FCharmapOk := true;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//ISO Unicode
|
|
for i := 0 to n-1 do
|
|
begin
|
|
if TT_Get_CharMap_ID(FFace, i, lPlatform, encoding) = TT_Err_Ok then
|
|
begin
|
|
if (lPlatform = TT_PLATFORM_ISO) and (encoding = 1) then
|
|
if TT_Get_CharMap(FFace, i, FCharMap) = TT_Err_Ok then
|
|
begin
|
|
FCharmapOk := true;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
FCharmapOk := false;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.RenderTextDecoration(AText: string; x, y: single;
|
|
ARect: TRect; OnRender: TDirectRenderingFunction);
|
|
procedure HorizLine(AYCoeff, AHeightCoeff: single);
|
|
var
|
|
ly, height: single;
|
|
clippedRect,unclippedRect: TRect;
|
|
begin
|
|
ly := y + self.Ascent * AYCoeff;
|
|
height := Max(self.Ascent * AHeightCoeff, 1);
|
|
unclippedRect := Types.Rect(round(x),round(ly),
|
|
round(x+self.TextWidth(AText)),round(ly+height));
|
|
clippedRect := rect(0,0,0,0);
|
|
if IntersectRect(clippedRect,unclippedRect,ARect) then
|
|
FillRect(clippedRect,OnRender);
|
|
end;
|
|
begin
|
|
if UnderlineDecoration then
|
|
HorizLine(+1.5*0.08, 0.08);
|
|
if StrikeoutDecoration then
|
|
HorizLine(-0.3, 0.06);
|
|
end;
|
|
|
|
procedure TFreeTypeFont.FillRect(ARect: TRect; OnRender: TDirectRenderingFunction);
|
|
var
|
|
yb,temp,tx: integer;
|
|
data: pbyte;
|
|
begin
|
|
if ARect.Top > ARect.Bottom then
|
|
begin
|
|
temp := ARect.Top;
|
|
ARect.Top := ARect.Bottom;
|
|
ARect.Bottom := temp;
|
|
end;
|
|
if ARect.Left > ARect.Right then
|
|
begin
|
|
temp := ARect.Left;
|
|
ARect.Left := ARect.Right;
|
|
ARect.Right:= temp;
|
|
end;
|
|
if ClearType then
|
|
begin
|
|
ARect.Left *= 3;
|
|
ARect.Right *= 3;
|
|
end;
|
|
tx := ARect.Right-ARect.Left;
|
|
if tx > 0 then
|
|
begin
|
|
getmem(data,tx);
|
|
try
|
|
fillchar(data^, tx, 255);
|
|
for yb := ARect.Top to ARect.Bottom-1 do
|
|
OnRender(ARect.Left,yb,tx,data);
|
|
finally
|
|
freemem(data);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.FaceChanged;
|
|
begin
|
|
if not FFaceChanged then
|
|
begin
|
|
FFaceChanged := true;
|
|
DiscardFace;
|
|
end;
|
|
end;
|
|
|
|
constructor TFreeTypeFont.Create;
|
|
begin
|
|
EnsureFreeTypeInitialized;
|
|
FFaceLoaded := false;
|
|
FFaceItem := nil;
|
|
FInstanceCreated := false;
|
|
FCharmapOk := false;
|
|
FPointSize := 10;
|
|
FDPI := 96;
|
|
FGlyphTable := TAvlTree.Create;
|
|
FGlyphTable.OnCompare := @GlyphTableOnCompare;
|
|
FHinted := true;
|
|
FKerningEnabled:= true;
|
|
FKerningFallbackEnabled:= true;
|
|
FWidthFactor := 1;
|
|
FClearType := false;
|
|
FStyleStr:= 'Regular';
|
|
SmallLinePadding:= true;
|
|
Quality := grqHighQuality;
|
|
FFaceChanged := true;
|
|
end;
|
|
|
|
destructor TFreeTypeFont.Destroy;
|
|
begin
|
|
DiscardInstance;
|
|
DiscardFace;
|
|
DiscardStream;
|
|
FGlyphTable.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.AccessFromStream(AStream: TStream; AStreamOwner: boolean);
|
|
begin
|
|
DiscardStream;
|
|
FStream := AStream;
|
|
FOwnedStream:= AStreamOwner;
|
|
FaceChanged;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.RenderText(AText: string; x, y: single; ARect: TRect;
|
|
OnRender: TDirectRenderingFunction);
|
|
var
|
|
pstr: pchar;
|
|
left,charcode,charlen: integer;
|
|
idx: integer;
|
|
g: TFreeTypeGlyph;
|
|
prevCharcode, glyphIndex: integer;
|
|
txmatrix: TT_Matrix;
|
|
angle, sin_angle, cos_angle: single;
|
|
outline: ^TT_Outline;
|
|
vector: TT_Vector;
|
|
corrX, corrY: single;
|
|
begin
|
|
if not CheckInstance then exit;
|
|
if AText = '' then exit;
|
|
idx := pos(LineEnding,AText);
|
|
|
|
if Orientation<>0 then
|
|
begin
|
|
angle := Orientation * PI / 1800;
|
|
SinCos(angle, sin_angle, cos_angle);
|
|
txmatrix.xx := Round( cos_angle * $10000 );
|
|
txmatrix.xy := -Round( sin_angle * $10000 );
|
|
txmatrix.yx := Round( sin_angle * $10000 );
|
|
txmatrix.yy := Round( cos_angle * $10000 );
|
|
end;
|
|
|
|
while idx <> 0 do
|
|
begin
|
|
RenderText(copy(AText,1,idx-1),x,y,ARect,OnRender);
|
|
delete(AText,1,idx+length(LineEnding)-1);
|
|
if Orientation<>0 then
|
|
begin
|
|
vector.x := 0;
|
|
vector.y := -round(LineFullHeight * 64);
|
|
TT_Transform_Vector(vector.x, vector.y, txmatrix);
|
|
x += vector.x / 64;
|
|
y -= vector.y / 64;
|
|
end else
|
|
y += LineFullHeight;
|
|
idx := pos(LineEnding,AText);
|
|
end;
|
|
If Assigned(FOnRenderText) then
|
|
FOnRenderText(AText,x,y);
|
|
|
|
// TODO: Rotation at arbitraty angles requires antialiased drawing
|
|
RenderTextDecoration(AText,x,y,ARect,OnRender);
|
|
pstr := @AText[1];
|
|
left := length(AText);
|
|
prevCharcode := -1;
|
|
while left > 0 do
|
|
begin
|
|
charcode := UTF8CodepointToUnicode(pstr, charlen);
|
|
dec(left,charlen);
|
|
glyphIndex := CharIndex[charcode];
|
|
g := Glyph[glyphIndex];
|
|
if Orientation<>0 then
|
|
g := g.Clone(Orientation);
|
|
|
|
if g <> nil then
|
|
with g do
|
|
begin
|
|
corrX := Advance;
|
|
|
|
if KerningEnabled and (prevCharcode <> -1) then
|
|
corrX += round(GetCharKerning(prevCharcode, charcode).Kerning.x);
|
|
|
|
vector.x := round(corrX * 64);
|
|
vector.y := 0;
|
|
|
|
if Orientation<>0 then begin
|
|
outLine := @PGlyph(Data.z)^.outline;
|
|
TT_Transform_Outline(outline^, txmatrix);
|
|
TT_Transform_Vector(vector.x, vector.y, txmatrix);
|
|
end;
|
|
|
|
corrX := vector.x / 64;
|
|
corry := vector.y / 64;
|
|
|
|
if Hinted then
|
|
RenderDirectly(x,round(y),ARect,OnRender,quality,FClearType)
|
|
else
|
|
RenderDirectly(x,y,ARect,OnRender,quality,FClearType);
|
|
|
|
if FClearType then
|
|
x += corrX/3
|
|
else
|
|
x += corrX;
|
|
|
|
y -= corrY;
|
|
|
|
prevCharcode := charcode;
|
|
if Orientation<>0 then
|
|
g.Free;
|
|
end;
|
|
inc(pstr,charlen);
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.RenderGlyph(AGlyph: Integer; x, y: single;
|
|
ARect: TRect; OnRender: TDirectRenderingFunction);
|
|
var
|
|
g: TFreeTypeGlyph;
|
|
begin
|
|
if not CheckInstance then exit;
|
|
g := Glyph[AGlyph];
|
|
if g <> nil then
|
|
with g do
|
|
begin
|
|
if Hinted then
|
|
RenderDirectly(x,round(y),ARect,OnRender,quality,FClearType)
|
|
else
|
|
RenderDirectly(x,y,ARect,OnRender,quality,FClearType);
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetNameAndStyle(AName: string; AStyle: string);
|
|
begin
|
|
AStyle := Trim(AStyle);
|
|
if (AName = FName) and (AStyle = FStyleStr) then exit;
|
|
FName := AName;
|
|
FStyleStr := AStyle;
|
|
FaceChanged;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.SetNameAndStyle(AName: string; AStyle: TFreeTypeStyles);
|
|
var styleStr: string;
|
|
begin
|
|
styleStr := '';
|
|
if ftsBold in AStyle then styleStr += 'Bold ';
|
|
if ftsItalic in AStyle then styleStr += 'Italic ';
|
|
SetNameAndStyle(AName, Trim(styleStr));
|
|
end;
|
|
|
|
function TFreeTypeFont.TextWidth(AText: string): single;
|
|
var
|
|
pstr: pchar;
|
|
left,charcode,charlen: integer;
|
|
maxWidth,w: single;
|
|
idx: integer;
|
|
g: TFreeTypeGlyph;
|
|
prevCharcode, glyphIndex: integer;
|
|
begin
|
|
result := 0;
|
|
if not CheckInstance then exit;
|
|
if AText = '' then exit;
|
|
|
|
maxWidth := 0;
|
|
idx := pos(LineEnding,AText);
|
|
while idx <> 0 do
|
|
begin
|
|
w := TextWidth(copy(AText,1,idx-1));
|
|
if w > maxWidth then maxWidth:= w;
|
|
delete(AText,1,idx+length(LineEnding)-1);
|
|
idx := pos(LineEnding,AText);
|
|
end;
|
|
if AText = '' then
|
|
begin
|
|
result := maxWidth;
|
|
exit;
|
|
end;
|
|
|
|
pstr := @AText[1];
|
|
left := length(AText);
|
|
prevCharcode := -1;
|
|
while left > 0 do
|
|
begin
|
|
charcode := UTF8CodepointToUnicode(pstr, charlen);
|
|
inc(pstr,charlen);
|
|
dec(left,charlen);
|
|
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
|
|
result := maxWidth;
|
|
end;
|
|
|
|
function TFreeTypeFont.TextHeight(AText: string): single;
|
|
var idx: integer;
|
|
nb: integer;
|
|
begin
|
|
if AText= '' then result := 0
|
|
else
|
|
begin
|
|
result := LineFullHeight;
|
|
nb := 1;
|
|
idx := pos(LineEnding,AText);
|
|
while idx <> 0 do
|
|
begin
|
|
nb += 1;
|
|
delete(AText,1,idx+length(LineEnding)-1);
|
|
idx := pos(LineEnding,AText);
|
|
end;
|
|
result *= nb;
|
|
end;
|
|
end;
|
|
|
|
function TFreeTypeFont.CharWidthFromUnicode(AUnicodeChar: integer): single;
|
|
var g: TFreeTypeGlyph;
|
|
begin
|
|
g := Glyph[CharIndex[AUnicodeChar]];
|
|
if g = nil then result := 0
|
|
else
|
|
result := g.Advance;
|
|
if FClearType then result /= 3;
|
|
end;
|
|
|
|
function TFreeTypeFont.CharWidthFromGlyph(AGlyph: integer): single;
|
|
var g: TFreeTypeGlyph;
|
|
begin
|
|
g := Glyph[AGlyph];
|
|
if g = nil then result := 0
|
|
else
|
|
result := g.Advance;
|
|
if FClearType then result /= 3;
|
|
end;
|
|
|
|
function TFreeTypeFont.CharsWidth(AText: string): ArrayOfSingle;
|
|
var
|
|
pstr: pchar;
|
|
left,charcode,charlen: integer;
|
|
resultIndex: integer;
|
|
w: single;
|
|
prevCharcode,glyphIndex: integer;
|
|
g: TFreeTypeGlyph;
|
|
begin
|
|
if AText = '' then
|
|
begin
|
|
setlength(result{%H-}, 0);
|
|
exit;
|
|
end;
|
|
pstr := @AText[1];
|
|
left := length(AText);
|
|
setlength(result, UTF8Length(AText));
|
|
resultIndex := 0;
|
|
prevCharcode := -1;
|
|
while left > 0 do
|
|
begin
|
|
charcode := UTF8CodepointToUnicode(pstr, charlen);
|
|
inc(pstr,charlen);
|
|
dec(left,charlen);
|
|
|
|
glyphIndex := CharIndex[charcode];
|
|
g := Glyph[glyphIndex];
|
|
if g <> nil then
|
|
with g do
|
|
begin
|
|
if FClearType then
|
|
w := Advance/3
|
|
else
|
|
w := Advance;
|
|
if KerningEnabled and (prevCharcode <> -1) and (resultIndex > 0) then
|
|
result[resultIndex-1] += GetCharKerning(prevCharcode, charcode).Kerning.x;
|
|
prevCharcode := charcode;
|
|
end else
|
|
w := 0;
|
|
|
|
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;
|
|
begin
|
|
result := CharsPosition(AText, []);
|
|
end;
|
|
|
|
function TFreeTypeFont.CharsPosition(AText: string; AAlign: TFreeTypeAlignments): ArrayOfCharPosition;
|
|
var
|
|
resultIndex,resultLineStart: integer;
|
|
curX: single;
|
|
|
|
procedure ApplyHorizAlign;
|
|
var delta: single;
|
|
i: integer;
|
|
begin
|
|
if ftaLeft in AAlign then exit;
|
|
if ftaCenter in AAlign then
|
|
delta := -curX/2
|
|
else if ftaRight in AAlign then
|
|
delta := -curX
|
|
else
|
|
exit;
|
|
|
|
for i := resultLineStart to resultIndex-1 do
|
|
result[i].x += delta;
|
|
end;
|
|
|
|
var
|
|
pstr: pchar;
|
|
left,charcode,charlen: integer;
|
|
i : integer;
|
|
w,h,y,yTopRel,yBottomRel: single;
|
|
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;
|
|
if AText = '' then exit;
|
|
StrLineEnding := LineEnding;
|
|
pstr := @AText[1];
|
|
left := length(AText);
|
|
setlength(result, UTF8Length(AText)+1);
|
|
resultIndex := 0;
|
|
resultLineStart := 0;
|
|
if ftaLeft in AAlign then AAlign -= [ftaLeft, ftaCenter, ftaRight];
|
|
if ftaBaseline in AAlign then AAlign -= [ftaTop, ftaBaseline, ftaBottom, ftaVerticalCenter];
|
|
curX := 0;
|
|
y := 0;
|
|
if ftaTop in AAlign then
|
|
begin
|
|
y += Ascent;
|
|
AAlign -= [ftaTop, ftaBottom, ftaVerticalCenter];
|
|
end;
|
|
yTopRel := -Ascent;
|
|
yBottomRel := Descent;
|
|
h := LineFullHeight;
|
|
prevCharcode := -1;
|
|
while left > 0 do
|
|
begin
|
|
if (left > length(StrLineEnding)) and (pstr^ = StrLineEnding[1]) then
|
|
begin
|
|
Found := true;
|
|
for i := 2 to length(StrLineEnding) do
|
|
if (pstr+(i-1))^ <> StrLineEnding[i] then
|
|
begin
|
|
Found := false;
|
|
break;
|
|
end;
|
|
if Found then
|
|
begin
|
|
for i := 1 to length(StrLineEnding) do
|
|
begin
|
|
with result[resultIndex] do
|
|
begin
|
|
x := curX;
|
|
width := 0;
|
|
yTop := y+yTopRel;
|
|
yBase := y;
|
|
yBottom := y+yBottomRel;
|
|
end;
|
|
inc(resultIndex);
|
|
inc(pstr);
|
|
dec(left);
|
|
end;
|
|
ApplyHorizAlign;
|
|
y += h;
|
|
curX := 0;
|
|
resultLineStart := resultIndex;
|
|
prevCharcode := -1;
|
|
if left <= 0 then break;
|
|
end;
|
|
end;
|
|
charcode := UTF8CodepointToUnicode(pstr, charlen);
|
|
inc(pstr,charlen);
|
|
dec(left,charlen);
|
|
glyphIndex := CharIndex[charcode];
|
|
g := Glyph[glyphIndex];
|
|
if g <> nil then
|
|
with g do
|
|
begin
|
|
if FClearType then
|
|
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;
|
|
width := w;
|
|
yTop := y+yTopRel;
|
|
yBase := y;
|
|
yBottom := y+yBottomRel;
|
|
end;
|
|
inc(resultIndex);
|
|
curX += w;
|
|
end;
|
|
if resultIndex >= length(result) then
|
|
setlength(result, resultIndex+1);
|
|
with result[resultIndex] do
|
|
begin
|
|
x := curX;
|
|
width := 0;
|
|
yTop := y+yTopRel;
|
|
yBase := y;
|
|
yBottom := y+yBottomRel;
|
|
end;
|
|
inc(resultIndex);
|
|
setlength(result, resultIndex);
|
|
ApplyHorizAlign;
|
|
|
|
if ftaBottom in AAlign then
|
|
begin
|
|
y += LineFullHeight-Ascent;
|
|
for i := 0 to high(result) do
|
|
with result[i] do
|
|
begin
|
|
yTop -= y;
|
|
yBase -= y;
|
|
yBottom -= y;
|
|
end;
|
|
end else
|
|
if ftaVerticalCenter in AAlign then
|
|
begin
|
|
y += LineFullHeight/2-Ascent;
|
|
for i := 0 to high(result) do
|
|
with result[i] do
|
|
begin
|
|
yTop -= y;
|
|
yBase -= y;
|
|
yBottom -= y;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeFont.FetchNames;
|
|
const
|
|
maxNameIndex = 22;
|
|
var i,j: integer;
|
|
nrPlatformID,nrEncodingID,nrLanguageID,nrNameID,len: integer;
|
|
value,value2: string;
|
|
|
|
begin
|
|
// setlength(FNamesArray, maxNameIndex+1);
|
|
// wp: Move this into the "if" to avoid ignoring font files after reading defective one.
|
|
if CheckFace then
|
|
begin
|
|
setlength(FNamesArray, maxNameIndex+1);
|
|
for i := 0 to TT_Get_Name_Count(FFace)-1 do
|
|
begin
|
|
if TT_Get_Name_ID(FFace, i, nrPlatformID, nrEncodingID,
|
|
nrLanguageID, nrNameID) <> TT_Err_Ok then continue;
|
|
|
|
if (nrNameID < 0) or (nrNameID > maxNameIndex) then continue;
|
|
|
|
{ check for Microsoft, Unicode, English }
|
|
if ((nrPlatformID=TT_PLATFORM_MICROSOFT) and (nrEncodingID in[0,1]) and
|
|
((nrLanguageID=$0409) or (nrLanguageID=$0809) or
|
|
(nrLanguageID=$0c09) or (nrLanguageID=$1009) or
|
|
(nrLanguageID=$1409) or (nrLanguageID=$1809))) or
|
|
{ or for Unicode, English }
|
|
((nrPlatformID=TT_PLATFORM_APPLE_UNICODE) and
|
|
(nrLanguageID=0)) then
|
|
begin
|
|
value := TT_Get_Name_String(FFace, i);
|
|
if value <> '' then
|
|
begin
|
|
for j := 1 to length(value) div 2 do
|
|
pword(@value[j*2-1])^ := BEtoN(pword(@value[j*2-1])^);
|
|
setlength(value2{%H-}, 3*(length(value) div 2) + 1); //maximum is 3-byte chars and NULL char at the end
|
|
len := system.UnicodeToUtf8(@value2[1],length(value2),PUnicodeChar( @value[1] ),length(value) div 2);
|
|
if len > 0 then
|
|
begin
|
|
setlength(value2, len-1 );
|
|
value := value2;
|
|
end;
|
|
end;
|
|
FNamesArray[nrNameID] := value;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TFreeTypeFont.GetCollection: TCustomFreeTypeFontCollection;
|
|
begin
|
|
if FCollection = nil then
|
|
result := FontCollection
|
|
else
|
|
result := FCollection;
|
|
end;
|
|
|
|
function TFreeTypeFont.CheckFace: boolean;
|
|
begin
|
|
if FFaceChanged then
|
|
begin
|
|
FFaceChanged:= false;
|
|
LoadFace;
|
|
end;
|
|
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;
|
|
end;
|
|
|
|
{ TFreeTypeGrayscaleMap }
|
|
|
|
procedure TFreeTypeGrayscaleMap.Init(AWidth, AHeight: integer);
|
|
begin
|
|
map.Width := AWidth;
|
|
map.Rows := AHeight;
|
|
map.Cols:= (AWidth+3) and not 3;
|
|
map.flow:= TT_Flow_Down;
|
|
map.Size:= map.Rows*map.Cols;
|
|
getmem(map.Buffer,map.Size);
|
|
Clear;
|
|
RenderQuality := grqHighQuality;
|
|
end;
|
|
|
|
function TFreeTypeGrayscaleMap.RenderGlyph(glyph: TFreeTypeGlyph; x, y: single): boolean;
|
|
var mono: TFreeTypeMonochromeMap;
|
|
psrc,pdest: pbyte;
|
|
xb,yb,tx: integer;
|
|
curBit: byte;
|
|
begin
|
|
case RenderQuality of
|
|
grqMonochrome:
|
|
begin
|
|
tx := Width;
|
|
mono := TFreeTypeMonochromeMap.Create(FRasterizer, tx,Height);
|
|
result := mono.RenderGlyph(glyph,x,y);
|
|
if result then
|
|
begin
|
|
for yb := mono.Height-1 downto 0 do
|
|
begin
|
|
psrc := mono.ScanLine[yb];
|
|
pdest := self.ScanLine[yb];
|
|
curBit := $80;
|
|
for xb := tx-1 downto 0 do
|
|
begin
|
|
if psrc^ and curBit <> 0 then
|
|
pdest^ := $ff;
|
|
curBit := curBit shr 1;
|
|
if curBit = 0 then
|
|
begin
|
|
curBit := $80;
|
|
inc(psrc);
|
|
end;
|
|
inc(pdest);
|
|
end;
|
|
end;
|
|
end;
|
|
mono.Free;
|
|
end;
|
|
grqLowQuality:
|
|
begin
|
|
FRasterizer.Set_Raster_Palette(RegularGray5);
|
|
result := TT_Get_Glyph_Pixmap(glyph.data, map, round(x*64), round((height-y)*64), FRasterizer) = TT_Err_Ok;
|
|
end;
|
|
grqHighQuality:
|
|
begin
|
|
result := TT_Get_Glyph_Pixmap_HQ(glyph.data, map, round(x*64), round((height-y)*64), FRasterizer) = TT_Err_Ok;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TFreeTypeGrayscaleMap.ScanMoveTo(x, y: integer);
|
|
begin
|
|
ScanPtrStart := pbyte(ScanLine[y]);
|
|
ScanX := x mod Width;
|
|
if ScanX < 0 then inc(ScanX,Width);
|
|
end;
|
|
|
|
function TFreeTypeGrayscaleMap.ScanNextPixel: byte;
|
|
begin
|
|
if ScanPtrStart = nil then
|
|
result := 0
|
|
else
|
|
begin
|
|
result := (ScanPtrStart+ScanX)^;
|
|
inc(ScanX);
|
|
if ScanX = map.Width then ScanX := 0;
|
|
end;
|
|
end;
|
|
|
|
function TFreeTypeGrayscaleMap.GetPixel(x, y: integer): byte;
|
|
begin
|
|
if (x < 0) or (x>= width) or (y <0) or (y >= height) then
|
|
result := 0
|
|
else
|
|
result := (pbyte(map.Buffer) + y*map.Cols + x)^;
|
|
end;
|
|
|
|
procedure TFreeTypeGrayscaleMap.SetPixel(x, y: integer; value: byte);
|
|
begin
|
|
if (x < 0) or (x>= width) or (y <0) or (y >= height) then
|
|
exit
|
|
else
|
|
(pbyte(map.Buffer) + y*map.Cols + x)^ := value;
|
|
end;
|
|
|
|
procedure TFreeTypeGrayscaleMap.XorPixel(x, y: integer; value: byte);
|
|
var p : pbyte;
|
|
begin
|
|
if (x < 0) or (x>= width) or (y <0) or (y >= height) then
|
|
exit
|
|
else
|
|
begin
|
|
p := (pbyte(map.Buffer) + y*map.Cols + x);
|
|
p^ := p^ xor value;
|
|
end;
|
|
end;
|
|
|
|
{ TFreeTypeRasterMap }
|
|
|
|
function TFreeTypeRasterMap.GetHeight: integer;
|
|
begin
|
|
result := map.Rows;
|
|
end;
|
|
|
|
function TFreeTypeRasterMap.GetWidth: integer;
|
|
begin
|
|
result := map.Width;
|
|
end;
|
|
|
|
function TFreeTypeRasterMap.GetScanLine(y: integer): pointer;
|
|
begin
|
|
if (y <0) or (y >= height) then
|
|
result := nil
|
|
else
|
|
Result:= pointer(pbyte(map.Buffer) + y*map.Cols);
|
|
end;
|
|
|
|
constructor TFreeTypeRasterMap.Create(AWidth, AHeight: integer);
|
|
begin
|
|
FRasterizer := TTGetDefaultRasterizer;
|
|
Init(AWidth,AHeight);
|
|
end;
|
|
|
|
constructor TFreeTypeRasterMap.Create(ARasterizer: TFreeTypeRasterizer; AWidth,
|
|
AHeight: integer);
|
|
begin
|
|
FRasterizer := ARasterizer;
|
|
Init(AWidth,AHeight);
|
|
end;
|
|
|
|
procedure TFreeTypeRasterMap.Clear;
|
|
begin
|
|
fillchar(map.Buffer^, map.Size, 0);
|
|
end;
|
|
|
|
procedure TFreeTypeRasterMap.Fill;
|
|
begin
|
|
fillchar(map.Buffer^, map.Size, $ff);
|
|
end;
|
|
|
|
destructor TFreeTypeRasterMap.Destroy;
|
|
begin
|
|
freemem(map.Buffer);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TFreeTypeMonochromeMap }
|
|
|
|
function TFreeTypeMonochromeMap.RenderGlyph(glyph: TFreeTypeGlyph; x,y: single): boolean;
|
|
begin
|
|
result := TT_Get_Glyph_Bitmap(glyph.data, map, round(x*64), round((height-y)*64), FRasterizer) = TT_Err_Ok;
|
|
end;
|
|
|
|
procedure TFreeTypeMonochromeMap.ScanMoveTo(x, y: integer);
|
|
begin
|
|
ScanPtrStart := pbyte(ScanLine[y]);
|
|
ScanX := x mod Width;
|
|
if ScanX < 0 then inc(ScanX,Width);
|
|
|
|
if ScanPtrStart <> nil then
|
|
begin
|
|
ScanPtrCur := ScanPtrStart + (ScanX shr 3);
|
|
ScanBit := $80 shr (ScanX and 7);
|
|
end else
|
|
begin
|
|
ScanPtrCur := nil;
|
|
ScanBit := 0;
|
|
end;
|
|
end;
|
|
|
|
function TFreeTypeMonochromeMap.ScanNextPixel: boolean;
|
|
begin
|
|
if ScanPtrCur = nil then
|
|
result := false
|
|
else
|
|
begin
|
|
result := (pbyte(ScanPtrCur)^ and ScanBit) <> 0;
|
|
inc(ScanX);
|
|
if ScanX = map.Width then
|
|
begin
|
|
ScanX := 0;
|
|
ScanBit := $80;
|
|
ScanPtrCur := ScanPtrStart;
|
|
end else
|
|
begin
|
|
ScanBit := ScanBit shr 1;
|
|
if ScanBit = 0 then
|
|
begin
|
|
ScanBit := $80;
|
|
inc(ScanPtrCur);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TFreeTypeMonochromeMap.GetPixel(x, y: integer): boolean;
|
|
begin
|
|
if (x < 0) or (x>= width) or (y <0) or (y >= height) then
|
|
result := false
|
|
else
|
|
result := (pbyte(map.Buffer) + y*map.Cols + (x shr 3))^ and ($80 shr (x and 7)) <> 0;
|
|
end;
|
|
|
|
procedure TFreeTypeMonochromeMap.SetPixel(x, y: integer; value: boolean);
|
|
var p: pbyte;
|
|
begin
|
|
if (x < 0) or (x>= width) or (y <0) or (y >= height) then
|
|
exit
|
|
else
|
|
begin
|
|
p := pbyte(map.Buffer) + y*map.Cols + (x shr 3);
|
|
if not value then
|
|
p^ := p^ and not ($80 shr (x and 7))
|
|
else
|
|
p^ := p^ or ($80 shr (x and 7));
|
|
end;
|
|
end;
|
|
|
|
function TFreeTypeMonochromeMap.GetPixelsInRect(x, y, x2, y2: integer): integer;
|
|
var yb: integer;
|
|
begin
|
|
result := 0;
|
|
|
|
if x < 0 then x := 0;
|
|
if x2 > width then x2 := width;
|
|
if x2 <= x then exit;
|
|
|
|
if y < 0 then y := 0;
|
|
if y2 > height then y2 := height;
|
|
for yb := y to y2-1 do
|
|
result += GetPixelsInHorizlineNoBoundsChecking(x,yb,x2-1);
|
|
end;
|
|
|
|
function TFreeTypeMonochromeMap.GetPixelsInHorizline(x, y, x2: integer): integer;
|
|
begin
|
|
if x < 0 then x := 0;
|
|
if x2 >= width then x2 := width-1;
|
|
if x2 <= x then
|
|
begin
|
|
result := 0;
|
|
exit;
|
|
end;
|
|
if (y < 0) or (y >= height) then
|
|
begin
|
|
result := 0;
|
|
exit;
|
|
end;
|
|
|
|
result := GetPixelsInHorizlineNoBoundsChecking(x,y,x2);
|
|
end;
|
|
|
|
function TFreeTypeMonochromeMap.GetPixelsInHorizlineNoBoundsChecking(x, y, x2: integer
|
|
): integer;
|
|
var p: pbyte;
|
|
ix,ix2: integer;
|
|
begin
|
|
result := 0;
|
|
ix := x shr 3;
|
|
ix2 := x2 shr 3;
|
|
p := pbyte(map.Buffer) + y*map.Cols + ix;
|
|
if ix2 > ix then
|
|
begin
|
|
result += BitCountTable[ p^ and ($ff shr (x and 7)) ];
|
|
inc(p^);
|
|
inc(ix);
|
|
while (ix2 > ix) do
|
|
begin
|
|
result += BitCountTable[p^];
|
|
inc(ix);
|
|
inc(p^);
|
|
end;
|
|
result += BitCountTable[ p^ and ($ff shl (x2 and 7 xor 7)) ];
|
|
end else
|
|
result += BitCountTable[ p^ and ($ff shr (x and 7)) and ($ff shl (x2 and 7 xor 7))];
|
|
end;
|
|
|
|
procedure TFreeTypeMonochromeMap.Init(AWidth, AHeight: integer);
|
|
begin
|
|
map.Width := AWidth;
|
|
map.Rows := AHeight;
|
|
map.Cols:= (AWidth+7) shr 3;
|
|
map.flow:= TT_Flow_Down;
|
|
map.Size:= map.Rows*map.Cols;
|
|
getmem(map.Buffer,map.Size);
|
|
Clear;
|
|
end;
|
|
|
|
procedure TFreeTypeMonochromeMap.TogglePixel(x, y: integer);
|
|
var p: pbyte;
|
|
begin
|
|
if (x < 0) or (x>= width) or (y <0) or (y >= height) then
|
|
exit
|
|
else
|
|
begin
|
|
p := pbyte(map.Buffer) + y*map.Cols + (x shr 3);
|
|
p^ := p^ xor ($80 shr (x and 7));
|
|
end;
|
|
end;
|
|
|
|
procedure InitTables;
|
|
var i: integer;
|
|
begin
|
|
for i := 0 to 255 do
|
|
begin
|
|
BitCountTable[i] := (i and 1) + (i shr 1 and 1) + (i shr 2 and 1) + (i shr 3 and 1) +
|
|
(i shr 4 and 1) + (i shr 5 and 1) + (i shr 6 and 1) + (i shr 7 and 1);
|
|
end;
|
|
|
|
RegularGray5[0] := 0;
|
|
RegularGray5[1] := $60;
|
|
RegularGray5[2] := $a0;
|
|
RegularGray5[3] := $d0;
|
|
RegularGray5[4] := $ff;
|
|
end;
|
|
|
|
initialization
|
|
|
|
FreeTypeInitialized := false;
|
|
FreeTypeCannotInitialize := false;
|
|
InitTables;
|
|
|
|
finalization
|
|
|
|
if FreeTypeInitialized then
|
|
begin
|
|
TT_Done_FreeType;
|
|
FreeTypeInitialized := false;
|
|
end;
|
|
|
|
end.
|
|
|