doublecmd/components/Image32/source/Img32.Text.pas
2025-03-23 21:11:06 +03:00

4464 lines
135 KiB
ObjectPascal

unit Img32.Text;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.8 *
* Date : 22 January 2025 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2025 *
* Purpose : TrueType fonts for TImage32 (without Windows dependencies) *
* License : http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
uses
{$IFDEF MSWINDOWS} Windows, ShlObj, ActiveX, {$ENDIF}
Types, SysUtils, Classes, Math,
{$IFDEF XPLAT_GENERICS} Generics.Collections, Generics.Defaults,{$ENDIF}
Img32, Img32.Draw, Img32.Vector;
type
TFixed = type single;
Int16 = type SmallInt;
TFontFormat = (ffInvalid, ffTrueType, ffCompact);
TFontFamily = (tfUnknown, tfSerif, tfSansSerif, tfMonospace);
TFontReader = class;
{$IFDEF MSWINDOWS}
PArrayOfEnumLogFontEx = ^TArrayOfEnumLogFontEx;
TArrayOfEnumLogFontEx = array of TEnumLogFontEx;
// TFontReaderFamily - a custom (Image32) record
TFontReaderFamily = record
regularFR : TFontReader;
boldFR : TFontReader;
italicFR : TFontReader;
boldItalicFR : TFontReader;
end;
{$ENDIF}
{$IFNDEF Unicode}
UnicodeString = WideString;
{$ENDIF}
TMacStyle = (msBold, msItalic, msUnderline, msOutline,
msShadow, msCondensed, msExtended);
TMacStyles = set of TMacStyle;
TTextAlign = (taLeft, taRight, taCenter, taJustify);
TTextVAlign = (tvaTop, tvaMiddle, tvaBottom);
// nb: Avoid "packed" records as these cause problems with Android
TFontHeaderTable = record
sfntVersion : Cardinal; // $10000 or 'OTTO'
numTables : WORD;
searchRange : WORD;
entrySelector : WORD;
rangeShift : WORD;
end;
TFontTable = record
tag : Cardinal;
checkSum : Cardinal;
offset : Cardinal;
length : Cardinal;
end;
TFontTable_Cmap = record
version : WORD;
numTables : WORD;
end;
TCmapTblRec = record
platformID : WORD; // Unicode = 0; Windows = 3 (obsolete);
encodingID : WORD;
offset : Cardinal;
end;
TCmapFormat0 = record
format : WORD; // 0
length : WORD;
language : WORD;
end;
TCmapFormat4 = record
format : WORD; // 4
length : WORD;
language : WORD;
segCountX2 : WORD;
searchRange : WORD;
entrySelector : WORD;
rangeShift : WORD;
//endCodes : array of WORD; // last = $FFFF
//reserved : WORD; // 0
//startCodes : array of WORD;
end;
TFormat4Rec = record
startCode : WORD;
endCode : WORD;
idDelta : WORD;
rangeOffset : WORD;
end;
TCmapFormat6 = record
format : WORD; // 6
length : WORD;
language : WORD;
firstCode : WORD;
entryCount : WORD;
end;
TCmapFormat12 = record
format : WORD; // 12
reserved : WORD; // 0
length : DWORD;
language : DWORD;
nGroups : DWORD;
//array[nGroups] of TFormat12Group;
end;
TFormat12Rec = record
startCode : WORD;
endCode : WORD;
idDelta : WORD;
rangeOffset : WORD;
end;
TFormat12Group = record
startCharCode : DWORD;
endCharCode : DWORD;
startGlyphCode: DWORD;
end;
TFontTable_Kern = record
version : WORD;
numTables : WORD;
end;
TKernSubTbl = record
version : WORD;
length : WORD;
coverage : WORD;
end;
TFormat0KernHdr = record
nPairs : WORD;
searchRange : WORD;
entrySelector : WORD;
rangeShift : WORD;
end;
TFormat0KernRec = record
left : WORD;
right : WORD;
value : int16;
end;
TArrayOfKernRecs = array of TFormat0KernRec;
TFontTable_Name = record
format : WORD;
count : WORD;
stringOffset : WORD;
//nameRecords[]
end;
TNameRec = record
platformID : WORD;
encodingID : WORD;
languageID : WORD;
nameID : WORD;
length : WORD;
offset : WORD;
end;
TFontTable_Head = record
majorVersion : WORD;
minorVersion : WORD;
fontRevision : TFixed;
checkSumAdjust : Cardinal;
magicNumber : Cardinal; // $5F0F3CF5
flags : WORD;
unitsPerEm : WORD;
dateCreated : UInt64;
dateModified : UInt64;
xMin : Int16;
yMin : Int16;
xMax : Int16;
yMax : Int16;
macStyle : WORD; // see TMacStyles
lowestRecPPEM : WORD;
fontDirHint : Int16; // left to right, right to left
indexToLocFmt : Int16;
glyphDataFmt : Int16;
end;
TFontTable_Maxp = record
version : TFixed;
numGlyphs : WORD;
maxPoints : WORD;
maxContours : WORD;
end;
TFontTable_Glyf = record
numContours : Int16;
xMin : Int16;
yMin : Int16;
xMax : Int16;
yMax : Int16;
end;
TFontTable_Hhea = record
version : TFixed;
ascent : Int16;
descent : Int16;
lineGap : Int16;
advWidthMax : WORD;
minLSB : Int16;
minRSB : Int16;
xMaxExtent : Int16;
caretSlopeRise : Int16;
caretSlopeRun : Int16;
caretOffset : Int16;
reserved : UInt64;
metricDataFmt : Int16;
numLongHorMets : WORD;
end;
TFontTable_Hmtx = record
advanceWidth : WORD;
leftSideBearing : Int16;
end;
TFontTable_Post = record
majorVersion : WORD;
minorVersion : WORD;
italicAngle : TFixed;
underlinePos : Int16;
underlineWidth : Int16;
isFixedPitch : Cardinal;
//minMemType42 : Cardinal;
//maxMemType42 : Cardinal;
//minMemType1 : Cardinal;
//maxMemType1 : Cardinal;
end;
ArrayOfUtf8String = array of Utf8String;
// TFontInfo: a custom summary record
TFontInfo = record
fontFormat : TFontFormat;
family : TFontFamily;
familyNames : ArrayOfUtf8String;
faceName : Utf8String;
fullFaceName : Utf8String;
style : Utf8String;
copyright : Utf8String;
manufacturer : Utf8String;
dateCreated : TDatetime;
dateModified : TDatetime;
macStyles : TMacStyles;
glyphCount : integer;
unitsPerEm : integer;
xMin : integer;
yMin : integer;
xMax : integer;
yMax : integer;
ascent : integer;
descent : integer;
lineGap : integer;
advWidthMax : integer;
minLSB : integer;
minRSB : integer;
xMaxExtent : integer;
end;
TKern = record
rightGlyphIdx : integer;
kernValue : integer;
end;
TArrayOfTKern = array of TKern;
///////////////////////////////////////////
// the following point structures are only
// used internally by the TFontReader class
TPointEx = record
pt: TPointD;
flag: byte;
end;
TPathEx = array of TPointEx;
TPathsEx = array of TPathEx;
///////////////////////////////////////////
PGlyphInfo = ^TGlyphInfo;
// TGlyphInfo: another custom record
TGlyphInfo = record
codepoint : integer;
glyphIdx : WORD;
unitsPerEm : integer;
glyf : TFontTable_Glyf;
hmtx : TFontTable_Hmtx;
kernList : TArrayOfTKern;
paths : TPathsD;
end;
TFontTableArray = array of TFontTable;
TArrayOfWord = array of WORD;
TArrayOfCardinal = array of Cardinal;
TArrayOfCmapTblRec = array of TCmapTblRec;
TTableName = (tblName, tblHead, tblHhea,
tblCmap, tblMaxp, tblLoca, tblGlyf,
tblHmtx, tblKern, tblPost);
{$IFDEF ZEROBASEDSTR}
{$ZEROBASEDSTRINGS OFF}
{$ENDIF}
TLoadFontResult = (lfrSuccess, lfrDuplicate, lfrInvalid);
TFontManager = class
private
fMaxFonts: integer;
{$IFDEF XPLAT_GENERICS}
fFontList: TList<TFontReader>;
{$ELSE}
fFontList: TList;
{$ENDIF}
procedure SetMaxFonts(value: integer);
procedure SortFontListOnLastUse;
procedure DeleteOldestFont;
function ValidateFontLoad(var fr: TFontReader): TLoadFontResult;
function FindDuplicate(fr: TFontReader): integer;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
{$IFDEF MSWINDOWS}
// LoadFontReaderFamily: call will fail if the fonts have already been
// loaded, or if the font family hasn't been installed in the PC.
function LoadFontReaderFamily(const fontFamily: string): TLoadFontResult; overload;
function LoadFontReaderFamily(const fontFamily: string;
out fontReaderFamily: TFontReaderFamily): TLoadFontResult; overload;
function LoadFontReader(const fontName: string): TFontReader;
{$ENDIF}
function LoadFromStream(stream: TStream): TFontReader;
function LoadFromResource(const resName: string; resType: PChar): TFontReader;
function LoadFromFile(const filename: string): TFontReader;
function GetBestMatchFont(const fontInfo: TFontInfo): TFontReader; overload;
function GetBestMatchFont(const styles: TMacStyles): TFontReader; overload;
// FindReaderContainingGlyph: returns a TFontReader object containing the
// specified glyph, otherwise nil. If a fontfamily is spedified, then the
// search is limited to within that font family. If a TFontReader is found
// then the out 'glyphIdx' parameter contains the index to the glyph
// matching the supplied codepoint.
function FindReaderContainingGlyph(codepoint: Cardinal;
fntFamily: TFontFamily; out glyphIdx: WORD): TFontReader;
function Delete(fontReader: TFontReader): Boolean;
property MaxFonts: integer read fMaxFonts write SetMaxFonts;
end;
TFontReader = class(TInterfacedObj, INotifySender)
private
fFontManager : TFontManager;
fDestroying : Boolean;
fUpdateCount : integer;
fRecipientList : TRecipients;
fLastUsedTime : TDateTime;
fStream : TMemoryStream;
fFontWeight : integer;
fFontInfo : TFontInfo;
fTables : TFontTableArray;
fTblIdxes : array[TTableName] of integer;
fTbl_name : TFontTable_Name;
fTbl_head : TFontTable_Head;
fTbl_hhea : TFontTable_Hhea;
fTbl_cmap : TFontTable_Cmap;
fTbl_maxp : TFontTable_Maxp;
fTbl_post : TFontTable_Post;
fTbl_loca2 : TArrayOfWord;
fTbl_loca4 : TArrayOfCardinal;
fKernTable : TArrayOfKernRecs;
fFormat0CodeMap : array of byte;
fFormat4CodeMap : array of TFormat4Rec;
fFormat12CodeMap : array of TFormat12Group;
fFormat4Offset : integer;
function GetTables: Boolean;
function GetTable_name: Boolean;
function GetTable_cmap: Boolean;
function GetTable_maxp: Boolean;
function GetTable_head: Boolean;
function GetTable_loca: Boolean;
function IsValidFontTable(const tbl : TFontTable): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
function GetTable_hhea: Boolean;
procedure GetTable_kern;
procedure GetTable_post;
procedure GetFontFamily;
function GetGlyphPaths(glyphIdx: WORD;
var tbl_hmtx: TFontTable_Hmtx; out tbl_glyf: TFontTable_Glyf): TPathsEx;
function GetGlyphIdxUsingCmap(codePoint: Cardinal): WORD;
function GetSimpleGlyph(tbl_glyf: TFontTable_Glyf): TPathsEx;
function GetCompositeGlyph(var tbl_glyf: TFontTable_Glyf;
var tbl_hmtx: TFontTable_Hmtx): TPathsEx;
function ConvertSplinesToBeziers(const pathsEx: TPathsEx): TPathsEx;
procedure GetPathCoords(var paths: TPathsEx);
function GetGlyphHorzMetrics(glyphIdx: WORD): TFontTable_Hmtx;
function GetFontInfo: TFontInfo;
function GetGlyphKernList(glyphIdx: WORD): TArrayOfTKern;
function GetGlyphInfoInternal(glyphIdx: WORD): TGlyphInfo;
function GetWeight: integer;
procedure BeginUpdate;
procedure EndUpdate;
procedure NotifyRecipients(notifyFlag: TImg32Notification);
protected
property LastUsedTime: TDatetime read fLastUsedTime write fLastUsedTime;
property PostTable: TFontTable_Post read fTbl_post;
public
constructor Create; overload;
constructor CreateFromResource(const resName: string; resType: PChar);
{$IFDEF MSWINDOWS}
constructor Create(const fontname: string); overload;
{$ENDIF}
destructor Destroy; override;
procedure Clear;
procedure AddRecipient(recipient: INotifyRecipient);
procedure DeleteRecipient(recipient: INotifyRecipient);
function IsValidFontFormat: Boolean;
function HasGlyph(codepoint: Cardinal): Boolean;
function LoadFromStream(stream: TStream): Boolean;
function LoadFromResource(const resName: string; resType: PChar): Boolean;
function LoadFromFile(const filename: string): Boolean;
{$IFDEF MSWINDOWS}
function Load(const FontName: string): Boolean; overload;
function Load(const logFont: TLogFont): Boolean; overload;
function LoadUsingFontHdl(hdl: HFont): Boolean;
{$ENDIF}
function GetGlyphInfo(codepoint: Cardinal;
out nextX: integer; out glyphInfo: TGlyphInfo): Boolean;
property FontFamily: TFontFamily read fFontInfo.family;
property FontInfo: TFontInfo read GetFontInfo;
property Weight: integer read GetWeight; // range 100-900
end;
TPageTextMetrics = record
bounds : TRect;
lineCount : integer;
lineHeight : double;
topLinePxOffset : integer;
nextChuckIdx : integer;
startOfLineIdx : TArrayOfInteger;
justifyDeltas : TArrayOfDouble;
lineWidths : TArrayOfDouble;
end;
TFontCache = class;
TChunkedText = class;
TTextChunk = class
public
owner : TChunkedText;
index : integer;
text : UnicodeString;
left : double;
top : double;
width : double;
height : double;
backColor : TColor32;
fontColor : TColor32;
ascent : double;
userData : Pointer;
glyphOffsets : TArrayOfDouble;
arrayOfPaths : TArrayOfPathsD;
constructor Create(owner: TChunkedText; const chunk: UnicodeString;
index: integer; fontCache: TFontCache; fontColor: TColor32;
backColor: TColor32 = clNone32);
end;
TDrawChunkEvent = procedure(chunk: TTextChunk; const chunkRec: TRectD) of object;
// TChunkedText: A font formatted list of text 'chunks' (usually space
// seperated words) that will greatly speed up displaying word-wrapped text.
TChunkedText = class
private
fSpaceWidth : double;
fLastFont : TFontCache;
{$IFDEF XPLAT_GENERICS}
fList : TList<TTextChunk>;
{$ELSE}
fList : TList;
{$ENDIF}
fDrawChunkEvent: TDrawChunkEvent;
function GetChunk(index: integer): TTextChunk;
function GetText: UnicodeString;
function GetCount: integer;
protected
function GetGlyphsOrDrawInternal(image: TImage32; const rec: TRect;
textAlign: TTextAlign; textAlignV: TTextVAlign; startChunk: integer;
lineHeight: double; out paths: TPathsD): TPageTextMetrics;
public
constructor Create; overload;
constructor Create(const text: string; font: TFontCache;
fontColor: TColor32 = clBlack32; backColor: TColor32 = clNone32); overload;
destructor Destroy; override;
procedure Clear;
procedure DeleteChunk(Index: Integer);
procedure DeleteChunkRange(startIdx, endIdx: Integer);
procedure AddNewline(font: TFontCache);
procedure AddSpace(font: TFontCache); overload;
function GetPageMetrics(const rec: TRect; lineHeight: double;
startingChunkIdx: integer): TPageTextMetrics;
function GetChunkAndGlyphOffsetAtPt(const ptm: TPageTextMetrics;
const pt: TPoint; out glyphIdx, chunkChrOff: integer): Boolean;
function InsertTextChunk(font: TFontCache; index: integer;
const chunk: UnicodeString; fontColor: TColor32 = clBlack32;
backColor: TColor32 = clNone32): TTextChunk;
function AddTextChunk(font: TFontCache; const chunk: UnicodeString;
fontColor: TColor32 = clBlack32;
backColor: TColor32 = clNone32): TTextChunk;
procedure SetText(const text: UnicodeString; font: TFontCache;
fontColor: TColor32 = clBlack32; backColor: TColor32 = clNone32);
// DrawText: see Examples/FMX2, Examples/Text & Examples/Experimental apps.
function DrawText(image: TImage32; const rec: TRect;
textAlign: TTextAlign; textAlignV: TTextVAlign;
startChunk: integer; lineHeight: double = 0.0): TPageTextMetrics;
function GetTextGlyphs(const rec: TRect;
textAlign: TTextAlign; textAlignV: TTextVAlign; startChunk: integer;
lineHeight: double = 0.0): TPathsD;
procedure ApplyNewFont(font: TFontCache);
property Count: integer read GetCount;
property Chunk[index: integer]: TTextChunk read GetChunk; default;
property Text: UnicodeString read GetText;
property OnDrawChunk: TDrawChunkEvent
read fDrawChunkEvent write fDrawChunkEvent;
end;
// TFontCache: speeds up text rendering by parsing font files only once
// for each accessed character. It can also scale glyphs to a specified
// font height and invert glyphs too (which is necessary on Windows PCs).
TFontCache = class(TInterfacedObj, INotifySender, INotifyRecipient)
private
{$IFDEF XPLAT_GENERICS}
fGlyphInfoList : TList<PGlyphInfo>;
{$ELSE}
fGlyphInfoList : TList;
{$ENDIF}
fFontReader : TFontReader;
fRecipientList : TRecipients;
fSorted : Boolean;
fScale : double;
fUseKerning : Boolean;
fFontHeight : double;
fFlipVert : Boolean;
fUnderlined : Boolean;
fStrikeOut : Boolean;
procedure NotifyRecipients(notifyFlag: TImg32Notification);
function FoundInList(charOrdinal: Cardinal): Boolean;
function AddGlyph(codepoint: Cardinal): PGlyphInfo;
procedure VerticalFlip(var paths: TPathsD);
procedure SetFlipVert(value: Boolean);
procedure SetFontHeight(newHeight: double);
procedure SetFontReader(newFontReader: TFontReader);
procedure UpdateScale;
procedure Sort;
procedure GetMissingGlyphs(const ordinals: TArrayOfCardinal);
function IsValidFont: Boolean;
function GetAscent: double;
function GetDescent: double;
function GetGap: double;
function GetLineHeight: double;
function GetYyHeight: double;
function GetTextOutlineInternal(x, y: double; const text: UnicodeString;
underlineIdx: integer; out glyphs: TArrayOfPathsD;
out offsets: TArrayOfDouble; out nextX: double): Boolean; overload;
procedure UpdateFontReaderLastUsedTime;
public
constructor Create(fontReader: TFontReader = nil; fontHeight: double = 10); overload;
destructor Destroy; override;
procedure Clear;
// TFontCache is both an INotifySender and an INotifyRecipient.
// It receives notifications from a TFontReader object and it sends
// notificiations to any number of TFontCache object users
procedure ReceiveNotification(Sender: TObject; notify: TImg32Notification);
procedure AddRecipient(recipient: INotifyRecipient);
procedure DeleteRecipient(recipient: INotifyRecipient);
function GetGlyphInfo(codepoint: Cardinal): PGlyphInfo;
function GetTextOutline(x, y: double; const text: UnicodeString): TPathsD; overload;
function GetTextOutline(const rec: TRectD; const text: UnicodeString;
ta: TTextAlign; tav: TTextVAlign; underlineIdx: integer = 0): TPathsD; overload;
function GetTextOutline(x, y: double; const text: UnicodeString;
out nextX: double; underlineIdx: integer = 0): TPathsD; overload;
// GetUnderlineOutline - another way to underline text. 'y' indicates the
// text baseline, and 'dy' is the offset from that baseline.
// if dy = InvalidD then the default offset is used (& based on linewidth).
function GetUnderlineOutline(leftX, rightX, y: double; dy: double = invalidD;
wavy: Boolean = false; strokeWidth: double = 0): TPathD;
function GetVerticalTextOutline(x, y: double;
const text: UnicodeString; lineHeight: double = 0.0): TPathsD;
function GetAngledTextGlyphs(x, y: double; const text: UnicodeString;
angleRadians: double; const rotatePt: TPointD;
out nextPt: TPointD): TPathsD;
// GetGlyphOffsets - there isn't always a one-to-one relationship between
// text characters and glyphs since text can on occasions contain
// "surrogate paired" characters (eg emoji characters).
function GetGlyphOffsets(const text: UnicodeString;
interCharSpace: double = 0): TArrayOfDouble;
// As per the comment above, there isn't always a one-to-one relationship
// between text characters and their codepoints (2 byte chars vs 4 bytes)
function GetTextCodePoints(const text: UnicodeString): TArrayOfCardinal;
function GetTextWidth(const text: UnicodeString): double;
function CountCharsThatFit(const text: UnicodeString; maxWidth: double): integer;
function GetSpaceWidth: double;
property Ascent : double read GetAscent;
property Descent : double read GetDescent;
property LineGap : double read GetGap;
property FontHeight : double read fFontHeight write SetFontHeight;
property FontReader : TFontReader read fFontReader write SetFontReader;
property InvertY : boolean read fFlipVert write SetFlipVert;
property Kerning : boolean read fUseKerning write fUseKerning;
property LineHeight : double read GetLineHeight;
property YyHeight : double read GetYyHeight;
property Scale : double read fScale;
property Underlined : Boolean read fUnderlined write fUnderlined;
property StrikeOut : Boolean read fStrikeOut write fStrikeOut;
end;
function DrawText(image: TImage32; x, y: double;
const text: UnicodeString; font: TFontCache;
textColor: TColor32 = clBlack32): double; overload;
procedure DrawText(image: TImage32; const rec: TRectD;
const text: UnicodeString; font: TFontCache;
textColor: TColor32 = clBlack32; align: TTextAlign = taCenter;
valign: TTextVAlign = tvaMiddle); overload;
function DrawText(image: TImage32; x, y: double;
const text: UnicodeString; font: TFontCache;
renderer: TCustomRenderer): double; overload;
function DrawAngledText(image: TImage32;
x, y: double; angleRadians: double;
const text: UnicodeString; font: TFontCache;
textColor: TColor32 = clBlack32): TPointD;
procedure DrawVerticalText(image: TImage32;
x, y: double; const text: UnicodeString; font: TFontCache;
lineHeight: double = 0.0; textColor: TColor32 = clBlack32);
function GetTextOutlineOnPath(const text: UnicodeString;
const path: TPathD; font: TFontCache; textAlign: TTextAlign;
x, y: double; charSpacing: double;
out charsThatFit: integer; out outX: double): TPathsD; overload;
function GetTextOutlineOnPath(const text: UnicodeString;
const path: TPathD; font: TFontCache; textAlign: TTextAlign;
perpendicOffset: integer = 0; charSpacing: double = 0): TPathsD; overload;
function GetTextOutlineOnPath(const text: UnicodeString;
const path: TPathD; font: TFontCache; textAlign: TTextAlign;
perpendicOffset: integer; charSpacing: double;
out charsThatFit: integer): TPathsD; overload;
function GetTextOutlineOnPath(const text: UnicodeString;
const path: TPathD; font: TFontCache; x, y: integer;
charSpacing: double; out outX: double): TPathsD; overload;
{$IFDEF MSWINDOWS}
procedure FontHeightToFontSize(var logFontHeight: integer);
procedure FontSizeToFontHeight(var logFontHeight: integer);
function GetFontPixelHeight(logFontHeight: integer): double;
function GetFontFolder: string;
function GetInstalledTtfFilenames: TArrayOfString;
// GetLogFonts: using DEFAULT_CHARSET will get logfonts
// for ALL charsets that match the specified faceName.
function GetLogFonts(const faceName: string;
charSet: byte = DEFAULT_CHARSET): TArrayOfEnumLogFontEx;
// GetLogFontFromEnumThatMatchesStyles:
// will return false when no style match is found
function GetLogFontFromEnumThatMatchesStyles(LogFonts: TArrayOfEnumLogFontEx;
styles: TMacStyles; out logFont: TLogFont): Boolean;
{$ENDIF}
function FontManager: TFontManager;
implementation
uses
Img32.Transform;
resourcestring
rsChunkedTextRangeError =
'TChunkedText: range error.';
rsFontCacheError =
'TFontCache error: notification received from the wrong TFontReader';
rsChunkedTextFontError =
'TChunkedText: invalid font error.';
var
aFontManager: TFontManager;
const
lineFrac = 0.05;
SPACE = ' ';
//------------------------------------------------------------------------------
// Miscellaneous functions
//------------------------------------------------------------------------------
// GetMeaningfulDateTime: returns UTC date & time
procedure GetMeaningfulDateTime(const secsSince1904: Uint64;
out yy,mo,dd, hh,mi,ss: cardinal);
const
dayInYrAtMthStart: array[boolean, 0..12] of cardinal =
((0,31,59,90,120,151,181,212,243,273,304,334,365), // non-leap year
(0,31,60,91,121,152,182,213,244,274,305,335,366)); // leap year
var
isLeapYr: Boolean;
const
maxValidYear = 2100;
secsPerHour = 3600;
secsPerDay = 86400;
secsPerNormYr = 31536000;
secsPerLeapYr = secsPerNormYr + secsPerDay;
secsPer4Years = secsPerNormYr * 3 + secsPerLeapYr; // 126230400;
begin
// Leap years are divisble by 4, except for centuries which are not
// leap years unless they are divisble by 400. (Hence 2000 was a leap year,
// but 1900 was not. But 1904 was a leap year because it's divisble by 4.)
// Validate at http://www.mathcats.com/explore/elapsedtime.html
ss := (secsSince1904 div secsPer4Years); // count '4years' since 1904
// manage invalid dates
if (secsSince1904 = 0) or
(ss > (maxValidYear-1904) div 4) then
begin
yy := 1904; mo := 1; dd := 1;
hh := 0; mi := 0; ss := 0;
Exit;
end;
yy := 1904 + (ss * 4);
ss := secsSince1904 mod secsPer4Years; // secs since last leap yr
isLeapYr := ss < secsPerLeapYr;
if not isLeapYr then
begin
dec(ss, secsPerLeapYr);
yy := yy + (ss div secsPerNormYr) + 1;
ss := ss mod secsPerNormYr; // remaining secs in final year
end;
dd := 1 + ss div secsPerDay; // day number in final year
mo := 1; // 1, because mo is base 1
while dayInYrAtMthStart[isLeapYr, mo] < dd do inc(mo);
// remaining secs in month
ss := ss - (dayInYrAtMthStart[isLeapYr, mo -1] * secsPerDay);
dd := 1 + (ss div secsPerDay); // because dd is base 1 too
ss := ss mod secsPerDay;
hh := ss div secsPerHour;
ss := ss mod secsPerHour;
mi := ss div 60;
ss := ss mod 60;
end;
//------------------------------------------------------------------------------
function MergeArrayOfPaths(const pa: TArrayOfPathsD): TPathsD;
var
i, j: integer;
resultCount: integer;
begin
Result := nil;
// Preallocate the Result-Array
resultCount := 0;
for i := 0 to High(pa) do
inc(resultCount, Length(pa[i]));
SetLength(Result, resultCount);
resultCount := 0;
for i := 0 to High(pa) do
begin
for j := 0 to High(pa[i]) do
begin
Result[resultCount] := pa[i][j];
inc(resultCount);
end;
end;
end;
//------------------------------------------------------------------------------
// MergeArrayOfPathsEx - merges AND translates/offsets paths
function MergeArrayOfPathsEx(const pa: TArrayOfPathsD; dx, dy: double): TPathsD;
var
i, j: integer;
resultCount: integer;
begin
Result := nil;
// Preallocate the Result-Array
resultCount := 0;
for i := 0 to High(pa) do
inc(resultCount, Length(pa[i]));
SetLength(Result, resultCount);
resultCount := 0;
for i := 0 to High(pa) do
begin
for j := 0 to High(pa[i]) do
begin
Result[resultCount] := TranslatePath(pa[i][j], dx, dy);
inc(resultCount);
end;
end;
end;
//------------------------------------------------------------------------------
function WordSwap(val: WORD): WORD;
{$IFDEF ASM_X86}
asm
rol ax,8;
end;
{$ELSE}
var
v: array[0..1] of byte absolute val;
r: array[0..1] of byte absolute result;
begin
r[0] := v[1];
r[1] := v[0];
end;
{$ENDIF}
//------------------------------------------------------------------------------
function Int16Swap(val: Int16): Int16;
{$IFDEF ASM_X86}
asm
rol ax,8;
end;
{$ELSE}
var
v: array[0..1] of byte absolute val;
r: array[0..1] of byte absolute result;
begin
r[0] := v[1];
r[1] := v[0];
end;
{$ENDIF}
//------------------------------------------------------------------------------
function Int32Swap(val: integer): integer;
{$IFDEF ASM_X86}
asm
bswap eax
end;
{$ELSE}
var
i: integer;
v: array[0..3] of byte absolute val;
r: array[0..3] of byte absolute Result; // warning: do not inline
begin
for i := 0 to 3 do r[3-i] := v[i];
end;
{$ENDIF}
//------------------------------------------------------------------------------
function UInt64Swap(val: UInt64): UInt64;
{$IFDEF ASM_X86}
asm
MOV EDX, val.Int64Rec.Lo
BSWAP EDX
MOV EAX, val.Int64Rec.Hi
BSWAP EAX
end;
{$ELSE}
var
i: integer;
v: array[0..7] of byte absolute val;
r: array[0..7] of byte absolute Result;
begin
for i := 0 to 7 do r[7-i] := v[i];
end;
{$ENDIF}
//------------------------------------------------------------------------------
procedure GetByte(stream: TStream; out value: byte);
{$IFDEF INLINE} inline; {$ENDIF}
begin
stream.Read(value, 1);
end;
//------------------------------------------------------------------------------
procedure GetShortInt(stream: TStream; out value: ShortInt);
{$IFDEF INLINE} inline; {$ENDIF}
begin
stream.Read(value, 1);
end;
//------------------------------------------------------------------------------
function GetWord(stream: TStream; out value: WORD): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
begin
result := stream.Position + SizeOf(value) < stream.Size;
if not Result then Exit;
stream.Read(value, SizeOf(value));
value := WordSwap(value);
end;
//------------------------------------------------------------------------------
function GetInt16(stream: TStream; out value: Int16): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
begin
result := stream.Position + SizeOf(value) < stream.Size;
if not Result then Exit;
stream.Read(value, SizeOf(value));
value := Int16Swap(value);
end;
//------------------------------------------------------------------------------
function GetCardinal(stream: TStream; out value: Cardinal): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
begin
result := stream.Position + SizeOf(value) < stream.Size;
if not Result then Exit;
stream.Read(value, SizeOf(value));
value := Cardinal(Int32Swap(Integer(value)));
end;
//------------------------------------------------------------------------------
function GetInt(stream: TStream; out value: integer): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
begin
result := stream.Position + SizeOf(value) < stream.Size;
if not Result then Exit;
stream.Read(value, SizeOf(value));
value := Int32Swap(value);
end;
//------------------------------------------------------------------------------
function GetUInt64(stream: TStream; out value: UInt64): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
begin
result := stream.Position + SizeOf(value) < stream.Size;
if not Result then Exit;
stream.Read(value, SizeOf(value));
value := UInt64Swap(value);
end;
//------------------------------------------------------------------------------
function Get2Dot14(stream: TStream; out value: single): Boolean;
var
val: Int16;
begin
result := GetInt16(stream, val);
if result then value := val * 6.103515625e-5; // 16384;
end;
//------------------------------------------------------------------------------
function GetFixed(stream: TStream; out value: TFixed): Boolean;
var
val: integer;
begin
result := GetInt(stream, val);
value := val * 1.52587890625e-5; // 1/35536
end;
//------------------------------------------------------------------------------
function GetWideString(stream: TStream; len: integer): Utf8String;
var
i: integer;
w: WORD;
s: UnicodeString;
begin
len := len div 2;
setLength(s, len);
for i := 1 to len do
begin
GetWord(stream, w);
if w = 0 then
begin
SetLength(s, i -1);
break;
end;
s[i] := WideChar(w);
end;
Result := Utf8String(s);
end;
//------------------------------------------------------------------------------
function GetUtf8String(stream: TStream; len: integer): Utf8String;
var
i: integer;
begin
setLength(Result, len+1);
Result[len+1] := #0;
stream.Read(Result[1], len);
for i := 1 to length(Result) do
if Result[i] = #0 then
begin
SetLength(Result, i -1);
break;
end;
end;
//------------------------------------------------------------------------------
function SameText(const text1, text2: Utf8String): Boolean; overload;
var
len: integer;
begin
len := Length(text1);
Result := (Length(text2) = len) and
((len = 0) or CompareMem(@text1[1], @text2[1], len));
end;
//------------------------------------------------------------------------------
// TTrueTypeReader
//------------------------------------------------------------------------------
constructor TFontReader.Create;
begin
fStream := TMemoryStream.Create;
end;
//------------------------------------------------------------------------------
constructor TFontReader.CreateFromResource(const resName: string; resType: PChar);
begin
Create;
LoadFromResource(resName, resType);
end;
//------------------------------------------------------------------------------
{$IFDEF MSWINDOWS}
constructor TFontReader.Create(const fontname: string);
begin
Create;
Load(fontname);
end;
//------------------------------------------------------------------------------
{$ENDIF}
destructor TFontReader.Destroy;
begin
Clear;
NotifyRecipients(inDestroy);
fStream.Free;
if Assigned(fFontManager) then
begin
fDestroying := true;
fFontManager.Delete(self);
end;
inherited;
end;
//------------------------------------------------------------------------------
procedure TFontReader.Clear;
begin
fTables := nil;
fFormat4CodeMap := nil;
fFormat12CodeMap := nil;
fKernTable := nil;
FillChar(fTbl_post, SizeOf(fTbl_post), 0);
fFontInfo.fontFormat := ffInvalid;
fFontInfo.family := tfUnknown;
fFontWeight := 0;
fStream.Clear;
NotifyRecipients(inStateChange);
end;
//------------------------------------------------------------------------------
procedure TFontReader.BeginUpdate;
begin
inc(fUpdateCount);
end;
//------------------------------------------------------------------------------
procedure TFontReader.EndUpdate;
begin
dec(fUpdateCount);
if fUpdateCount = 0 then NotifyRecipients(inStateChange);
end;
//------------------------------------------------------------------------------
procedure TFontReader.NotifyRecipients(notifyFlag: TImg32Notification);
var
i: integer;
begin
if fUpdateCount > 0 then Exit;
for i := High(fRecipientList) downto 0 do
try
// try .. except block because when TFontReader is destroyed in a
// finalization section, it's possible for recipients to have been
// destroyed without calling their destructors.
fRecipientList[i].ReceiveNotification(self, notifyFlag);
except
end;
end;
//------------------------------------------------------------------------------
procedure TFontReader.AddRecipient(recipient: INotifyRecipient);
var
len: integer;
begin
len := Length(fRecipientList);
SetLength(fRecipientList, len+1);
fRecipientList[len] := Recipient;
end;
//------------------------------------------------------------------------------
procedure TFontReader.DeleteRecipient(recipient: INotifyRecipient);
var
i, highI: integer;
begin
highI := High(fRecipientList);
i := highI;
while (i >= 0) and (fRecipientList[i] <> Recipient) do dec(i);
if i < 0 then Exit;
if i < highI then
Move(fRecipientList[i+1], fRecipientList[i],
(highI - i) * SizeOf(INotifyRecipient));
SetLength(fRecipientList, highI);
end;
//------------------------------------------------------------------------------
function TFontReader.IsValidFontFormat: Boolean;
begin
result := fFontInfo.fontFormat = ffTrueType;
end;
//------------------------------------------------------------------------------
function TFontReader.LoadFromStream(stream: TStream): Boolean;
begin
BeginUpdate;
try
Clear;
fStream.CopyFrom(stream, 0);
fStream.Position := 0;
result := GetTables;
if not result then Clear;
finally
EndUpdate;
end;
end;
//------------------------------------------------------------------------------
function TFontReader.LoadFromResource(const resName: string; resType: PChar): Boolean;
var
rs: TResourceStream;
begin
BeginUpdate;
rs := CreateResourceStream(resName, resType);
try
Result := assigned(rs) and LoadFromStream(rs);
finally
rs.free;
EndUpdate;
end;
end;
//------------------------------------------------------------------------------
function TFontReader.LoadFromFile(const filename: string): Boolean;
var
fs: TFileStream;
begin
try
fs := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone);
try
Result := LoadFromStream(fs);
finally
fs.free;
end;
except
Result := False;
end;
end;
//------------------------------------------------------------------------------
{$IFDEF MSWINDOWS}
function GetFontMemStreamFromFontHdl(hdl: HFont;
memStream: TMemoryStream): Boolean;
var
memDc: HDC;
cnt: DWORD;
begin
result := false;
if not Assigned(memStream) or (hdl = 0) then Exit;
memDc := CreateCompatibleDC(0);
try
if SelectObject(memDc, hdl) = 0 then Exit;
// get the required size of the font data (file)
cnt := Windows.GetFontData(memDc, 0, 0, nil, 0);
result := cnt <> $FFFFFFFF;
if not Result then Exit;
// copy the font data into the memory stream
memStream.SetSize(cnt);
Windows.GetFontData(memDc, 0, 0, memStream.Memory, cnt);
finally
DeleteDC(memDc);
end;
end;
//------------------------------------------------------------------------------
function TFontReader.LoadUsingFontHdl(hdl: HFont): Boolean;
var
ms: TMemoryStream;
begin
ms := TMemoryStream.Create;
try
Result := GetFontMemStreamFromFontHdl(hdl, ms) and
LoadFromStream(ms);
finally
ms.Free;
end;
end;
//------------------------------------------------------------------------------
function TFontReader.Load(const FontName: string): Boolean;
var
lf: TLogFont;
begin
Result := false;
if fontname = '' then Exit;
FillChar(lf, sizeof(TLogFont), 0);
lf.lfCharSet := DEFAULT_CHARSET;
Move(fontname[1], lf.lfFaceName[0], Length(fontname) * SizeOf(Char));
Result := Load(lf);
end;
//------------------------------------------------------------------------------
function TFontReader.Load(const logFont: TLogFont): Boolean;
var
hdl: HFont;
begin
Result := false;
hdl := CreateFontIndirect({$IFDEF FPC}@{$ENDIF}logfont);
if hdl > 0 then
try
Result := LoadUsingFontHdl(hdl);
finally
DeleteObject(hdl);
end;
end;
//------------------------------------------------------------------------------
{$ENDIF}
function GetHeaderTable(stream: TStream;
out headerTable: TFontHeaderTable): Boolean;
begin
result := stream.Position < stream.Size - SizeOf(TFontHeaderTable);
if not result then Exit;
GetCardinal(stream, headerTable.sfntVersion);
GetWord(stream, headerTable.numTables);
GetWord(stream, headerTable.searchRange);
GetWord(stream, headerTable.entrySelector);
GetWord(stream, headerTable.rangeShift);
end;
//------------------------------------------------------------------------------
function TFontReader.IsValidFontTable(const tbl : TFontTable): Boolean;
begin
Result := (fStream.Size >= tbl.offset + tbl.length);
end;
//------------------------------------------------------------------------------
function TFontReader.GetTables: Boolean;
var
i, tblCount: integer;
tbl: TTableName;
headerTable: TFontHeaderTable;
begin
result := false;
if not GetHeaderTable(fStream, headerTable) then Exit;
tblCount := headerTable.numTables;
result := fStream.Position < fStream.Size - SizeOf(TFontTable) * tblCount;
if not result then Exit;
for tbl := low(TTableName) to High(TTableName) do fTblIdxes[tbl] := -1;
SetLength(fTables, tblCount);
for i := 0 to tblCount -1 do
begin
GetCardinal(fStream, fTables[i].tag);
GetCardinal(fStream, fTables[i].checkSum);
GetCardinal(fStream, fTables[i].offset);
GetCardinal(fStream, fTables[i].length);
case
fTables[i].tag of
$6E616D65: fTblIdxes[tblName] := i;
$68656164: fTblIdxes[tblHead] := i;
$676C7966: fTblIdxes[tblGlyf] := i;
$6C6F6361: fTblIdxes[tblLoca] := i;
$6D617870: fTblIdxes[tblMaxp] := i;
$636D6170: fTblIdxes[tblCmap] := i;
$68686561: fTblIdxes[tblHhea] := i;
$686D7478: fTblIdxes[tblHmtx] := i;
$6B65726E: fTblIdxes[tblKern] := i;
$706F7374: fTblIdxes[tblPost] := i;
end;
end;
if fTblIdxes[tblName] < 0 then fFontInfo.fontFormat := ffInvalid
else if fTblIdxes[tblGlyf] < 0 then fFontInfo.fontFormat := ffCompact
else fFontInfo.fontFormat := ffTrueType;
result := (fFontInfo.fontFormat = ffTrueType) and
(fTblIdxes[tblName] >= 0) and GetTable_name and
(fTblIdxes[tblHead] >= 0) and GetTable_head and
(fTblIdxes[tblHhea] >= 0) and GetTable_hhea and
(fTblIdxes[tblMaxp] >= 0) and GetTable_maxp and
(fTblIdxes[tblLoca] >= 0) and GetTable_loca and // loca must follow maxp
(fTblIdxes[tblCmap] >= 0) and GetTable_cmap and
(fTblIdxes[tblHmtx] >= 0) and IsValidFontTable(fTables[fTblIdxes[tblHmtx]]);
if not Result then Exit;
if (fTblIdxes[tblKern] >= 0) then GetTable_kern;
if (fTblIdxes[tblPost] >= 0) then GetTable_post;
GetFontFamily;
end;
//------------------------------------------------------------------------------
function TFontReader.GetTable_cmap: Boolean;
var
i,j : integer;
segCount : integer;
format : WORD;
reserved : WORD;
format4Rec : TCmapFormat4;
format12Rec : TCmapFormat12;
cmapTbl : TFontTable;
cmapTblRecs : array of TCmapTblRec;
label
format4Error;
begin
Result := false;
cmapTbl := fTables[fTblIdxes[tblCmap]];
if (fStream.Size < cmapTbl.offset + cmapTbl.length) then Exit;
fStream.Position := cmapTbl.offset;
GetWord(fStream, fTbl_cmap.version);
GetWord(fStream, fTbl_cmap.numTables);
// only use the unicode table (0: always first)
SetLength(cmapTblRecs, fTbl_cmap.numTables);
for i := 0 to fTbl_cmap.numTables -1 do
begin
GetWord(fStream, cmapTblRecs[i].platformID);
GetWord(fStream, cmapTblRecs[i].encodingID);
GetCardinal(fStream, cmapTblRecs[i].offset);
end;
for i := 0 to fTbl_cmap.numTables -1 do
begin
with cmapTblRecs[i] do
if (platformID = 0) or (platformID = 3) then
fStream.Position := cmapTbl.offset + offset
else
Continue;
GetWord(fStream, format);
case format of
0:
begin
if Assigned(fFormat0CodeMap) then Continue;
GetWord(fStream, format4Rec.length);
GetWord(fStream, format4Rec.language);
SetLength(fFormat0CodeMap, 256);
for j := 0 to 255 do
GetByte(fStream, fFormat0CodeMap[j]);
fFontInfo.glyphCount := 255;
end;
4: // USC-2
begin
if Assigned(fFormat4CodeMap) then Continue;
GetWord(fStream, format4Rec.length);
GetWord(fStream, format4Rec.language);
fFontInfo.glyphCount := 0;
GetWord(fStream, format4Rec.segCountX2);
segCount := format4Rec.segCountX2 shr 1;
GetWord(fStream, format4Rec.searchRange);
GetWord(fStream, format4Rec.entrySelector);
GetWord(fStream, format4Rec.rangeShift);
SetLength(fFormat4CodeMap, segCount);
for j := 0 to segCount -1 do
GetWord(fStream, fFormat4CodeMap[j].endCode);
if fFormat4CodeMap[segCount-1].endCode <> $FFFF then
GoTo format4Error;
GetWord(fStream, reserved);
if reserved <> 0 then
GoTo format4Error;
for j := 0 to segCount -1 do
GetWord(fStream, fFormat4CodeMap[j].startCode);
if fFormat4CodeMap[segCount-1].startCode <> $FFFF then
GoTo format4Error;
for j := 0 to segCount -1 do
GetWord(fStream, fFormat4CodeMap[j].idDelta);
fFormat4Offset := fStream.Position;
for j := 0 to segCount -1 do
GetWord(fStream, fFormat4CodeMap[j].rangeOffset);
if Assigned(fFormat12CodeMap) then Break
else Continue;
format4Error:
fFormat4CodeMap := nil;
end;
12: // USC-4
begin
if Assigned(fFormat12CodeMap) then Continue;
GetWord(fStream, reserved);
GetCardinal(fStream, format12Rec.length);
GetCardinal(fStream, format12Rec.language);
GetCardinal(fStream, format12Rec.nGroups);
SetLength(fFormat12CodeMap, format12Rec.nGroups);
for j := 0 to format12Rec.nGroups -1 do
with fFormat12CodeMap[j] do
begin
GetCardinal(fStream, startCharCode);
GetCardinal(fStream, endCharCode);
GetCardinal(fStream, startGlyphCode);
end;
if Assigned(fFormat4CodeMap) then Break;
end;
end;
end;
Result := Assigned(fFormat4CodeMap) or Assigned(fFormat12CodeMap);
end;
//------------------------------------------------------------------------------
function TFontReader.GetGlyphIdxUsingCmap(codePoint: Cardinal): WORD;
var
i: integer;
w: WORD;
begin
result := 0; // default to the 'missing' glyph
if (codePoint < 256) and Assigned(fFormat0CodeMap) then
Result := fFormat0CodeMap[codePoint]
else if Assigned(fFormat12CodeMap) then
begin
for i := 0 to High(fFormat12CodeMap) do
with fFormat12CodeMap[i] do
if codePoint <= endCharCode then
begin
if codePoint < startCharCode then Break;
result := (startGlyphCode + WORD(codePoint - startCharCode));
Break;
end;
end
else if (codePoint < $FFFF) and Assigned(fFormat4CodeMap) then
begin
for i := 0 to High(fFormat4CodeMap) do
with fFormat4CodeMap[i] do
if codePoint <= endCode then
begin
if codePoint < startCode then Break;
if rangeOffset > 0 then
begin
fStream.Position := fFormat4Offset +
rangeOffset + 2 * (i + WORD(codePoint - startCode));
GetWord(fStream, w);
if w < fTbl_maxp.numGlyphs then Result := w;
end else
result := (idDelta + codePoint) and $FFFF;
Break;
end;
end;
end;
//------------------------------------------------------------------------------
function TFontReader.GetTable_maxp: Boolean;
var
maxpTbl: TFontTable;
begin
maxpTbl := fTables[fTblIdxes[tblMaxp]];
Result := (fStream.Size >= maxpTbl.offset + maxpTbl.length) and
(maxpTbl.length >= SizeOf(TFixed) + SizeOf(WORD));
if not Result then Exit;
fStream.Position := maxpTbl.offset;
GetFixed(fStream, fTbl_maxp.version);
GetWord(fStream, fTbl_maxp.numGlyphs);
if fTbl_maxp.version >= 1 then
begin
GetWord(fStream, fTbl_maxp.maxPoints);
GetWord(fStream, fTbl_maxp.maxContours);
fFontInfo.glyphCount := fTbl_maxp.numGlyphs;
end else
Result := false;
end;
//------------------------------------------------------------------------------
function TFontReader.GetTable_loca: Boolean;
var
i: integer;
locaTbl: TFontTable;
begin
locaTbl := fTables[fTblIdxes[tblLoca]];
Result := fStream.Size >= locaTbl.offset + locaTbl.length;
if not Result then Exit;
fStream.Position := locaTbl.offset;
if fTbl_head.indexToLocFmt = 0 then
begin
SetLength(fTbl_loca2, fTbl_maxp.numGlyphs +1);
for i := 0 to fTbl_maxp.numGlyphs do
GetWord(fStream, fTbl_loca2[i]);
end else
begin
SetLength(fTbl_loca4, fTbl_maxp.numGlyphs +1);
for i := 0 to fTbl_maxp.numGlyphs do
GetCardinal(fStream, fTbl_loca4[i]);
end;
end;
//------------------------------------------------------------------------------
function IsUnicode(platformID: WORD): Boolean;
begin
Result := (platformID = 0) or (platformID = 3);
end;
//------------------------------------------------------------------------------
function GetNameRecString(stream: TStream;
const nameRec: TNameRec; offset: cardinal): Utf8String;
var
sPos, len: integer;
begin
sPos := stream.Position;
stream.Position := offset + nameRec.offset;
if IsUnicode(nameRec.platformID) then
Result := GetWideString(stream, nameRec.length) else
Result := GetUtf8String(stream, nameRec.length);
len := Length(Result);
if (len > 0) and (Result[len] = #0) then SetLength(Result, len -1);
stream.Position := sPos;
end;
//------------------------------------------------------------------------------
function TFontReader.GetTable_name: Boolean;
var
i: integer;
offset: cardinal;
nameRec: TNameRec;
nameTbl: TFontTable;
begin
fFontInfo.faceName := '';
fFontInfo.fullFaceName := '';
fFontInfo.style := '';
nameTbl := fTables[fTblIdxes[tblName]];
Result := IsValidFontTable(nameTbl) and
(nameTbl.length >= SizeOf(TFontTable_Name));
if not Result then Exit;
fStream.Position := nameTbl.offset;
GetWord(fStream, fTbl_name.format);
GetWord(fStream, fTbl_name.count);
GetWord(fStream, fTbl_name.stringOffset);
offset := nameTbl.offset + fTbl_name.stringOffset;
for i := 1 to fTbl_name.count do
begin
GetWord(fStream, nameRec.platformID);
GetWord(fStream, nameRec.encodingID);
GetWord(fStream, nameRec.languageID);
GetWord(fStream, nameRec.nameID);
GetWord(fStream, nameRec.length);
GetWord(fStream, nameRec.offset);
case nameRec.nameID of
0: fFontInfo.copyright := GetNameRecString(fStream, nameRec, offset);
1: fFontInfo.faceName := GetNameRecString(fStream, nameRec, offset);
2: fFontInfo.style := GetNameRecString(fStream, nameRec, offset);
3: continue;
4: fFontInfo.fullFaceName := GetNameRecString(fStream, nameRec, offset);
5..7: continue;
8: fFontInfo.manufacturer := GetNameRecString(fStream, nameRec, offset);
end;
end;
end;
//------------------------------------------------------------------------------
function TFontReader.GetTable_head: Boolean;
var
headTbl: TFontTable;
yy,mo,dd,hh,mi,ss: cardinal;
begin
headTbl := fTables[fTblIdxes[tblHead]];
Result := IsValidFontTable(headTbl) and (headTbl.length >= 54);
if not Result then Exit;
fStream.Position := headTbl.offset;
GetWord(fStream, fTbl_head.majorVersion);
GetWord(fStream, fTbl_head.minorVersion);
GetFixed(fStream, fTbl_head.fontRevision);
GetCardinal(fStream, fTbl_head.checkSumAdjust);
GetCardinal(fStream, fTbl_head.magicNumber);
GetWord(fStream, fTbl_head.flags);
GetWord(fStream, fTbl_head.unitsPerEm);
GetUInt64(fStream, fTbl_head.dateCreated);
GetMeaningfulDateTime(fTbl_head.dateCreated, yy,mo,dd,hh,mi,ss);
fFontInfo.dateCreated := EncodeDate(yy,mo,dd) + EncodeTime(hh,mi,ss, 0);
GetUInt64(fStream, fTbl_head.dateModified);
GetMeaningfulDateTime(fTbl_head.dateModified, yy,mo,dd,hh,mi,ss);
fFontInfo.dateModified := EncodeDate(yy,mo,dd) + EncodeTime(hh,mi,ss, 0);
GetInt16(fStream, fTbl_head.xMin);
GetInt16(fStream, fTbl_head.yMin);
GetInt16(fStream, fTbl_head.xMax);
GetInt16(fStream, fTbl_head.yMax);
GetWord(fStream, fTbl_head.macStyle);
fFontInfo.macStyles := TMacStyles(Byte(fTbl_head.macStyle));
GetWord(fStream, fTbl_head.lowestRecPPEM);
GetInt16(fStream, fTbl_head.fontDirHint);
GetInt16(fStream, fTbl_head.indexToLocFmt);
GetInt16(fStream, fTbl_head.glyphDataFmt);
result := fTbl_head.magicNumber = $5F0F3CF5
end;
//------------------------------------------------------------------------------
function TFontReader.GetTable_hhea: Boolean;
var
hheaTbl: TFontTable;
begin
hheaTbl := fTables[fTblIdxes[tblHhea]];
Result := IsValidFontTable(hheaTbl) and (hheaTbl.length >= 36);
if not Result then Exit;
fStream.Position := hheaTbl.offset;
GetFixed(fStream, fTbl_hhea.version);
GetInt16(fStream, fTbl_hhea.ascent);
GetInt16(fStream, fTbl_hhea.descent);
GetInt16(fStream, fTbl_hhea.lineGap);
GetWord(fStream, fTbl_hhea.advWidthMax);
GetInt16(fStream, fTbl_hhea.minLSB);
GetInt16(fStream, fTbl_hhea.minRSB);
GetInt16(fStream, fTbl_hhea.xMaxExtent);
GetInt16(fStream, fTbl_hhea.caretSlopeRise);
GetInt16(fStream, fTbl_hhea.caretSlopeRun);
GetInt16(fStream, fTbl_hhea.caretOffset);
GetUInt64(fStream, fTbl_hhea.reserved);
GetInt16(fStream, fTbl_hhea.metricDataFmt);
GetWord(fStream, fTbl_hhea.numLongHorMets);
end;
//------------------------------------------------------------------------------
function TFontReader.GetGlyphHorzMetrics(glyphIdx: WORD): TFontTable_Hmtx;
var
tbl : TFontTable;
begin
tbl := fTables[fTblIdxes[tblHmtx]];
if glyphIdx < fTbl_hhea.numLongHorMets then
begin
fStream.Position := Integer(tbl.offset) + glyphIdx * 4;
GetWord(fStream, Result.advanceWidth);
GetInt16(fStream, Result.leftSideBearing);
end else
begin
fStream.Position := Integer(tbl.offset) +
Integer(fTbl_hhea.numLongHorMets -1) * 4;
GetWord(fStream, Result.advanceWidth);
fStream.Position := Integer(tbl.offset +
fTbl_hhea.numLongHorMets * 4) +
2 * (glyphIdx - Integer(fTbl_hhea.numLongHorMets));
GetInt16(fStream, Result.leftSideBearing);
end;
end;
//------------------------------------------------------------------------------
procedure TFontReader.GetTable_kern;
var
i : integer;
tbl : TFontTable;
tbl_kern : TFontTable_Kern;
kernSub : TKernSubTbl;
format0KernHdr : TFormat0KernHdr;
begin
if fTblIdxes[tblKern] < 0 then Exit;
tbl := fTables[fTblIdxes[tblKern]];
if not IsValidFontTable(tbl) then Exit;
fStream.Position := Integer(tbl.offset);
GetWord(fStream, tbl_kern.version);
GetWord(fStream, tbl_kern.numTables);
if tbl_kern.numTables = 0 then Exit;
// assume there's only one kern table
GetWord(fStream, kernSub.version);
GetWord(fStream, kernSub.length);
GetWord(fStream, kernSub.coverage);
// we're currently only interested in Format0 horizontal kerning
if kernSub.coverage <> 1 then Exit;
GetWord(fStream, format0KernHdr.nPairs);
GetWord(fStream, format0KernHdr.searchRange);
GetWord(fStream, format0KernHdr.entrySelector);
GetWord(fStream, format0KernHdr.rangeShift);
SetLength(fKernTable, format0KernHdr.nPairs);
for i := 0 to format0KernHdr.nPairs -1 do
begin
GetWord(fStream, fKernTable[i].left);
GetWord(fStream, fKernTable[i].right);
GetInt16(fStream, fKernTable[i].value);
end;
end;
//------------------------------------------------------------------------------
procedure TFontReader.GetTable_post;
var
tbl: TFontTable;
begin
if fTblIdxes[tblPost] < 0 then Exit;
tbl := fTables[fTblIdxes[tblPost]];
if not IsValidFontTable(tbl) then Exit;
fStream.Position := Integer(tbl.offset);
GetWord(fStream, fTbl_post.majorVersion);
GetWord(fStream, fTbl_post.minorVersion);
GetFixed(fStream, fTbl_post.italicAngle);
GetInt16(fStream, fTbl_post.underlinePos);
GetInt16(fStream, fTbl_post.underlineWidth);
GetCardinal(fStream, fTbl_post.isFixedPitch);
end;
//------------------------------------------------------------------------------
function FindKernInTable(glyphIdx: WORD; const kernTable: TArrayOfKernRecs): integer;
var
i,l,r: integer;
begin
l := 0;
r := High(kernTable);
while l <= r do
begin
Result := (l + r) shr 1;
i := kernTable[Result].left - glyphIdx;
if i < 0 then
begin
l := Result +1
end else
begin
if i = 0 then
begin
// found a match! Now find the very first one ...
while (Result > 0) and
(kernTable[Result-1].left = glyphIdx) do dec(Result);
Exit;
end;
r := Result -1;
end;
end;
Result := -1;
end;
//------------------------------------------------------------------------------
function TFontReader.GetGlyphKernList(glyphIdx: WORD): TArrayOfTKern;
var
i,j,len: integer;
begin
result := nil;
i := FindKernInTable(glyphIdx, fKernTable);
if i < 0 then Exit;
len := Length(fKernTable);
j := i +1;
while (j < len) and (fKernTable[j].left = glyphIdx) do inc(j);
SetLength(Result, j - i);
for j := 0 to High(Result) do
with fKernTable[i+j] do
begin
Result[j].rightGlyphIdx := right;
Result[j].kernValue := value;
end;
end;
//------------------------------------------------------------------------------
function TFontReader.GetGlyphPaths(glyphIdx: WORD;
var tbl_hmtx: TFontTable_Hmtx; out tbl_glyf: TFontTable_Glyf): TPathsEx;
var
offset: cardinal;
glyfTbl: TFontTable;
begin
result := nil;
if fTbl_head.indexToLocFmt = 0 then
begin
offset := fTbl_loca2[glyphIdx] *2;
if offset = fTbl_loca2[glyphIdx+1] *2 then Exit; // no contours
end else
begin
offset := fTbl_loca4[glyphIdx];
if offset = fTbl_loca4[glyphIdx+1] then Exit; // no contours
end;
glyfTbl := fTables[fTblIdxes[tblGlyf]];
if offset >= glyfTbl.length then Exit;
inc(offset, glyfTbl.offset);
fStream.Position := offset;
GetInt16(fStream, tbl_glyf.numContours);
GetInt16(fStream, tbl_glyf.xMin);
GetInt16(fStream, tbl_glyf.yMin);
GetInt16(fStream, tbl_glyf.xMax);
GetInt16(fStream, tbl_glyf.yMax);
if tbl_glyf.numContours < 0 then
result := GetCompositeGlyph(tbl_glyf, tbl_hmtx) else
result := GetSimpleGlyph(tbl_glyf);
end;
//------------------------------------------------------------------------------
const
// glyf flags - simple
ON_CURVE = $1;
X_SHORT_VECTOR = $2;
Y_SHORT_VECTOR = $4;
REPEAT_FLAG = $8;
X_DELTA = $10;
Y_DELTA = $20;
//------------------------------------------------------------------------------
function TFontReader.GetSimpleGlyph(tbl_glyf: TFontTable_Glyf): TPathsEx;
var
i,j, len: integer;
instructLen: WORD;
flag, repeats: byte;
contourEnds: TArrayOfWord;
begin
SetLength(contourEnds, tbl_glyf.numContours);
for i := 0 to High(contourEnds) do
GetWord(fStream, contourEnds[i]);
// hints are currently ignored
GetWord(fStream, instructLen);
fStream.Position := fStream.Position + instructLen;
setLength(result, tbl_glyf.numContours);
repeats := 0;
flag := 0; // help the compiler with "flag isn't initialized"
for i := 0 to High(result) do
begin
if i = 0 then len := contourEnds[0] +1
else len := contourEnds[i] - contourEnds[i-1];
setLength(result[i], len);
for j := 0 to len -1 do
begin
if repeats = 0 then
begin
GetByte(fStream, flag);
if flag and REPEAT_FLAG = REPEAT_FLAG then
GetByte(fStream, repeats);
end else
dec(repeats);
result[i][j].flag := flag;
end;
end;
if tbl_glyf.numContours > 0 then
GetPathCoords(result);
end;
//------------------------------------------------------------------------------
procedure TFontReader.GetPathCoords(var paths: TPathsEx);
var
i,j: integer;
xi,yi: Int16;
flag, xb,yb: byte;
pt: TPoint;
begin
// get X coords
pt := Point(0,0);
xi := 0;
for i := 0 to high(paths) do
begin
for j := 0 to high(paths[i]) do
begin
flag := paths[i][j].flag;
if flag and X_SHORT_VECTOR = X_SHORT_VECTOR then
begin
GetByte(fStream, xb);
if (flag and X_DELTA) = 0 then
dec(pt.X, xb) else
inc(pt.X, xb);
end else
begin
if flag and X_DELTA = 0 then
begin
if GetInt16(fStream, xi) then
pt.X := pt.X + xi;
end;
end;
paths[i][j].pt.X := pt.X;
end;
end;
// get Y coords
yi := 0;
for i := 0 to high(paths) do
begin
for j := 0 to high(paths[i]) do
begin
flag := paths[i][j].flag;
if flag and Y_SHORT_VECTOR = Y_SHORT_VECTOR then
begin
GetByte(fStream, yb);
if (flag and Y_DELTA) = 0 then
dec(pt.Y, yb) else
inc(pt.Y, yb);
end else
begin
if flag and Y_DELTA = 0 then
begin
if GetInt16(fStream, yi) then
pt.Y := pt.Y + yi;
end;
end;
paths[i][j].pt.Y := pt.Y;
end;
end;
end;
//------------------------------------------------------------------------------
function OnCurve(flag: byte): Boolean;
begin
result := flag and ON_CURVE <> 0;
end;
//------------------------------------------------------------------------------
function MidPoint(const pt1, pt2: TPointEx): TPointEx;
begin
Result.pt.X := (pt1.pt.X + pt2.pt.X) / 2;
Result.pt.Y := (pt1.pt.Y + pt2.pt.Y) / 2;
Result.flag := ON_CURVE;
end;
//------------------------------------------------------------------------------
function TFontReader.ConvertSplinesToBeziers(const pathsEx: TPathsEx): TPathsEx;
var
i,j,k: integer;
pt: TPointEx;
prevOnCurve: Boolean;
begin
SetLength(Result, Length(pathsEx));
for i := 0 to High(pathsEx) do
begin
SetLength(Result[i], Length(pathsEx[i]) *2);
Result[i][0] := pathsEx[i][0]; k := 1;
prevOnCurve := true;
for j := 1 to High(pathsEx[i]) do
begin
if OnCurve(pathsEx[i][j].flag) then
begin
prevOnCurve := true;
end
else if not prevOnCurve then
begin
pt := MidPoint(pathsEx[i][j-1], pathsEx[i][j]);
Result[i][k] := pt; inc(k);
end else
prevOnCurve := false;
Result[i][k] := pathsEx[i][j]; inc(k);
end;
SetLength(Result[i], k);
end;
end;
//------------------------------------------------------------------------------
procedure AppendPathsEx(var paths: TPathsEx; const extra: TPathsEx);
var
i, len1, len2: integer;
begin
len2 := length(extra);
len1 := length(paths);
setLength(paths, len1 + len2);
for i := 0 to len2 -1 do
paths[len1+i] := Copy(extra[i], 0, length(extra[i]));
end;
//------------------------------------------------------------------------------
procedure AffineTransform(const a,b,c,d,e,f: double; var pathsEx: TPathsEx);
var
i,j: integer;
mat: TMatrixD;
begin
// https://developer.apple.com/fonts/TrueType-Reference-Manual/RM06/Chap6glyf.html
if ((a = 0) and (b = 0)) or ((c = 0) and (d = 0)) then
begin
if (e = 0) and (f = 0) then Exit;
for i := 0 to High(pathsEx) do
for j := 0 to High(pathsEx[i]) do
with pathsEx[i][j].pt do
begin
X := X + e;
y := Y + f;
end;
end else
begin
mat[0,0] := a;
mat[0,1] := b;
mat[1,0] := c;
mat[1,1] := d;
mat[2][0] := e;
mat[2][1] := f;
for i := 0 to High(pathsEx) do
for j := 0 to High(pathsEx[i]) do
MatrixApply(mat, pathsEx[i][j].pt);
end;
end;
//------------------------------------------------------------------------------
function TFontReader.GetCompositeGlyph(var tbl_glyf: TFontTable_Glyf;
var tbl_hmtx: TFontTable_Hmtx): TPathsEx;
var
streamPos: integer;
flag, glyphIndex: WORD;
arg1_i8, arg2_i8: ShortInt;
arg1_i16, arg2_i16: Int16;
tmp_single: single;
a,b,c,d,e,f: double;
componentPaths: TPathsEx;
component_tbl_glyf: TFontTable_Glyf;
component_tbl_hmtx: TFontTable_Hmtx;
const
ARG_1_AND_2_ARE_WORDS = $1;
ARGS_ARE_XY_VALUES = $2;
ROUND_XY_TO_GRID = $4;
WE_HAVE_A_SCALE = $8;
MORE_COMPONENTS = $20;
WE_HAVE_AN_X_AND_Y_SCALE = $40;
WE_HAVE_A_TWO_BY_TWO = $80;
WE_HAVE_INSTRUCTIONS = $100;
USE_MY_METRICS = $200;
begin
result := nil;
flag := MORE_COMPONENTS;
while (flag and MORE_COMPONENTS <> 0) do
begin
glyphIndex := 0;
a := 0; b := 0; c := 0; d := 0; e := 0; f := 0;
GetWord(fStream, flag);
GetWord(fStream, glyphIndex);
if (flag and ARG_1_AND_2_ARE_WORDS <> 0) then
begin
GetInt16(fStream, arg1_i16);
GetInt16(fStream, arg2_i16);
if (flag and ARGS_ARE_XY_VALUES <> 0) then
begin
e := arg1_i16;
f := arg2_i16;
end;
end else
begin
GetShortInt(fStream, arg1_i8);
GetShortInt(fStream, arg2_i8);
if (flag and ARGS_ARE_XY_VALUES <> 0) then
begin
e := arg1_i8;
f := arg2_i8;
end;
end;
if (flag and WE_HAVE_A_SCALE <> 0) then
begin
Get2Dot14(fStream, tmp_single);
a := tmp_single; d := tmp_single;
end
else if (flag and WE_HAVE_AN_X_AND_Y_SCALE <> 0) then
begin
Get2Dot14(fStream, tmp_single); a := tmp_single;
Get2Dot14(fStream, tmp_single); d := tmp_single;
end
else if (flag and WE_HAVE_A_TWO_BY_TWO <> 0) then
begin
Get2Dot14(fStream, tmp_single); a := tmp_single;
Get2Dot14(fStream, tmp_single); b := tmp_single;
Get2Dot14(fStream, tmp_single); c := tmp_single;
Get2Dot14(fStream, tmp_single); d := tmp_single;
end;
component_tbl_hmtx := tbl_hmtx;
// GetGlyphPaths() will change the stream position, so save it.
streamPos := fStream.Position;
componentPaths := GetGlyphPaths(glyphIndex, component_tbl_hmtx, component_tbl_glyf);
// return to saved stream position
fStream.Position := streamPos;
if (flag and ARGS_ARE_XY_VALUES <> 0) then
AffineTransform(a,b,c,d,e,f, componentPaths); // (#131)
if (flag and USE_MY_METRICS <> 0) then
tbl_hmtx := component_tbl_hmtx; // (#24)
if component_tbl_glyf.numContours > 0 then
begin
if tbl_glyf.numContours < 0 then tbl_glyf.numContours := 0;
inc(tbl_glyf.numContours, component_tbl_glyf.numContours);
tbl_glyf.xMin := Min(tbl_glyf.xMin, component_tbl_glyf.xMin);
tbl_glyf.xMax := Max(tbl_glyf.xMax, component_tbl_glyf.xMax);
tbl_glyf.yMin := Min(tbl_glyf.yMin, component_tbl_glyf.yMin);
tbl_glyf.yMax := Max(tbl_glyf.yMax, component_tbl_glyf.yMax);
end;
AppendPathsEx(result, componentPaths);
end;
end;
//------------------------------------------------------------------------------
function TFontReader.HasGlyph(codepoint: Cardinal): Boolean;
begin
Result := GetGlyphIdxUsingCmap(codepoint) > 0;
end;
//------------------------------------------------------------------------------
function FlattenPathExBeziers(pathsEx: TPathsEx): TPathsD;
var
i,j : integer;
pt2: TPointEx;
bez: TPathD;
begin
setLength(Result, length(pathsEx));
for i := 0 to High(pathsEx) do
begin
SetLength(Result[i],1);
Result[i][0] := pathsEx[i][0].pt;
for j := 1 to High(pathsEx[i]) do
begin
if OnCurve(pathsEx[i][j].flag) then
begin
AppendPoint(Result[i], pathsEx[i][j].pt);
end else
begin
if j = High(pathsEx[i]) then
pt2 := pathsEx[i][0] else
pt2 := pathsEx[i][j+1];
bez := FlattenQBezier(pathsEx[i][j-1].pt, pathsEx[i][j].pt, pt2.pt);
ConcatPaths(Result[i], bez);
end;
end;
end;
end;
//------------------------------------------------------------------------------
function TFontReader.GetGlyphInfo(codepoint: Cardinal;
out nextX: integer; out glyphInfo: TGlyphInfo): Boolean;
var
glyphIdx: WORD;
begin
Result := IsValidFontFormat;
if not Result then Exit;
glyphIdx := GetGlyphIdxUsingCmap(codepoint);
glyphInfo := GetGlyphInfoInternal(glyphIdx);
glyphInfo.hmtx := GetGlyphHorzMetrics(glyphIdx);
nextX := glyphInfo.hmtx.advanceWidth;
glyphInfo.codepoint := codepoint;
end;
//------------------------------------------------------------------------------
function TFontReader.GetFontInfo: TFontInfo;
begin
if not IsValidFontFormat then
begin
FillChar(Result, SizeOf(Result), 0);
Exit;
end;
result := fFontInfo;
if result.unitsPerEm > 0 then Exit;
// and updated the record with everything except the strings
result.unitsPerEm := fTbl_head.unitsPerEm;
result.xMin := fTbl_head.xMin;
result.xMax := fTbl_head.xMax;
result.yMin := fTbl_head.yMin;
result.yMax := fTbl_head.yMax;
// note: the following three fields "represent the design
// intentions of the font's creator rather than any computed value"
// https://developer.apple.com/fonts/TrueType-Reference-Manual/RM06/Chap6hhea.html
result.ascent := fTbl_hhea.ascent;
result.descent := abs(fTbl_hhea.descent);
result.lineGap := fTbl_hhea.lineGap;
result.advWidthMax := fTbl_hhea.advWidthMax;
result.minLSB := fTbl_hhea.minLSB;
result.minRSB := fTbl_hhea.minRSB;
result.xMaxExtent := fTbl_hhea.xMaxExtent;
end;
//------------------------------------------------------------------------------
function TFontReader.GetGlyphInfoInternal(glyphIdx: WORD): TGlyphInfo;
var
pathsEx: TPathsEx;
begin
FillChar(result, sizeOf(Result), 0);
if not IsValidFontFormat then Exit;
result.glyphIdx := glyphIdx;
result.unitsPerEm := fTbl_head.unitsPerEm;
// get raw splines
pathsEx := GetGlyphPaths(glyphIdx, result.hmtx, result.glyf);
if Assigned(pathsEx) then
begin
pathsEx := ConvertSplinesToBeziers(pathsEx);
result.paths := FlattenPathExBeziers(PathsEx);
end;
Result.kernList := GetGlyphKernList(glyphIdx);
end;
//------------------------------------------------------------------------------
function TFontReader.GetWeight: integer;
var
i, dummy: integer;
accum: Cardinal;
gm: TGlyphInfo;
rec: TRectD;
img: TImage32;
p: PARGB;
const
imgSize = 16;
k = 5; // an empirical constant
begin
// get an empirical weight based on the character 'G'
result := 0;
if not IsValidFontFormat then Exit;
if fFontWeight > 0 then
begin
Result := fFontWeight;
Exit;
end;
GetGlyphInfo(Ord('G'),dummy, gm);
rec := GetBoundsD(gm.paths);
gm.paths := Img32.Vector.TranslatePath(gm.paths, -rec.Left, -rec.Top);
gm.paths := Img32.Vector.ScalePath(gm.paths, imgSize/rec.Width, imgSize/rec.Height);
img := TImage32.Create(imgSize,imgSize);
try
DrawPolygon(img, gm.paths, frEvenOdd, clBlack32);
accum := 0;
p := PARGB(img.PixelBase);
for i := 0 to imgSize * imgSize do
begin
inc(accum, p.A);
inc(p);
end;
finally
img.Free;
end;
fFontWeight := Max(100, Min(900,
Round(k * accum / (imgSize * imgSize * 100)) * 100));
Result := fFontWeight;
end;
//------------------------------------------------------------------------------
procedure TFontReader.GetFontFamily;
var
giT, giI, giM: integer;
gmT: TGlyphInfo;
hmtxI, hmtxM: TFontTable_Hmtx;
begin
fFontInfo.family := tfUnknown;
if (fTbl_post.majorVersion > 0) and
(fTbl_post.isFixedPitch <> 0) then
begin
fFontInfo.family := tfMonospace;
Exit;
end;
// use glyph metrics for 'T', 'i' & 'm' to determine the font family
// if the widths of 'i' & 'm' are equal, then assume a monospace font
// else if the number of vertices used to draw 'T' is greater than 10
// then assume a serif font otherwise assume a sans serif font.
giT := GetGlyphIdxUsingCmap(Ord('T'));
giI := GetGlyphIdxUsingCmap(Ord('i'));
giM := GetGlyphIdxUsingCmap(Ord('m'));
if (giT = 0) or (giI = 0) or (giM = 0) then Exit;
hmtxI := GetGlyphHorzMetrics(giI);
hmtxM := GetGlyphHorzMetrics(giM);
if hmtxI.advanceWidth = hmtxM.advanceWidth then
begin
fFontInfo.family := tfMonospace;
Exit;
end;
gmT := GetGlyphInfoInternal(giT);
if Assigned(gmT.paths) and (Length(gmT.paths[0]) > 10) then
fFontInfo.family := tfSerif else
fFontInfo.family := tfSansSerif;
end;
//------------------------------------------------------------------------------
// TFontCache
//------------------------------------------------------------------------------
constructor TFontCache.Create(fontReader: TFontReader; fontHeight: double);
begin
{$IFDEF XPLAT_GENERICS}
fGlyphInfoList := TList<PGlyphInfo>.Create;
{$ELSE}
fGlyphInfoList := TList.Create;
{$ENDIF}
fSorted := false;
fUseKerning := true;
fFlipVert := true;
fFontHeight := fontHeight;
SetFontReader(fontReader);
end;
//------------------------------------------------------------------------------
destructor TFontCache.Destroy;
begin
SetFontReader(nil);
Clear;
NotifyRecipients(inDestroy);
fGlyphInfoList.Free;
inherited;
end;
//------------------------------------------------------------------------------
procedure TFontCache.ReceiveNotification(Sender: TObject; notify: TImg32Notification);
begin
if Sender <> fFontReader then
raise Exception.Create(rsFontCacheError);
if notify = inStateChange then
begin
Clear;
UpdateScale;
end else
SetFontReader(nil);
end;
//------------------------------------------------------------------------------
procedure TFontCache.NotifyRecipients(notifyFlag: TImg32Notification);
var
i: integer;
begin
for i := High(fRecipientList) downto 0 do
try
// try .. except block because when TFontCache is destroyed in a
// finalization section, it's possible for recipients to have been
// destroyed without calling their destructors.
fRecipientList[i].ReceiveNotification(self, notifyFlag);
except
end;
end;
//------------------------------------------------------------------------------
procedure TFontCache.AddRecipient(recipient: INotifyRecipient);
var
len: integer;
begin
len := Length(fRecipientList);
SetLength(fRecipientList, len+1);
fRecipientList[len] := Recipient;
end;
//------------------------------------------------------------------------------
procedure TFontCache.DeleteRecipient(recipient: INotifyRecipient);
var
i, highI: integer;
begin
highI := High(fRecipientList);
i := highI;
while (i >= 0) and (fRecipientList[i] <> Recipient) do dec(i);
if i < 0 then Exit;
if i < highI then
Move(fRecipientList[i+i], fRecipientList[i],
(highI - i) * SizeOf(INotifyRecipient));
SetLength(fRecipientList, highI);
end;
//------------------------------------------------------------------------------
procedure TFontCache.Clear;
var
i: integer;
begin
for i := 0 to fGlyphInfoList.Count -1 do
Dispose(PGlyphInfo(fGlyphInfoList[i]));
fGlyphInfoList.Clear;
fSorted := false;
end;
//------------------------------------------------------------------------------
{$IFDEF XPLAT_GENERICS}
function FindInSortedList(charOrdinal: Cardinal; glyphList: TList<PGlyphInfo>): integer;
{$ELSE}
function FindInSortedList(charOrdinal: Cardinal; glyphList: TList): integer;
{$ENDIF}
var
i,l,r: integer;
begin
// binary search the sorted list ...
l := 0;
r := glyphList.Count -1;
while l <= r do
begin
Result := (l + r) shr 1;
i := integer(PGlyphInfo(glyphList[Result]).codepoint) - integer(charOrdinal);
if i < 0 then
begin
l := Result +1
end else
begin
if i = 0 then Exit;
r := Result -1;
end;
end;
Result := -1;
end;
//------------------------------------------------------------------------------
function TFontCache.FoundInList(charOrdinal: Cardinal): Boolean;
begin
if not fSorted then Sort;
result := FindInSortedList(charOrdinal, fGlyphInfoList) >= 0;
end;
//------------------------------------------------------------------------------
procedure TFontCache.GetMissingGlyphs(const ordinals: TArrayOfCardinal);
var
i, len: integer;
begin
if not IsValidFont then Exit;
len := Length(ordinals);
for i := 0 to len -1 do
begin
if ordinals[i] < 32 then continue
else if not FoundInList(ordinals[i]) then AddGlyph(ordinals[i]);
end;
end;
//------------------------------------------------------------------------------
function TFontCache.IsValidFont: Boolean;
begin
Result := assigned(fFontReader) and fFontReader.IsValidFontFormat;
end;
//------------------------------------------------------------------------------
function TFontCache.GetAscent: double;
begin
if not IsValidFont then Result := 0
else with fFontReader.FontInfo do
Result := Max(ascent, yMax) * fScale;
end;
//------------------------------------------------------------------------------
function TFontCache.GetDescent: double;
begin
if not IsValidFont then Result := 0
else with fFontReader.FontInfo do
Result := Max(descent, -yMin) * fScale;
end;
//------------------------------------------------------------------------------
function TFontCache.GetGap: double;
begin
if not IsValidFont then Result := 0
else Result := fFontReader.FontInfo.lineGap * fScale;
end;
//------------------------------------------------------------------------------
function TFontCache.GetLineHeight: double;
begin
if not IsValidFont then Result := 0
else Result := Ascent + Descent + LineGap;
end;
//------------------------------------------------------------------------------
function TFontCache.GetYyHeight: double;
var
minY, maxY: double;
begin
// nb: non-inverted Y coordinates.
maxY := GetGlyphInfo(ord('Y')).glyf.yMax;
minY := GetGlyphInfo(ord('y')).glyf.yMin;
Result := (maxY - minY) * fScale;
end;
//------------------------------------------------------------------------------
procedure TFontCache.VerticalFlip(var paths: TPathsD);
var
i,j: integer;
begin
for i := 0 to High(paths) do
for j := 0 to High(paths[i]) do
with paths[i][j] do Y := -Y;
end;
//------------------------------------------------------------------------------
function FindInKernList(glyphIdx: WORD; const kernList: TArrayOfTKern): integer;
var
i,l,r: integer;
begin
l := 0;
r := High(kernList);
while l <= r do
begin
Result := (l + r) shr 1;
i := kernList[Result].rightGlyphIdx - glyphIdx;
if i < 0 then
begin
l := Result +1
end else
begin
if i = 0 then Exit; // found!
r := Result -1;
end;
end;
Result := -1;
end;
//------------------------------------------------------------------------------
function TFontCache.GetGlyphInfo(codepoint: Cardinal): PGlyphInfo;
var
listIdx: integer;
begin
Result := nil;
if not IsValidFont then Exit;
if not fSorted then Sort;
listIdx := FindInSortedList(codepoint, fGlyphInfoList);
if listIdx < 0 then
Result := AddGlyph(codepoint) else
Result := PGlyphInfo(fGlyphInfoList[listIdx]);
end;
//------------------------------------------------------------------------------
function IsSurrogate(c: WideChar): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result := (c >= #$D800) and (c <= #$DFFF);
end;
//------------------------------------------------------------------------------
function ConvertSurrogatePair(hiSurrogate, loSurrogate: Cardinal): Cardinal;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result := ((hiSurrogate - $D800) shl 10) + (loSurrogate - $DC00) + $10000;
end;
//------------------------------------------------------------------------------
function TFontCache.GetTextCodePoints(const text: UnicodeString): TArrayOfCardinal;
var
i,j, len: integer;
inSurrogate: Boolean;
begin
len := Length(text);
setLength(Result, len);
inSurrogate := false;
j := 0;
for i := 1 to len do
begin
if inSurrogate then
begin
Result[j] := ConvertSurrogatePair(Ord(text[i -1]), Ord(text[i]));
inSurrogate := false;
end
else if IsSurrogate(text[i]) then
begin
inSurrogate := true;
Continue;
end
else
Result[j] := Ord(WideChar(text[i]));
inc(j);
end;
setLength(Result, j);
end;
//------------------------------------------------------------------------------
function TFontCache.GetGlyphOffsets(const text: UnicodeString;
interCharSpace: double): TArrayOfDouble;
var
i,j, len: integer;
codePoints: TArrayOfCardinal;
glyphInfo: PGlyphInfo;
thisX: double;
prevGlyphKernList: TArrayOfTKern;
begin
codePoints := GetTextCodePoints(text);
len := Length(codePoints);
SetLength(Result, len +1);
Result[0] := 0;
if len = 0 then Exit;
GetMissingGlyphs(codePoints);
thisX := 0;
prevGlyphKernList := nil;
for i := 0 to High(codePoints) do
begin
glyphInfo := GetGlyphInfo(codePoints[i]);
if not assigned(glyphInfo) then Break;
if fUseKerning and assigned(prevGlyphKernList) then
begin
j := FindInKernList(glyphInfo.glyphIdx, prevGlyphKernList);
if (j >= 0) then
thisX := thisX + prevGlyphKernList[j].kernValue*fScale;
end;
Result[i] := thisX;
thisX := thisX + glyphInfo.hmtx.advanceWidth*fScale +interCharSpace;
prevGlyphKernList := glyphInfo.kernList;
end;
Result[len] := thisX - interCharSpace;
end;
//------------------------------------------------------------------------------
function TFontCache.GetTextWidth(const text: UnicodeString): double;
var
offsets: TArrayOfDouble;
begin
Result := 0;
if not IsValidFont then Exit;
offsets := GetGlyphOffsets(text);
Result := offsets[high(offsets)];
end;
//------------------------------------------------------------------------------
function TFontCache.CountCharsThatFit(const text: UnicodeString;
maxWidth: double): integer;
var
offsets: TArrayOfDouble;
begin
Result := 0;
if not IsValidFont then Exit;
offsets := GetGlyphOffsets(text);
Result := Length(offsets);
while offsets[Result -1] > maxWidth do
Dec(Result);
end;
//------------------------------------------------------------------------------
function TFontCache.GetSpaceWidth: double;
begin
Result := GetGlyphInfo(32).hmtx.advanceWidth * fScale;
end;
//------------------------------------------------------------------------------
function TFontCache.GetTextOutline(x, y: double; const text: UnicodeString): TPathsD;
var
dummy: double;
begin
Result := GetTextOutline(x, y, text, dummy);
end;
//------------------------------------------------------------------------------
function TFontCache.GetTextOutline(x, y: double; const text: UnicodeString;
out nextX: double; underlineIdx: integer): TPathsD;
var
arrayOfGlyphs: TArrayOfPathsD;
dummy: TArrayOfDouble;
begin
Result := nil;
if not GetTextOutlineInternal(x, y,
text, underlineIdx, arrayOfGlyphs, dummy, nextX) then Exit;
Result := MergeArrayOfPaths(arrayOfGlyphs);
end;
//------------------------------------------------------------------------------
function TFontCache.GetTextOutline(const rec: TRectD; const text: UnicodeString;
ta: TTextAlign; tav: TTextVAlign; underlineIdx: integer): TPathsD;
var
dummy2, dx, dy: double;
arrayOfGlyphs: TArrayOfPathsD;
dummy1: TArrayOfDouble;
rec2: TRectD;
begin
Result := nil;
if not GetTextOutlineInternal(0, 0, text, underlineIdx,
arrayOfGlyphs, dummy1, dummy2) or (arrayOfGlyphs = nil) then Exit;
rec2 := GetBoundsD(arrayOfGlyphs);
case ta of
taRight: dx := rec.Right - rec2.Width;
taCenter: dx := rec.Left + (rec.Width - rec2.Width)/ 2;
else dx := rec.Left;
end;
case tav of
tvaMiddle: dy := rec.Top - rec2.Top + (rec.Height - rec2.Height)/ 2;
tvaBottom: dy := rec.Bottom - Descent;
else dy := rec.Top + Ascent;
end;
Result := MergeArrayOfPathsEx(arrayOfGlyphs, dx, dy);
end;
//------------------------------------------------------------------------------
function TFontCache.GetUnderlineOutline(leftX, rightX, y: double;
dy: double; wavy: Boolean; strokeWidth: double): TPathD;
var
i, cnt: integer;
dx: double;
wavyPath: TPathD;
begin
if strokeWidth <= 0 then
strokeWidth := LineHeight * lineFrac;
if dy = InvalidD then
y := y + 1.5 * (1 + strokeWidth) else
y := y + dy;
if wavy then
begin
Result := nil;
cnt := Ceil((rightX - leftX) / (strokeWidth *4));
if cnt < 2 then Exit;
dx := (rightX - leftX)/ cnt;
SetLength(wavyPath, cnt +2);
wavyPath[0] := PointD(leftX, y + strokeWidth/2);
wavyPath[1] := PointD(leftX + dx/2, y-(strokeWidth *2));
for i := 1 to cnt do
wavyPath[i+1] := PointD(leftX + dx * i, y + strokeWidth/2);
Result := FlattenQSpline(wavyPath);
wavyPath := ReversePath(Result);
wavyPath := TranslatePath(wavyPath, 0, strokeWidth *1.5);
ConcatPaths(Result, wavyPath);
end else
Result := Rectangle(leftX, y, rightX, y + strokeWidth);
end;
//------------------------------------------------------------------------------
function TFontCache.GetVerticalTextOutline(x, y: double;
const text: UnicodeString; lineHeight: double): TPathsD;
var
i, cnt, xxMax: integer;
glyphInfo: PGlyphInfo;
dx: double;
codePoints: TArrayOfCardinal;
glyphInfos: array of PGlyphInfo;
begin
Result := nil;
if not IsValidFont then Exit;
codePoints := GetTextCodePoints(text);
xxMax := 0;
cnt := Length(codePoints);
SetLength(glyphInfos, cnt);
for i := 0 to cnt -1 do
begin
glyphInfos[i] := GetGlyphInfo(codePoints[i]);
if not assigned(glyphInfos[i]) then Exit;
with glyphInfos[i].glyf do
if xMax > xxMax then
xxMax := xMax;
end;
if lineHeight = 0.0 then
lineHeight := self.LineHeight;
for i := 0 to cnt -1 do
begin
glyphInfo := glyphInfos[i];
with glyphInfo.glyf do
dx := (xxMax - xMax) * 0.5 * scale;
AppendPath(Result, TranslatePath(glyphInfo.paths, x + dx, y));
y := y + lineHeight;
end;
UpdateFontReaderLastUsedTime;
end;
//------------------------------------------------------------------------------
function TFontCache.GetTextOutlineInternal(x, y: double;
const text: UnicodeString; underlineIdx: integer; out glyphs: TArrayOfPathsD;
out offsets: TArrayOfDouble; out nextX: double): Boolean;
var
i,j, len : integer;
dx,y2,w : double;
codepoints : TArrayOfCardinal;
glyphInfo : PGlyphInfo;
currGlyph : TPathsD;
prevGlyphKernList: TArrayOfTKern;
begin
Result := true;
codePoints := GetTextCodePoints(text);
len := Length(codepoints);
GetMissingGlyphs(codepoints);
SetLength(offsets, len);
nextX := x;
prevGlyphKernList := nil;
for i := 0 to len -1 do
begin
offsets[i] := nextX;
glyphInfo := GetGlyphInfo(codepoints[i]);
if not assigned(glyphInfo) then Break;
if fUseKerning and assigned(prevGlyphKernList) then
begin
j := FindInKernList(glyphInfo.glyphIdx, prevGlyphKernList);
if (j >= 0) then
nextX := nextX + prevGlyphKernList[j].kernValue * fScale;
end;
currGlyph := TranslatePath(glyphInfo.paths, nextX, y);
dx := glyphInfo.hmtx.advanceWidth * fScale;
AppendPath(glyphs, currGlyph);
if not fUnderlined and (underlineIdx -1 = i) then
begin
w := LineHeight * lineFrac;
y2 := y + 1.5 * (1 + w);
SetLength(currGlyph, 1);
currGlyph[0] := Rectangle(nextX, y2, nextX +dx, y2 + w);
AppendPath(glyphs, currGlyph);
end;
nextX := nextX + dx;
prevGlyphKernList := glyphInfo.kernList;
end;
if fUnderlined then
begin
w := LineHeight * lineFrac;
y2 := y + 1.5 * (1 + w);
SetLength(currGlyph, 1);
currGlyph[0] := Rectangle(x, y2, nextX, y2 + w);
AppendPath(glyphs, currGlyph);
end;
if fStrikeOut then
begin
w := LineHeight * lineFrac;
y2 := y - LineHeight * 0.22;
SetLength(currGlyph, 1);
currGlyph[0] := Rectangle(x, y2, nextX, y2 + w);
AppendPath(glyphs, currGlyph);
end;
UpdateFontReaderLastUsedTime;
end;
//------------------------------------------------------------------------------
function TFontCache.GetAngledTextGlyphs(x, y: double;
const text: UnicodeString; angleRadians: double;
const rotatePt: TPointD; out nextPt: TPointD): TPathsD;
begin
nextPt.Y := y;
Result := GetTextOutline(x,y, text, nextPt.X);
if not Assigned(Result) then Exit;
Result := RotatePath(Result, rotatePt, angleRadians);
RotatePoint(nextPt, PointD(x,y), angleRadians);
UpdateFontReaderLastUsedTime;
end;
//------------------------------------------------------------------------------
procedure TFontCache.UpdateFontReaderLastUsedTime;
begin
if Assigned(fFontReader) then
fFontReader.LastUsedTime := now;
end;
//------------------------------------------------------------------------------
procedure TFontCache.SetFontReader(newFontReader: TFontReader);
begin
if newFontReader = fFontReader then Exit;
if Assigned(fFontReader) then
begin
fFontReader.DeleteRecipient(self as INotifyRecipient);
Clear;
end;
fFontReader := newFontReader;
if Assigned(fFontReader) then
fFontReader.AddRecipient(self as INotifyRecipient);
UpdateScale;
end;
//------------------------------------------------------------------------------
procedure TFontCache.UpdateScale;
begin
if IsValidFont and (fFontHeight > 0) then
fScale := fFontHeight / fFontReader.FontInfo.unitsPerEm else
fScale := 1;
NotifyRecipients(inStateChange);
end;
//------------------------------------------------------------------------------
procedure TFontCache.SetFontHeight(newHeight: double);
begin
newHeight := abs(newHeight); // manage point - pixel conversions externally
if fFontHeight = newHeight then Exit;
fFontHeight := newHeight;
Clear;
UpdateScale;
end;
//------------------------------------------------------------------------------
procedure FlipVert(var paths: TPathsD);
var
i,j: integer;
begin
for i := 0 to High(paths) do
for j := 0 to High(paths[i]) do
paths[i][j].Y := -paths[i][j].Y;
end;
//------------------------------------------------------------------------------
procedure TFontCache.SetFlipVert(value: Boolean);
var
i: integer;
glyphInfo: PGlyphInfo;
begin
if fFlipVert = value then Exit;
for i := 0 to fGlyphInfoList.Count -1 do
begin
glyphInfo := PGlyphInfo(fGlyphInfoList[i]);
FlipVert(glyphInfo.paths);
end;
fFlipVert := value;
end;
//------------------------------------------------------------------------------
function GlyphSorter(glyph1, glyph2: pointer): integer;
begin
Result := PGlyphInfo(glyph1).codepoint - PGlyphInfo(glyph2).codepoint;
end;
//------------------------------------------------------------------------------
procedure TFontCache.Sort;
begin
{$IFDEF XPLAT_GENERICS}
fGlyphInfoList.Sort(TComparer<PGlyphInfo>.Construct(
function (const glyph1, glyph2: PGlyphInfo): integer
begin
Result := glyph1.codepoint - glyph2.codepoint;
end));
{$ELSE}
fGlyphInfoList.Sort(GlyphSorter);
{$ENDIF}
fSorted := true;
end;
//------------------------------------------------------------------------------
function TFontCache.AddGlyph(codepoint: Cardinal): PGlyphInfo;
var
dummy: integer;
altFontReader: TFontReader;
glyphIdx: WORD;
scale: double;
const
minLength = 0.1;
begin
New(Result);
Result.codepoint := codepoint;
if not fFontReader.GetGlyphInfo(codepoint, dummy, Result^) or
(Result.glyphIdx = 0) then
begin
// to get here the unicode char is not supported by fFontReader
altFontReader :=
aFontManager.FindReaderContainingGlyph(codepoint, tfUnknown, glyphIdx);
if Assigned(altFontReader) then
begin
altFontReader.GetGlyphInfo(codepoint, dummy, Result^);
altFontReader.LastUsedTime := now;
scale := fFontReader.FontInfo.unitsPerEm / altFontReader.FontInfo.unitsPerEm;
if scale <> 1.0 then
Result.paths := ScalePath(Result.paths, scale);
end;
end;
fGlyphInfoList.Add(Result);
if fFontHeight > 0 then
begin
Result.paths := ScalePath(Result.paths, fScale);
// text rendering is about twice as fast when excess detail is removed
Result.paths := StripNearDuplicates(Result.paths, minLength, true);
end;
if fFlipVert then VerticalFlip(Result.paths);
fSorted := false;
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
function AppendSlash(const foldername: string): string;
begin
Result := foldername;
if (Result = '') or (Result[Length(Result)] = '\') then Exit;
Result := Result + '\';
end;
//------------------------------------------------------------------------------
{$IFDEF MSWINDOWS}
procedure FontHeightToFontSize(var logFontHeight: integer);
const
_72Div96 = 72/96;
begin
if logFontHeight < 0 then
logFontHeight := -Round(logFontHeight * _72Div96 / dpiAware1);
end;
//------------------------------------------------------------------------------
procedure FontSizeToFontHeight(var logFontHeight: integer);
const
_96Div72 = 96/72;
begin
if logFontHeight > 0 then
logFontHeight := -Round(DpiAware(logFontHeight * _96Div72));
end;
//------------------------------------------------------------------------------
function GetFontPixelHeight(logFontHeight: integer): double;
const
_96Div72 = 96/72;
begin
if logFontHeight > 0 then
Result := DPIAware(logFontHeight * _96Div72) else
Result := DPIAware(-logFontHeight);
end;
//------------------------------------------------------------------------------
function GetFontFolder: string;
var
pidl: PItemIDList;
path: array[0..MAX_PATH] of char;
begin
SHGetSpecialFolderLocation(0, CSIDL_FONTS, pidl);
SHGetPathFromIDList(pidl, path);
CoTaskMemFree(pidl);
result := path;
end;
//------------------------------------------------------------------------------
function GetInstalledTtfFilenames: TArrayOfString;
var
cnt, buffLen: integer;
fontFolder: string;
sr: TSearchRec;
res: integer;
begin
cnt := 0; buffLen := 1024;
SetLength(Result, buffLen);
fontFolder := AppendSlash(GetFontFolder);
res := FindFirst(fontFolder + '*.ttf', faAnyFile, sr);
while res = 0 do
begin
if cnt = buffLen then
begin
inc(buffLen, 128);
SetLength(Result, buffLen);
end;
Result[cnt] := fontFolder + sr.Name;
inc(cnt);
res := FindNext(sr);
end;
FindClose(sr);
SetLength(Result, cnt);
end;
//------------------------------------------------------------------------------
function EnumFontProc(LogFont: PEnumLogFontEx; TextMetric: PNewTextMetric;
FontType: DWORD; userDefined: LPARAM): Integer; stdcall;
var
len: integer;
alf: PArrayOfEnumLogFontEx absolute userDefined;
begin
if (FontType = TRUETYPE_FONTTYPE) then
begin
len := Length(alf^);
SetLength(alf^, len +1);
Move(LogFont^, alf^[len], SizeOf(TEnumLogFontEx));
end;
Result := 1;
end;
//------------------------------------------------------------------------------
function GetLogFonts(const faceName: string; charSet: byte): TArrayOfEnumLogFontEx;
var
lf: TLogFont;
dc: HDC;
begin
Result := nil;
if faceName = '' then Exit;
FillChar(lf, sizeof(lf), 0);
lf.lfCharSet := charSet;
Move(faceName[1], lf.lfFaceName[0], Length(faceName) * SizeOf(Char));
dc := CreateCompatibleDC(0);
try
EnumFontFamiliesEx(dc, lf, @EnumFontProc, LParam(@Result), 0);
finally
DeleteDC(dc);
end;
end;
//------------------------------------------------------------------------------
function GetLogFontFromEnumThatMatchesStyles(LogFonts: TArrayOfEnumLogFontEx;
styles: TMacStyles; out logFont: TLogFont): Boolean;
var
i: integer;
styles2: TMacStyles;
begin
Result := False;
if not Assigned(LogFonts) then Exit;
for i := 0 to High(LogFonts) do
begin
styles2 := [];
if LogFonts[i].elfLogFont.lfWeight > 500 then Include(styles2, msBold);
if LogFonts[i].elfLogFont.lfItalic <> 0 then Include(styles2, msItalic);
if styles <> styles2 then Continue;
logFont := LogFonts[i].elfLogFont;
Result := true;
Exit;
end;
end;
//------------------------------------------------------------------------------
{$ENDIF}
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
function DrawText(image: TImage32; x, y: double; const text: UnicodeString;
font: TFontCache; textColor: TColor32 = clBlack32): double;
var
glyphs: TPathsD;
begin
Result := 0;
if (text = '') or not assigned(font) or not font.IsValidFont then Exit;
glyphs := font.GetTextOutline(x,y, text, Result);
DrawPolygon(image, glyphs, frNonZero, textColor);
end;
//------------------------------------------------------------------------------
function DrawText(image: TImage32; x, y: double; const text: UnicodeString;
font: TFontCache; renderer: TCustomRenderer): double;
var
glyphs: TPathsD;
begin
Result := 0;
if (text = '') or not assigned(font) or
not font.IsValidFont then Exit;
glyphs := font.GetTextOutline(x,y, text, Result);
DrawPolygon(image, glyphs, frNonZero, renderer);
end;
//------------------------------------------------------------------------------
procedure DrawText(image: TImage32; const rec: TRectD;
const text: UnicodeString; font: TFontCache;
textColor: TColor32 = clBlack32; align: TTextAlign = taCenter;
valign: TTextVAlign = tvaMiddle);
var
glyphs: TPathsD;
dx,dy: double;
rec2: TRectD;
chunkedText: TChunkedText;
begin
if (text = '') or not assigned(font) or not font.IsValidFont then Exit;
if align = taJustify then
begin
chunkedText := TChunkedText.Create(text, font, textColor);
try
chunkedText.DrawText( image, Rect(rec), taJustify, valign, 0);
finally
chunkedText.Free;
end;
Exit;
end;
glyphs := font.GetTextOutline(0,0, text);
rec2 := GetBoundsD(glyphs);
case align of
taRight: dx := rec.Right - rec2.Right;
taCenter: dx := (rec.Left + rec.Right - rec2.Right) * 0.5;
else dx := rec.Left;
end;
case valign of
tvaMiddle: dy := (rec.Top + rec.Bottom - rec2.Top) * 0.5;
tvaBottom: dy := rec.Bottom - rec2.Bottom;
else dy := rec.Top + font.Ascent;
end;
glyphs := TranslatePath(glyphs, dx, dy);
DrawPolygon(image, glyphs, frNonZero, textColor);
end;
//------------------------------------------------------------------------------
function DrawAngledText(image: TImage32;
x, y: double; angleRadians: double;
const text: UnicodeString; font: TFontCache;
textColor: TColor32 = clBlack32): TPointD;
var
glyphs: TPathsD;
rotatePt: TPointD;
begin
rotatePt := PointD(x,y);
if not assigned(font) or not font.IsValidFont then
begin
Result := NullPointD;
Exit;
end;
glyphs := font.GetAngledTextGlyphs(x, y,
text, angleRadians, rotatePt, Result);
DrawPolygon(image, glyphs, frNonZero, textColor);
end;
//------------------------------------------------------------------------------
procedure DrawVerticalText(image: TImage32; x, y: double;
const text: UnicodeString; font: TFontCache;
lineHeight: double; textColor: TColor32);
var
glyphs: TPathsD;
cr: TCustomRenderer;
begin
if not assigned(font) or not font.IsValidFont or (text = '') then Exit;
glyphs := font.GetVerticalTextOutline(x,y, text, lineHeight);
if image.AntiAliased then
cr := TColorRenderer.Create(textColor) else
cr := TAliasedColorRenderer.Create(textColor);
try
DrawPolygon(image, glyphs, frNonZero, cr);
finally
cr.Free;
end;
end;
//------------------------------------------------------------------------------
function FindLastSpace(const text: string; StartAt: integer): integer;
begin
Result := StartAt;
while (Result > 0) and (text[Result] <> SPACE) do Dec(Result);
end;
//------------------------------------------------------------------------------
function GetTextOutlineOnPath(const text: UnicodeString;
const path: TPathD; font: TFontCache; textAlign: TTextAlign;
x, y: double; charSpacing: double;
out charsThatFit: integer; out outX: double): TPathsD;
var
pathLen, pathLenMin1: integer;
cummDists: TArrayOfDouble; // cummulative distances
i, currentPathIdx: integer;
textWidth, glyphCenterX, glyphCenterOnPath, dist, dx: double;
glyph: PGlyphInfo;
CharOffsets: TArrayOfDouble;
unitVector: TPointD;
tmpPaths: TPathsD;
begin
Result := nil;
pathLen := Length(path);
pathLenMin1 := pathLen -1;
charsThatFit := Length(text);
if (pathLen < 2) or (charsThatFit = 0) then Exit;
CharOffsets := font.GetGlyphOffsets(text, charSpacing);
textWidth := CharOffsets[charsThatFit];
setLength(cummDists, pathLen +1);
cummDists[0] := 0;
dist := 0;
for i:= 1 to pathLen -1 do
begin
dist := dist + Distance(path[i-1], path[i]);
cummDists[i] := dist;
end;
// truncate text that doesn't fit ...
if textWidth > dist then
begin
Dec(charsThatFit);
while CharOffsets[charsThatFit] > dist do Dec(charsThatFit);
// if possible, break text at a SPACE char
i := FindLastSpace(text, charsThatFit);
if i > 0 then charsThatFit := i;
end;
case textAlign of
taCenter: x := (dist - textWidth) * 0.5;
taRight : x := dist - textWidth;
// else use user defined starting x
end;
Result := nil;
currentPathIdx := 0;
for i := 1 to charsThatFit do
begin
glyph := font.GetGlyphInfo(Ord(text[i]));
with glyph^ do
glyphCenterX := (glyf.xMax - glyf.xMin) * font.Scale * 0.5;
glyphCenterOnPath := x + glyphCenterX;
while (currentPathIdx < pathLenMin1) and
(cummDists[currentPathIdx +1] < glyphCenterOnPath) do
inc(currentPathIdx);
if currentPathIdx = pathLenMin1 then
begin
charsThatFit := i; // nb 1 base vs 0 base :)
Break;
end;
x := x + glyph.hmtx.advanceWidth * font.Scale + charSpacing;
unitVector := GetUnitVector(path[currentPathIdx], path[currentPathIdx +1]);
tmpPaths := RotatePath(glyph.paths,
PointD(glyphCenterX, -y), GetAngle(NullPointD, unitVector));
dx := glyphCenterOnPath - cummDists[currentPathIdx];
tmpPaths := TranslatePath(tmpPaths,
path[currentPathIdx].X + unitVector.X * dx - glyphCenterX,
path[currentPathIdx].Y + unitVector.Y * dx + y);
AppendPath(Result, tmpPaths);
end;
outX := x;
end;
//------------------------------------------------------------------------------
function GetTextOutlineOnPath(const text: UnicodeString;
const path: TPathD; font: TFontCache; textAlign: TTextAlign;
perpendicOffset: integer; charSpacing: double;
out charsThatFit: integer): TPathsD;
var
dummy: double;
begin
Result := GetTextOutlineOnPath(text, path, font, textAlign,
0, perpendicOffset, charSpacing, charsThatFit, dummy);
end;
//------------------------------------------------------------------------------
function GetTextOutlineOnPath(const text: UnicodeString;
const path: TPathD; font: TFontCache; textAlign: TTextAlign;
perpendicOffset: integer = 0; charSpacing: double = 0): TPathsD;
var
dummy: integer;
begin
Result := GetTextOutlineOnPath(text, path, font, textAlign,
perpendicOffset, charSpacing, dummy);
end;
//------------------------------------------------------------------------------
function GetTextOutlineOnPath(const text: UnicodeString;
const path: TPathD; font: TFontCache; x, y: integer;
charSpacing: double; out outX: double): TPathsD;
var
dummy: integer;
begin
Result := GetTextOutlineOnPath(text, path, font, taLeft,
x, y, charSpacing, dummy, outX);
end;
//------------------------------------------------------------------------------
// TTextChunk class
//------------------------------------------------------------------------------
constructor TTextChunk.Create(owner: TChunkedText; const chunk: UnicodeString;
index: integer; fontCache: TFontCache; fontColor, backColor: TColor32);
var
i, listCnt: integer;
begin
Self.owner := owner;
listCnt := owner.fList.Count;
if index < 0 then index := 0
else if index > listCnt then index := listCnt;
self.index := index;
self.text := chunk;
self.fontColor := fontColor;
self.backColor := backColor;
if Assigned(fontCache) then
begin
fontCache.GetTextOutlineInternal(0,0,
chunk, 0, self.arrayOfPaths, self.glyphOffsets, self.width);
self.height := fontCache.LineHeight;
self.ascent := fontCache.Ascent;
end else
begin
self.arrayOfPaths := nil;
SetLength(self.glyphOffsets, 1);
self.glyphOffsets[0] := 0;
self.width := 0;
self.height := 0;
self.ascent := 0;
end;
owner.fList.Insert(index, self);
// reindex any trailing chunks
if index < listCnt then
for i := index +1 to listCnt do
TTextChunk(owner.fList[i]).index := i;
end;
//------------------------------------------------------------------------------
// TChunkedText
//------------------------------------------------------------------------------
constructor TChunkedText.Create;
begin
inherited;
{$IFDEF XPLAT_GENERICS}
fList := TList<TTextChunk>.Create;
{$ELSE}
fList := TList.Create;
{$ENDIF}
end;
//------------------------------------------------------------------------------
constructor TChunkedText.Create(const text: string; font: TFontCache;
fontColor: TColor32; backColor: TColor32);
begin
Create;
SetText(text, font, fontColor, backColor);
end;
//------------------------------------------------------------------------------
destructor TChunkedText.Destroy;
begin
Clear;
fList.Free;
inherited;
end;
//------------------------------------------------------------------------------
function TChunkedText.GetChunk(index: integer): TTextChunk;
begin
if (index < 0) or (index >= fList.Count) then
raise Exception.Create(rsChunkedTextRangeError);
Result := TTextChunk(fList.Items[index]);
end;
//------------------------------------------------------------------------------
function TChunkedText.GetText: UnicodeString;
var
i: integer;
begin
Result := '';
for i := 0 to Count -1 do
Result := Result + TTextChunk(fList.Items[i]).text;
end;
//------------------------------------------------------------------------------
procedure TChunkedText.AddNewline(font: TFontCache);
var
nlChunk: TTextChunk;
begin
if not Assigned(font) or not font.IsValidFont then
raise Exception.Create(rsChunkedTextFontError);
if (fLastFont = font) then
begin
// this is much faster as it bypasses font.GetTextOutlineInternal
nlChunk := InsertTextChunk(nil, MaxInt, #10, clNone32);
nlChunk.height := fLastFont.LineHeight;
nlChunk.ascent := fLastFont.Ascent;
end else
begin
nlChunk := InsertTextChunk(font, MaxInt, SPACE, clNone32);
nlChunk.text := #10;
fSpaceWidth := nlChunk.width;
fLastFont := font;
end;
end;
//------------------------------------------------------------------------------
procedure TChunkedText.AddSpace(font: TFontCache);
var
spaceChunk: TTextChunk;
begin
if not Assigned(font) or not font.IsValidFont then
raise Exception.Create(rsChunkedTextFontError);
if (fLastFont = font) then
begin
// this is much faster as it bypasses font.GetTextOutlineInternal
spaceChunk := InsertTextChunk(nil, MaxInt, SPACE, clNone32);
spaceChunk.width := fSpaceWidth;
spaceChunk.height := fLastFont.LineHeight;
spaceChunk.ascent := fLastFont.Ascent;
end else
begin
spaceChunk := InsertTextChunk(font, MaxInt, SPACE, clNone32);
fLastFont := font;
fSpaceWidth := spaceChunk.width;
end;
end;
//------------------------------------------------------------------------------
function TChunkedText.AddTextChunk(font: TFontCache; const chunk: UnicodeString;
fontColor: TColor32; backColor: TColor32): TTextChunk;
begin
Result := InsertTextChunk(font, MaxInt, chunk, fontColor, backColor);
end;
//------------------------------------------------------------------------------
function TChunkedText.InsertTextChunk(font: TFontCache; index: integer;
const chunk: UnicodeString; fontColor: TColor32;
backColor: TColor32): TTextChunk;
begin
Result := TTextChunk.Create(self, chunk, index, font, fontColor, backColor);
end;
//------------------------------------------------------------------------------
function TChunkedText.GetCount: integer;
begin
Result := fList.Count;
end;
//------------------------------------------------------------------------------
procedure TChunkedText.Clear;
var
i: integer;
begin
for i := 0 to fList.Count -1 do
TTextChunk(fList.Items[i]).Free;
fList.Clear;
end;
//------------------------------------------------------------------------------
procedure TChunkedText.DeleteChunk(Index: Integer);
var
i: integer;
begin
if (index < 0) or (index >= fList.Count) then
raise Exception.Create(rsChunkedTextRangeError);
TTextChunk(fList.Items[index]).Free;
fList.Delete(index);
// reindex
for i := Index to fList.Count -1 do
dec(TTextChunk(fList.Items[i]).index);
end;
//------------------------------------------------------------------------------
procedure TChunkedText.DeleteChunkRange(startIdx, endIdx: Integer);
var
i, cnt: Integer;
begin
cnt := endIdx - startIdx +1;
if (startIdx < 0) or (endIdx >= fList.Count) or (cnt <= 0) then
raise Exception.Create(rsChunkedTextRangeError);
for i := startIdx to endIdx do
TTextChunk(fList.Items[i]).Free;
// reindex
for i := startIdx to fList.Count -1 do
dec(TTextChunk(fList.Items[i]).index, cnt);
end;
//------------------------------------------------------------------------------
procedure TChunkedText.SetText(const text: UnicodeString;
font: TFontCache; fontColor: TColor32; backColor: TColor32);
var
len: integer;
p, p2, pEnd: PWideChar;
s: UnicodeString;
begin
if not Assigned(font) then Exit;
Clear;
p := PWideChar(text);
pEnd := p;
Inc(pEnd, Length(text));
while p < pEnd do
begin
if (p^ <= SPACE) then
begin
if (p^ = SPACE) then AddSpace(font)
else if (p^ = #10) then AddNewline(font);
inc(p);
end else
begin
p2 := p;
inc(p);
while (p < pEnd) and (p^ > SPACE) do inc(p);
len := p - p2;
SetLength(s, len);
Move(p2^, s[1], len * SizeOf(Char));
AddTextChunk(font, s, fontColor, backColor);
end;
end;
end;
//------------------------------------------------------------------------------
function TChunkedText.GetPageMetrics(const rec: TRect; lineHeight: double;
startingChunkIdx: integer): TPageTextMetrics;
var
pageWidth, pageHeight : integer;
lh, priorSplitWidth : double;
currentX : double;
arrayCnt, arrayCap : integer;
chunkIdxAtStartOfLine : integer;
currentChunkIdx : integer;
linesFinished : Boolean;
procedure SetResultLength(len: integer);
begin
SetLength(Result.startOfLineIdx, len);
SetLength(Result.justifyDeltas, len);
SetLength(Result.lineWidths, len);
end;
procedure CheckArrayCap;
begin
if arrayCnt < arrayCap then Exit;
inc(arrayCap, 16);
SetResultLength(arrayCap);
end;
function IsRoomForCurrentLine: Boolean;
begin
Result := (arrayCnt + 1) * lh <= pageHeight;
end;
function CheckLineHeight(currentChunk: TTextChunk): Boolean;
begin
// unless a user-defined lineHeight has been assigned (lineHeight > 0),
// get the largest lineHeight of all displayed chunks and use that
// lineHeight for *every* line that's being displayed ...
if (lineHeight = 0) and (currentChunk.height > lh) then
begin
// first make sure that this chunk will fit
Result := (arrayCnt + 1) * currentChunk.height <= pageHeight;
if Result then lh := currentChunk.height;
end else
Result := IsRoomForCurrentLine;
end;
procedure AddLine;
var
i, spcCnt, ChunkIdxAtEndOfLine: integer;
x: double;
chnk: TTextChunk;
begin
CheckArrayCap;
ChunkIdxAtEndOfLine := currentChunkIdx -1;
// ignore spaces at the end of lines
while (ChunkIdxAtEndOfLine > chunkIdxAtStartOfLine) and
(Chunk[ChunkIdxAtEndOfLine].text = SPACE) do
Dec(ChunkIdxAtEndOfLine);
x := -priorSplitWidth; spcCnt := 0;
for i := chunkIdxAtStartOfLine to ChunkIdxAtEndOfLine do
begin
chnk := Chunk[i];
if chnk.text = SPACE then inc(spcCnt);
x := x + chnk.width;
end;
Result.lineWidths[arrayCnt] := x;
Result.lineHeight := lh;
Result.startOfLineIdx[arrayCnt] := chunkIdxAtStartOfLine;
if spcCnt = 0 then
Result.justifyDeltas[arrayCnt] := 0 else
Result.justifyDeltas[arrayCnt] := (pageWidth - x)/spcCnt;
inc(arrayCnt);
chunkIdxAtStartOfLine := currentChunkIdx;
currentX := 0;
priorSplitWidth := 0;
end;
procedure AddSplitChunkLines(glyphOffset: integer);
var
highI: integer;
residualWidth: double;
chnk: TTextChunk;
begin
chnk := Chunk[chunkIdxAtStartOfLine];
priorSplitWidth := chnk.glyphOffsets[glyphOffset];
highI := High(chnk.glyphOffsets);
residualWidth := chnk.width - priorSplitWidth;
while (highI >= glyphOffset) and (residualWidth > pageWidth) do
begin
residualWidth := chnk.glyphOffsets[highI] - priorSplitWidth;
Dec(highI);
end;
if highI < glyphOffset then
begin
// oops, even a single character won't fit !!
linesFinished := true;
currentChunkIdx := chunkIdxAtStartOfLine;
end
else if not IsRoomForCurrentLine then
begin
linesFinished := true;
currentChunkIdx := chunkIdxAtStartOfLine;
end
else
begin
CheckArrayCap;
Result.lineWidths[arrayCnt] := residualWidth;
Result.lineHeight := lh;
Result.startOfLineIdx[arrayCnt] := chunkIdxAtStartOfLine;
Result.justifyDeltas[arrayCnt] := 0;
if (highI = High(chnk.glyphOffsets)) then
begin
currentX := residualWidth;
inc(currentChunkIdx);
end else
begin
inc(arrayCnt);
AddSplitChunkLines(highI +1); // note recursion
end;
end;
end;
var
chnk: TTextChunk;
begin
FillChar(Result, SizeOf(Result), 0);
arrayCnt := 0; arrayCap := 0;
if (startingChunkIdx < 0) then startingChunkIdx := 0;
if (Count = 0) or (startingChunkIdx >= Count) then Exit;
lh := lineHeight;
RectWidthHeight(rec, pageWidth, pageHeight);
currentChunkIdx := startingChunkIdx;
chunkIdxAtStartOfLine := startingChunkIdx;
currentX := 0;
priorSplitWidth := 0;
linesFinished := false;
while (currentChunkIdx < Count) do
begin
chnk := Chunk[currentChunkIdx];
if not CheckLineHeight(chnk) then break;
if (chnk.text = #10) then
begin
AddLine;
if arrayCnt > 0 then
Result.justifyDeltas[arrayCnt-1] := 0;
inc(currentChunkIdx);
chunkIdxAtStartOfLine := currentChunkIdx;
end
else if (currentX + chnk.width > pageWidth) then
begin
if (currentChunkIdx = chunkIdxAtStartOfLine) then
begin
// a single chunk is too wide for 'pageWidth'
AddSplitChunkLines(0);
if linesFinished or (currentChunkIdx = Count) then Break;
end else
begin
AddLine;
// don't allow spaces to wrap to the front of the following line
while (currentChunkIdx < Count) and
(self.chunk[currentChunkIdx].text = SPACE) do
inc(currentChunkIdx);
chunkIdxAtStartOfLine := currentChunkIdx;
end;
end else
begin
currentX := currentX + chnk.width;
inc(currentChunkIdx);
end;
end;
if not linesFinished and
(currentChunkIdx > chunkIdxAtStartOfLine) then AddLine;
Result.lineCount := arrayCnt;
SetResultLength(arrayCnt);
Result.nextChuckIdx := currentChunkIdx;
if (arrayCnt > 0) and (Result.nextChuckIdx = Count) then
Result.justifyDeltas[arrayCnt-1] := 0;
end;
//------------------------------------------------------------------------------
function TChunkedText.GetChunkAndGlyphOffsetAtPt(const ptm: TPageTextMetrics;
const pt: TPoint; out glyphIdx, chunkChrOff: integer): Boolean;
var
x,y, maxY, maxIdx: integer;
x2 : Double;
chnk: TTextChunk;
begin
Result := false;
x := pt.X - ptm.bounds.Left;
y := Trunc((pt.Y - ptm.bounds.Top - ptm.topLinePxOffset) / ptm.lineHeight);
maxY := ptm.lineCount -1;
if (x < 0) or (x > ptm.bounds.right - ptm.bounds.Left) or
(y < 0) or (y > maxY) then Exit;
if y = maxY then
maxIdx := ptm.nextChuckIdx -1 else
maxIdx := ptm.startOfLineIdx[y +1] -1;
glyphIdx := ptm.startOfLineIdx[y];
chunkChrOff := 0;
x2 := x;
// get chunkIdx within line 'y' ...
while (glyphIdx < maxIdx) do
begin
if Chunk[glyphIdx].text = space then
begin
if x2 < Chunk[glyphIdx].width + ptm.justifyDeltas[y] then Break;
x2 := x2 - Chunk[glyphIdx].width - ptm.justifyDeltas[y];
end else
begin
if x2 < Chunk[glyphIdx].width then Break;
x2 := x2 - Chunk[glyphIdx].width;
end;
inc(glyphIdx);
end;
// get chunkChrOffset within Chunk[chunkIdx] ...
chnk := Chunk[glyphIdx];
while x2 >= chnk.glyphOffsets[chunkChrOff +1] do Inc(chunkChrOff);
Result := true;
end;
//------------------------------------------------------------------------------
function TChunkedText.GetGlyphsOrDrawInternal(image: TImage32; const rec: TRect;
textAlign: TTextAlign; textAlignV: TTextVAlign; startChunk: integer;
lineHeight: double; out paths: TPathsD): TPageTextMetrics;
var
i,j, highJ,k, recWidth, recHeight: integer;
a,b, chrIdx, lastLine: integer;
x,y, totalHeight, lineWidth, spcDx: double;
consumedWidth: double;
pp: TPathsD;
top: double;
chnk: TTextChunk;
begin
paths := nil;
FillChar(Result, SizeOf(Result), 0);
Result.nextChuckIdx := startChunk;
if Count = 0 then Exit;
RectWidthHeight(rec, recWidth, recHeight);
// LINE HEIGHTS ...............
// Getting lineheights based on a given font's ascent and descent values
// works well only when a single font is used. Unfortunately, when using
// multiple fonts, line spacing becomes uneven and looks ugly.
// An alternative approach is to measure the highest and lowest bounds of all
// the glyphs in a line, and use these and a fixed inter line space
// to derive variable line heights. But this approach also has problems,
// especially when lines contain no glyphs, or when they only contain glyphs
// with minimal heights (----------). So this too can look ugly.
// A third approach, is to get the maximum of every lines' height and use
// that value for every line. But this approach tends to produce undesirably
// large line heights.
// A fourth approach is to use the height of the very first text chunk.
// And a final approach ia simply to use a user defined line height
if lineHeight = 0 then
lineHeight := Chunk[0].height;
Result := GetPageMetrics(rec, lineHeight, startChunk);
if (Result.lineCount = 0) or (lineHeight > recHeight) then Exit;
// only return glyphs for visible lines
totalHeight := lineHeight * Result.lineCount;
i := Result.startOfLineIdx[0];
top := rec.Top + Chunk[i].ascent;
case textAlignV of
tvaMiddle: y := top + (RecHeight - totalHeight) /2 -1;
tvaBottom: y := rec.bottom - totalHeight + Chunk[i].ascent;
else y := top;
end;
Result.bounds := rec;
Result.topLinePxOffset := Round(y - top);
chrIdx := 0;
lastLine := Result.lineCount -1;
for i := 0 to lastLine do
begin
a := Result.startOfLineIdx[i];
if i = lastLine then
begin
if (chunk[a].width - chunk[a].glyphOffsets[chrIdx] > recWidth) then
b := a -1 // flag getting glyphs for a partial chunk
else if Result.nextChuckIdx = 0 then
b := Count -1
else
b := Result.nextChuckIdx -1;
end else
b := Result.startOfLineIdx[i+1] -1;
if textAlign = taJustify then
spcDx := Result.justifyDeltas[i] else
spcDx := 0;
lineWidth := Result.lineWidths[i];
if (b < a) then
begin
// chunk[a] width exceeds recWidth
chnk := chunk[a];
consumedWidth := chnk.glyphOffsets[chrIdx];
highJ := High(chnk.glyphOffsets);
j := chrIdx;
while (j < highJ) and
(chnk.glyphOffsets[j+1] -consumedWidth < lineWidth) do inc(j);
pp := nil;
for k := chrIdx to j do
AppendPath(pp, chnk.arrayOfPaths[k]);
pp := TranslatePath(pp, rec.Left - consumedWidth, y);
chnk.left := rec.Left;
chnk.top := y - chnk.ascent;
if Assigned(image) then
begin
if Assigned(fDrawChunkEvent) then
fDrawChunkEvent(chnk, RectD(rec.Left, chnk.top,
rec.Left + consumedWidth, chnk.top + chnk.height));
DrawPolygon(image, pp, frNonZero, chnk.fontColor);
end else
AppendPath(paths, pp);
y := y + lineHeight;
chrIdx := j +1;
Continue;
end
else if chrIdx > 0 then
begin
// finish the partially processed chunk before continuing to next one
chnk := chunk[a];
highJ := High(chnk.glyphOffsets);
consumedWidth := chnk.glyphOffsets[chrIdx];
j := chrIdx;
while (j < highJ) and
(chnk.glyphOffsets[j+1] -consumedWidth < lineWidth) do inc(j);
pp := nil;
for k := chrIdx to j do
AppendPath(pp, chnk.arrayOfPaths[k]);
pp := TranslatePath(pp, rec.Left - consumedWidth, y);
if Assigned(image) then
DrawPolygon(image, pp, frNonZero, chnk.fontColor) else
AppendPath(paths, pp);
if (j = chrIdx) and (j < highJ) then
break // oops, even a character is too wide for 'rec' !
else if j < HighJ then
begin
chrIdx := j;
Continue;
end else
begin
chrIdx := 0;
x := rec.Left + chnk.width - consumedWidth;
inc(a);
end;
end else
begin
case textAlign of
taRight : x := rec.Left + (recWidth - lineWidth);
taCenter : x := rec.Left + (recWidth - lineWidth) / 2;
else x := rec.Left;
end;
end;
// ignore trailing spaces
while (b >= a) do
if Chunk[b].text <= SPACE then
dec(b) else
break;
for j := a to b do
begin
chnk := GetChunk(j);
chnk.left := x;
chnk.top := y - chnk.ascent;
if chnk.text > SPACE then
begin
pp := MergeArrayOfPathsEx(chnk.arrayOfPaths, x, y);
if Assigned(image) then
begin
if (GetAlpha(chnk.backColor) > 0) then
image.FillRect(Img32.Vector.Rect(RectD(x, chnk.top,
x + chnk.width, chnk.top + chnk.height)), chnk.backColor);
if Assigned(fDrawChunkEvent) then
fDrawChunkEvent(chnk, RectD(x, chnk.top,
x + chnk.width, chnk.top + chnk.height));
DrawPolygon(image, pp, frNonZero, chnk.fontColor);
end else
AppendPath(paths, pp);
x := x + chnk.width;
end else
begin
if (GetAlpha(chnk.backColor) > 0) then
image.FillRect(Img32.Vector.Rect(RectD(x, chnk.top,
x + chnk.width + spcDx, chnk.top + chnk.height)),
chnk.backColor);
if Assigned(image) and Assigned(fDrawChunkEvent) then
fDrawChunkEvent(chnk, RectD(x, chnk.top,
x + chnk.width + spcDx, chnk.top + chnk.height));
x := x + chnk.width + spcDx;
end;
end;
y := y + lineHeight;
end;
end;
//------------------------------------------------------------------------------
function TChunkedText.DrawText(image: TImage32; const rec: TRect;
textAlign: TTextAlign; textAlignV: TTextVAlign;
startChunk: integer; lineHeight: double): TPageTextMetrics;
var
dummy: TPathsD;
begin
Result := GetGlyphsOrDrawInternal(image,
rec, textAlign, textAlignV, startChunk, lineHeight, dummy);
end;
//------------------------------------------------------------------------------
function TChunkedText.GetTextGlyphs(const rec: TRect;
textAlign: TTextAlign; textAlignV: TTextVAlign; startChunk: integer;
lineHeight: double = 0.0): TPathsD;
begin
GetGlyphsOrDrawInternal(nil, rec, textAlign, textAlignV,
startChunk, lineHeight, Result);
end;
//------------------------------------------------------------------------------
procedure TChunkedText.ApplyNewFont(font: TFontCache);
var
i: integer;
begin
if not Assigned(font) then Exit;
for i := 0 to Count -1 do
with Chunk[i] do
begin
font.GetTextOutlineInternal(0,0,
text, 0, arrayOfPaths, glyphOffsets, width);
height := font.LineHeight;
ascent := font.Ascent;
end;
end;
//------------------------------------------------------------------------------
// TFontManager
//------------------------------------------------------------------------------
constructor TFontManager.Create;
begin
fMaxFonts := 32;
{$IFDEF XPLAT_GENERICS}
fFontList := TList<TFontReader>.Create;
{$ELSE}
fFontList:= TList.Create;
{$ENDIF}
end;
//------------------------------------------------------------------------------
destructor TFontManager.Destroy;
begin
Clear;
fFontList.Free;
inherited;
end;
//------------------------------------------------------------------------------
procedure TFontManager.Clear;
var
i: integer;
begin
for i := 0 to fFontList.Count -1 do
with TFontReader(fFontList[i]) do
begin
fFontManager := nil;
Free;
end;
fFontList.Clear;
end;
//------------------------------------------------------------------------------
function TFontManager.FindDuplicate(fr: TFontReader): integer;
var
fi, fi2: TFontInfo;
begin
fi := fr.FontInfo;
for Result := 0 to fFontList.Count -1 do
begin
fi2 := TFontReader(fFontList[Result]).FontInfo;
if SameText(fi.fullFaceName, fi2.fullFaceName) and
(fi.macStyles = fi2.macStyles) then Exit;
end;
Result := -1;
end;
//------------------------------------------------------------------------------
{$IFDEF MSWINDOWS}
function TFontManager.LoadFontReaderFamily(const fontFamily: string): TLoadFontResult;
var
frf: TFontReaderFamily;
begin
Result := LoadFontReaderFamily(fontFamily, frf);
end;
//------------------------------------------------------------------------------
function TFontManager.LoadFontReaderFamily(const fontFamily: string;
out fontReaderFamily: TFontReaderFamily): TLoadFontResult;
var
arrayEnumLogFont: TArrayOfEnumLogFontEx;
lf: TLogFont;
fontInfo: TFontInfo;
function FontInfoNamesAndSytlesMatch(const fontInfo1, fontInfo2: TFontInfo): Boolean;
begin
Result := (fontInfo1.faceName = fontInfo2.faceName) and
(fontInfo1.macStyles = fontInfo2.macStyles);
end;
begin
Result := lfrInvalid;
fontReaderFamily.regularFR := nil;
fontReaderFamily.boldFR := nil;
fontReaderFamily.italicFR := nil;
fontReaderFamily.boldItalicFR := nil;
if (fontFamily = '') or (Length(fontFamily) > LF_FACESIZE) then Exit;
arrayEnumLogFont := GetLogFonts(fontFamily, DEFAULT_CHARSET); //ANSI_CHARSET);
FillChar(lf, SizeOf(TLogFont), 0);
Move(fontFamily[1], lf.lfFaceName[0], Length(fontFamily) * SizeOf(Char));
if not GetLogFontFromEnumThatMatchesStyles(arrayEnumLogFont, [], lf) then Exit;
// make room for 4 new fontreaders
while fFontList.Count > fMaxFonts - 4 do DeleteOldestFont;
fontReaderFamily.regularFR := TFontReader.Create;
fontReaderFamily.regularFR.Load(lf);
Result := ValidateFontLoad(fontReaderFamily.regularFR);
case Result of
lfrInvalid: Exit;
lfrDuplicate:
begin
fontInfo := fontReaderFamily.regularFR.FontInfo;
fontInfo.macStyles := [msBold];
fontReaderFamily.boldFR := GetBestMatchFont(fontInfo);
if not FontInfoNamesAndSytlesMatch(FontInfo,
fontReaderFamily.boldFR.FontInfo) then
fontReaderFamily.boldFR := nil;
fontInfo.macStyles := [msItalic];
fontReaderFamily.italicFR := GetBestMatchFont(fontInfo);
if not FontInfoNamesAndSytlesMatch(FontInfo,
fontReaderFamily.italicFR.FontInfo) then
fontReaderFamily.italicFR := nil;
fontInfo.macStyles := [msBold, msItalic];
fontReaderFamily.boldItalicFR := GetBestMatchFont(fontInfo);
if not FontInfoNamesAndSytlesMatch(FontInfo,
fontReaderFamily.boldItalicFR.FontInfo) then
fontReaderFamily.boldItalicFR := nil;
end;
else
begin
if GetLogFontFromEnumThatMatchesStyles(arrayEnumLogFont, [msBold], lf) then
begin
fontReaderFamily.boldFR := TFontReader.Create;
fontReaderFamily.boldFR.Load(lf);
ValidateFontLoad(fontReaderFamily.boldFR);
end;
if GetLogFontFromEnumThatMatchesStyles(arrayEnumLogFont, [msItalic], lf) then
begin
fontReaderFamily.italicFR := TFontReader.Create;
fontReaderFamily.italicFR.Load(lf);
ValidateFontLoad(fontReaderFamily.italicFR);
end;
if GetLogFontFromEnumThatMatchesStyles(arrayEnumLogFont, [msBold, msItalic], lf) then
begin
fontReaderFamily.boldItalicFR := TFontReader.Create;
fontReaderFamily.boldItalicFR.Load(lf);
ValidateFontLoad(fontReaderFamily.boldItalicFR);
end;
end;
end;
end;
//------------------------------------------------------------------------------
function TFontManager.LoadFontReader(const fontName: string): TFontReader;
begin
Result := nil;
if (fontName = '') or (Length(fontName) > LF_FACESIZE) then Exit;
if fFontList.Count >= fMaxFonts then DeleteOldestFont;
Result := TFontReader.Create(fontName);
ValidateFontLoad(Result);
end;
//------------------------------------------------------------------------------
{$ENDIF}
function TFontManager.LoadFromStream(stream: TStream): TFontReader;
begin
if fFontList.Count >= fMaxFonts then DeleteOldestFont;
Result := TFontReader.Create;
try
if not Result.LoadFromStream(stream) then FreeAndNil(Result)
else ValidateFontLoad(Result);
except
FreeAndNil(Result);
end;
end;
//------------------------------------------------------------------------------
function TFontManager.LoadFromResource(const resName: string; resType: PChar): TFontReader;
begin
if fFontList.Count >= fMaxFonts then DeleteOldestFont;
Result := TFontReader.Create;
try
if not Result.LoadFromResource(resName, resType) then FreeAndNil(Result)
else ValidateFontLoad(Result);
except
FreeAndNil(Result);
end;
end;
//------------------------------------------------------------------------------
function TFontManager.LoadFromFile(const filename: string): TFontReader;
begin
if fFontList.Count >= fMaxFonts then DeleteOldestFont;
Result := TFontReader.Create;
try
if not Result.LoadFromFile(filename) then FreeAndNil(Result)
else ValidateFontLoad(Result);
except
FreeAndNil(Result);
end;
end;
//------------------------------------------------------------------------------
function TFontManager.ValidateFontLoad(var fr: TFontReader): TLoadFontResult;
var
dupIdx: integer;
begin
if not fr.IsValidFontFormat then
begin
FreeAndNil(fr);
result := lfrInvalid;
Exit;
end;
dupIdx := FindDuplicate(fr);
if dupIdx >= 0 then
begin
FreeAndNil(fr);
result := lfrDuplicate;
fr := fFontList[dupIdx];
end else
begin
Result := lfrSuccess;
fFontList.Add(fr);
fr.fFontManager := self;
end;
end;
//------------------------------------------------------------------------------
function TFontManager.Delete(fontReader: TFontReader): Boolean;
var
i: integer;
begin
for i := 0 to fFontList.Count -1 do
if TFontReader(fFontList[i]) = fontReader then
begin
// make sure the FontReader object isn't destroying itself externally
if not fontReader.fDestroying then fontReader.Free;
fFontList.Delete(i);
Result := true;
Exit;
end;
Result := false;
end;
//------------------------------------------------------------------------------
function StylesToInt(macstyles: TMacStyles): integer;
{$IFDEF INLINE} inline; {$ENDIF}
begin
if msBold in macStyles then
Result := 1 else Result := 0;
if msItalic in macStyles then inc(Result, 2);
end;
//------------------------------------------------------------------------------
function FontFamilyToInt(family: TFontFamily): integer;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result := Ord(family) +1;
end;
//------------------------------------------------------------------------------
function TFontManager.GetBestMatchFont(const fontInfo: TFontInfo): TFontReader;
function GetStyleDiff(const macstyles1, macstyles2: TMacStyles): integer;
{$IFDEF INLINE} inline; {$ENDIF}
begin
// top priority
Result := (((Byte(macstyles1) xor $FF) or
(Byte(macstyles2) xor $FF)) and $3) * 256;
end;
function GetFontFamilyDiff(const family1, family2: TFontFamily): integer;
{$IFDEF INLINE} inline; {$ENDIF}
begin
// second priority
if family1 = tfUnknown then
Result := 0 else
Result := Abs(FontFamilyToInt(family1) - FontFamilyToInt(family2)) * 8;
end;
function GetShortNameDiff(const name1, name2: Utf8String): integer;
{$IFDEF INLINE} inline; {$ENDIF}
begin
// third priority (shl 3)
if name1 = '' then
Result := 0 else
if SameText(name1, name2) then Result := 0 else Result := 4;
end;
function GetFullNameDiff(const fiToMatch: TFontInfo;
const candidateName: Utf8String): integer;
var
i: integer;
begin
// lowest priority
Result := 0;
if Assigned(fiToMatch.familyNames) then
begin
for i := 0 to High(fiToMatch.familyNames) do
if SameText(fiToMatch.familyNames[i], candidateName) then Exit;
end
else if SameText(fiToMatch.faceName, candidateName) then Exit;
Result := 2;
end;
function CompareFontInfos(const fiToMatch, fiCandidate: TFontInfo): integer;
begin
Result :=
GetStyleDiff(fiToMatch.macStyles, fiCandidate.macStyles) +
GetFontFamilyDiff(fiToMatch.family, fiCandidate.family) +
GetShortNameDiff(fiToMatch.faceName, fiCandidate.faceName) +
GetFullNameDiff(fiToMatch, fiCandidate.fullFaceName);
end;
var
i, bestDiff, currDiff: integer;
fr: TFontReader;
begin
Result := nil;
bestDiff := MaxInt;
for i := 0 to fFontList.Count -1 do
begin
fr := TFontReader(fFontList[i]);
currDiff := CompareFontInfos(fontInfo, fr.fFontInfo);
if (currDiff < bestDiff) then
begin
Result := fr;
if currDiff = 0 then Break; // can't do better :)
bestDiff := currDiff;
end;
end;
end;
//------------------------------------------------------------------------------
function TFontManager.GetBestMatchFont(const styles: TMacStyles): TFontReader;
var
i, bestDiff, currDiff: integer;
fr: TFontReader;
begin
Result := nil;
bestDiff := MaxInt;
for i := 0 to fFontList.Count -1 do
begin
fr := TFontReader(fFontList[i]);
currDiff := (((Byte(styles) xor $FF) or (Byte(fr.fFontInfo.macStyles) xor $FF)) and $3);
if (currDiff < bestDiff) then
begin
Result := fr;
if currDiff = 0 then Break; // can't do any better :)
bestDiff := currDiff;
end;
end;
end;
//------------------------------------------------------------------------------
function TFontManager.FindReaderContainingGlyph(codepoint: Cardinal;
fntFamily: TFontFamily; out glyphIdx: WORD): TFontReader;
var
i: integer;
reader: TFontReader;
begin
result := nil;
for i := 0 to fFontList.Count -1 do
begin
reader := TFontReader(fFontList[i]);
glyphIdx := reader.GetGlyphIdxUsingCmap(codepoint);
// if a font family is specified, then only return true
// when finding the glyph within that font family
if (glyphIdx > 0) and ((fntFamily = tfUnknown) or
(reader.FontFamily = tfUnknown) or (fntFamily = reader.FontFamily)) then
begin
Result := reader;
Exit;
end;
end;
glyphIdx := 0;
end;
//------------------------------------------------------------------------------
procedure TFontManager.SetMaxFonts(value: integer);
begin
if value < 0 then value := 0;
if value <= 0 then Clear
else while value > fFontList.Count do
Delete(TFontReader(fFontList[0]));
fMaxFonts := value;
end;
//------------------------------------------------------------------------------
function FontSorterProc(fontreader1, fontreader2: Pointer): integer;
var
fr1: TFontReader absolute fontreader1;
fr2: TFontReader absolute fontreader2;
begin
if fr1.fLastUsedTime > fr2.fLastUsedTime then Result := -1
else if fr1.fLastUsedTime < fr2.fLastUsedTime then Result := 1
else Result := 0;
end;
//------------------------------------------------------------------------------
procedure TFontManager.SortFontListOnLastUse;
begin
{$IFDEF XPLAT_GENERICS}
fFontList.Sort(TComparer<TFontReader>.Construct(
function (const fr1, fr2: TFontReader): integer
begin
if fr1.fLastUsedTime > fr2.fLastUsedTime then Result := -1
else if fr1.fLastUsedTime < fr2.fLastUsedTime then Result := 1
else Result := 0;
end));
{$ELSE}
fFontList.Sort(FontSorterProc);
{$ENDIF}
end;
//------------------------------------------------------------------------------
procedure TFontManager.DeleteOldestFont;
var
cnt: integer;
begin
cnt := fFontList.Count;
if cnt = 0 then Exit;
SortFontListOnLastUse;
TFontReader(fFontList[cnt -1]).Free;
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
function FontManager: TFontManager;
begin
result := aFontManager;
end;
//------------------------------------------------------------------------------
initialization
aFontManager := TFontManager.Create;
finalization
aFontManager.Free;
end.