unit Img32.Text; (******************************************************************************* * Author : Angus Johnson * * Version : 4.3 * * Date : 6 October 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * * * Purpose : TrueType fonts for TImage32 (without Windows dependencies) * * * * License : Use, modification & distribution is subject to * * Boost Software License Ver 1 * * 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; type TFixed = type single; Int16 = type SmallInt; TFontFormat = (ffInvalid, ffTrueType, ffCompact); TTtfFontFamily = (ttfUnknown, ttfSerif, ttfSansSerif, ttfMonospace); {$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; TCmapFormat6 = record format : WORD; //6 length : WORD; language : WORD; firstCode : WORD; entryCount : WORD; 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; //ltr, rtl 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; TFontInfo = record //a custom summary record fontFormat : TFontFormat; fontFamily : TTtfFontFamily; faceName : UnicodeString; style : UnicodeString; copyright : UnicodeString; manufacturer : UnicodeString; 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; TGlyphMetrics = record //a custom metrics record glyphIdx : integer; unitsPerEm : integer; glyf : TFontTable_Glyf; hmtx : TFontTable_Hmtx; kernList : TArrayOfTKern; end; TFontTableArray = array of TFontTable; TArrayOfWord = array of WORD; TArrayOfCardinal = array of Cardinal; TArrayOfCmapTblRec = array of TCmapTblRec; TPointEx = record pt: TPointD; flag: byte; end; TPathEx = array of TPointEx; TPathsEx = array of TPathEx; TTableName = (tblName, tblHead, tblHhea, tblCmap, tblMaxp, tblLoca, tblGlyf, tblHmtx, tblKern, tblPost); {$IFDEF ZEROBASEDSTR} {$ZEROBASEDSTRINGS OFF} {$ENDIF} TFontReader = class; TFontManager = class private fMaxFonts: integer; {$IFDEF XPLAT_GENERICS} fFontList: TList; {$ELSE} fFontList: TList; {$ENDIF} procedure SetMaxFonts(value: integer); function ValidateAdd(fr: TFontReader): Boolean; public constructor Create; destructor Destroy; override; procedure Clear; function GetFont(const fontName: string): TFontReader; {$IFDEF MSWINDOWS} function Load(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; 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; 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_glyf : TFontTable_Glyf; fTbl_hmtx : TFontTable_Hmtx; fTbl_post : TFontTable_Post; fTbl_loca2 : TArrayOfWord; fTbl_loca4 : TArrayOfCardinal; fCmapTblRecs : TArrayOfCmapTblRec; fFormat0CodeMap : array[0..255] of byte; fFormat4EndCodes : TArrayOfWord; fFormat4StartCodes : TArrayOfWord; fFormat4IdDelta : TArrayOfWord; fFormat4RangeOff : TArrayOfWord; fFormat4Offset : integer; fKernTable : TArrayOfKernRecs; function GetTables: Boolean; function GetTable_name: Boolean; function GetTable_cmap: Boolean; function GetTable_maxp: Boolean; function GetTable_head: Boolean; function GetTable_loca: Boolean; function GetTable_hhea: Boolean; procedure GetTable_kern; procedure GetTable_post; function GetGlyphPaths(glyphIdx: integer): TPathsEx; function GetGlyphIdxFromCmapIdx(idx: Word): integer; function GetSimpleGlyph: TPathsEx; function GetCompositeGlyph: TPathsEx; function ConvertSplinesToBeziers(const pathsEx: TPathsEx): TPathsEx; procedure GetPathCoords(var paths: TPathsEx); function GetGlyphHorzMetrics(glyphIdx: integer): Boolean; function GetFontInfo: TFontInfo; function GetGlyphKernList(glyphIdx: integer): TArrayOfTKern; function GetGlyphMetricsInternal(glyphIdx: integer): TGlyphMetrics; function GetWeight: integer; function GetFontFamily: TTtfFontFamily; procedure BeginUpdate; procedure EndUpdate; procedure NotifyRecipients(notifyFlag: TImg32Notification); protected 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 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; function LoadUsingFontHdl(hdl: HFont): Boolean; {$ENDIF} function GetGlyphInfo(unicode: Word; out paths: TPathsD; out nextX: integer; out glyphMetrics: TGlyphMetrics): Boolean; property FontFamily: TTtfFontFamily read GetFontFamily; property FontInfo: TFontInfo read GetFontInfo; property Weight: integer read GetWeight; //range 100-900 end; PGlyphInfo = ^TGlyphInfo; TGlyphInfo = record unicode : Word; contours : TPathsD; metrics : TGlyphMetrics; end; TTextPageMetrics = record lineCount : integer; maxLineWidth : double; wordListOffsets : TArrayOfInteger; justifyDeltas : TArrayOfDouble; lineWidths : TArrayOfDouble; end; TWordInfoList = class; TWordInfo = class index : integer; aWord : UnicodeString; width : double; length : integer; paths : TArrayOfPathsD; constructor Create(owner: TWordInfoList; idx: integer); end; TFontCache = class; //TWordInfoList: A font formatted word list where text is broken into //individual words and stored with their glyph info. This class is very //useful with custom text editors. TWordInfoList = class private {$IFDEF XPLAT_GENERICS} fList : TList; {$ELSE} fList : TList; {$ENDIF} fSingleLine : Boolean; //fListUpdates: accommodates many calls to UpdateWordList //by occasionally refreshing glyph outlines. //fListUpdates: integer; fUpdateCount: integer; fOnChanged : TNotifyEvent; function GetWord(index: integer): TWordInfo; function GetText: UnicodeString; protected procedure Changed; Virtual; public constructor Create; destructor Destroy; override; procedure BeginUpdate; procedure EndUpdate; procedure ApplyNewFont(font: TFontCache); procedure Clear; function Count: integer; procedure Edit(font: TFontCache; index: Integer; const newWord: string); procedure Delete(Index: Integer); procedure DeleteRange(startIdx, endIdx: Integer); procedure AddNewline; procedure AddSpace(font: TFontCache); overload; procedure AddSpace(spaceWidth: double); overload; procedure AddWord(font: TFontCache; const word: UnicodeString; underlineIdx: integer = 0); procedure InsertNewline(index: integer); procedure InsertSpace(font: TFontCache; index: integer); overload; procedure InsertSpace(spaceWidth: double; index: integer); overload; procedure InsertWord(font: TFontCache; index: integer; const word: UnicodeString; underlineIdx: integer = 0); procedure SetText(const text: UnicodeString; font: TFontCache; underlineIdx: integer = 0); property ForceSingleLine: Boolean read fSingleLine write fSingleLine; property WordInfo[index: integer]: TWordInfo read GetWord; default; property Text: UnicodeString read GetText; property OnChanged: TNotifyEvent read fOnChanged write fOnChanged; 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 them too (which is necessary on Windows PCs). TFontCache = class(TInterfacedObj, INotifySender, INotifyRecipient) private {$IFDEF XPLAT_GENERICS} fGlyphInfoList : TList; {$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: WORD): Boolean; function AddGlyph(unicode: Word): 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: TArrayOfWord); function IsValidFont: Boolean; function GetAscent: double; function GetDescent: double; function GetLineHeight: double; function GetYyHeight: double; function GetTextOutlineInternal(x, y: double; const text: UnicodeString; out glyphs: TArrayOfPathsD; out nextX: double; underlineIdx: integer = 0): Boolean; 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 GetCharInfo(charOrdinal: WORD): PGlyphInfo; function GetTextOutline(x, y: double; const text: UnicodeString): TPathsD; overload; function GetTextOutline(const rec: TRect; const text: UnicodeString; textAlign: TTextAlign; textAlignV: TTextVAlign; underlineIdx: integer = 0): TPathsD; overload; function GetTextOutline(const rec: TRect; wordList: TWordInfoList; tpm: TTextPageMetrics; textAlign: TTextAlign; startLine, endLine: integer): TPathsD; overload; function GetTextOutline(x, y: double; const text: UnicodeString; out nextX: double; underlineIdx: integer = 0): TPathsD; overload; function GetVerticalTextOutline(x, y: double; const text: UnicodeString; interCharSpace: double =0): TPathsD; function GetAngledTextGlyphs(x, y: double; const text: UnicodeString; angleRadians: double; const rotatePt: TPointD; out nextPt: TPointD): TPathsD; function GetCharOffsets(const text: UnicodeString; interCharSpace: double = 0): TArrayOfDouble; function GetTextWidth(const text: UnicodeString): double; function GetSpaceWidth: double; property Ascent: double read GetAscent; property Descent: double read GetDescent; 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; //Given a wordList and a specified maximum line width (in pixels), //get both the line count and the offsets to the words in wordlist //that will start each line. function GetPageMetrics(lineWidth: double; wordList: TWordInfoList): TTextPageMetrics; function DrawText(image: TImage32; x, y: double; const text: UnicodeString; font: TFontCache; textColor: TColor32 = clBlack32; useClearType: Boolean = false; clearTypeBgColor: TColor32 = clWhite32): double; overload; function DrawText(image: TImage32; x, y: double; const text: UnicodeString; font: TFontCache; renderer: TCustomRenderer): double; overload; procedure DrawText(image: TImage32; const rec: TRect; const text: UnicodeString; textAlign: TTextAlign; textAlignV: TTextVAlign; font: TFontCache; textColor: TColor32 = clBlack32; useClearType: Boolean = false; clearTypeBgColor: TColor32 = clWhite32); overload; function DrawAngledText(image: TImage32; x, y: double; angleRadians: double; const text: UnicodeString; font: TFontCache; textColor: TColor32 = clBlack32): TPointD; function DrawVerticalText(image: TImage32; x, y, interCharSpace: double; const text: UnicodeString; font: TFontCache; textColor: TColor32 = clBlack32): double; 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; {$IFDEF MSWINDOWS} procedure CheckFontHeight(var logFont: TLogFont); function PointHeightToPixelHeight(pt: double): double; function GetFontFolder: string; function GetInstalledTtfFilenames: TArrayOfString; {$ENDIF} function FontManager: TFontManager; implementation uses Img32.Vector; resourcestring rsTooManyFonts = 'TFontManager error: Too many fonts are open.'; rsWordListRangeError = 'TFFWordList: range error.'; rsFontCacheError = 'TFontCache error: message from incorrect TFontReader'; rsWordListFontError = 'TFFWordList: invalid font error.'; var aFontManager: TFontManager; const lineFrac = 0.05; //------------------------------------------------------------------------------ // Miscellaneous functions //------------------------------------------------------------------------------ //GetMeaningfulDateTime: returns UTC date & time procedure GetMeaningfulDateTime(const secsSince1904: Uint64; out yy,mo,dd, hh,mi,ss: cardinal); const dim: 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 //nb: Centuries are not leap years unless they are multiples of 400. // 2000 WAS a leap year, but 2100 won't be. // Validate function 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 START 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; while dim[isLeapYr, mo] < dd do inc(mo); ss := ss - (dim[isLeapYr, mo-1] * secsPerDay); //remaining secs in month dd := 1 + (ss div secsPerDay); ss := ss mod secsPerDay; hh := ss div secsPerHour; ss := ss mod secsPerHour; mi := ss div 60; ss := ss mod 60; end; //------------------------------------------------------------------------------ function MergePathsArray(const pa: TArrayOfPathsD): TPathsD; var i: integer; begin Result := nil; for i := 0 to High(pa) do AppendPath(Result, pa[i]); 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); begin stream.Read(value, 1); end; //------------------------------------------------------------------------------ procedure GetShortInt(stream: TStream; out value: ShortInt); begin stream.Read(value, 1); end; //------------------------------------------------------------------------------ function GetWord(stream: TStream; out value: WORD): Boolean; begin result := stream.Position + SizeOf(value) < stream.Size; stream.Read(value, SizeOf(value)); value := WordSwap(value); end; //------------------------------------------------------------------------------ function GetInt16(stream: TStream; out value: Int16): Boolean; begin result := stream.Position + SizeOf(value) < stream.Size; stream.Read(value, SizeOf(value)); value := Int16Swap(value); end; //------------------------------------------------------------------------------ function GetCardinal(stream: TStream; out value: Cardinal): Boolean; begin result := stream.Position + SizeOf(value) < stream.Size; stream.Read(value, SizeOf(value)); value := Cardinal(Int32Swap(Integer(value))); end; //------------------------------------------------------------------------------ function GetInt(stream: TStream; out value: integer): Boolean; begin result := stream.Position + SizeOf(value) < stream.Size; stream.Read(value, SizeOf(value)); value := Int32Swap(value); end; //------------------------------------------------------------------------------ function GetUInt64(stream: TStream; out value: UInt64): Boolean; begin result := stream.Position + SizeOf(value) < stream.Size; 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; length: integer): UnicodeString; var i: integer; w: Word; begin length := length div 2; setLength(Result, length); for i := 1 to length do begin GetWord(stream, w); //nb: reverses byte order if w = 0 then begin SetLength(Result, i -1); break; end; result[i] := WideChar(w); end; end; //------------------------------------------------------------------------------ function GetAnsiString(stream: TStream; len: integer): string; var i: integer; ansi: UTF8String; begin setLength(ansi, len+1); ansi[len+1] := #0; stream.Read(ansi[1], len); result := string(ansi); for i := 1 to length(Result) do if Result[i] = #0 then begin SetLength(Result, i -1); break; end; 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; fCmapTblRecs := nil; fFormat4Offset := 0; fFormat4EndCodes := nil; fKernTable := nil; FillChar(fTbl_post, SizeOf(fTbl_post), 0); fTbl_glyf.numContours := 0; fFontInfo.fontFormat := ffInvalid; fFontInfo.fontFamily := ttfUnknown; 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 //when destroying in a finalization section //it's possible for recipients to have been destroyed //without their destructors being called. 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 SelectObject(memDc, hdl); //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 logfont: TLogFont; hdl: HFont; begin Result := false; FillChar(logfont, SizeOf(logfont), 0); StrPCopy(@logfont.lfFaceName[0], fontname); hdl := CreateFontIndirect(logfont); if hdl = 0 then Exit; 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.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; if not Result then Exit; if (fTblIdxes[tblKern] >= 0) then GetTable_kern; if (fTblIdxes[tblPost] >= 0) then GetTable_post; fFontInfo.fontFamily := GetFontFamily; end; //------------------------------------------------------------------------------ function TFontReader.GetTable_cmap: Boolean; var i, segCount: integer; reserved: WORD; cmapRec: TCmapTblRec; format4Rec: TCmapFormat4; cmapTbl: TFontTable; 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(fCmapTblRecs, fTbl_cmap.numTables); for i := 0 to fTbl_cmap.numTables -1 do begin GetWord(fStream, fCmapTblRecs[i].platformID); GetWord(fStream, fCmapTblRecs[i].encodingID); GetCardinal(fStream, fCmapTblRecs[i].offset); end; i := 0; while (i < fTbl_cmap.numTables) and (fCmapTblRecs[i].platformID <> 0) and (fCmapTblRecs[i].platformID <> 3) do inc(i); if i = fTbl_cmap.numTables then Exit; cmapRec := fCmapTblRecs[i]; fStream.Position := cmapTbl.offset + cmapRec.offset; GetWord(fStream, format4Rec.format); GetWord(fStream, format4Rec.length); GetWord(fStream, format4Rec.language); if format4Rec.format = 0 then begin for i := 0 to 255 do GetByte(fStream, fFormat0CodeMap[i]); fFontInfo.glyphCount := 255; end else if format4Rec.format = 4 then begin 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(fFormat4EndCodes, segCount); for i := 0 to segCount -1 do GetWord(fStream, fFormat4EndCodes[i]); if fFormat4EndCodes[segCount-1] <> $FFFF then Exit; //error GetWord(fStream, reserved); if reserved <> 0 then Exit; //error SetLength(fFormat4StartCodes, segCount); for i := 0 to segCount -1 do GetWord(fStream, fFormat4StartCodes[i]); if fFormat4StartCodes[segCount-1] <> $FFFF then Exit; //error SetLength(fFormat4IdDelta, segCount); for i := 0 to segCount -1 do GetWord(fStream, fFormat4IdDelta[i]); SetLength(fFormat4RangeOff, segCount); fFormat4Offset := fStream.Position; for i := 0 to segCount -1 do GetWord(fStream, fFormat4RangeOff[i]); end else Exit; //unsupported format Result := true; end; //------------------------------------------------------------------------------ function TFontReader.GetGlyphIdxFromCmapIdx(idx: Word): integer; var i: integer; w: WORD; begin if fFormat4Offset = 0 then begin if idx > 255 then Result := 0 else Result := fFormat0CodeMap[idx]; Exit; end; //Format4 mapping result := 0; //default to the 'missing' glyph for i := 0 to High(fFormat4EndCodes) do if idx <= fFormat4EndCodes[i] then begin if idx < fFormat4StartCodes[i] then Exit; if fFormat4RangeOff[i] > 0 then begin fStream.Position := fFormat4Offset + fFormat4RangeOff[i] + 2 * (i + idx - fFormat4StartCodes[i]); GetWord(fStream, w); if w < fTbl_maxp.numGlyphs then Result := w; end else result := (fFormat4IdDelta[i] + idx) and $FFFF; Exit; 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): UnicodeString; 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 := UnicodeString(GetAnsiString(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.style := ''; nameTbl := fTables[fTblIdxes[tblName]]; Result := (fStream.Size >= nameTbl.offset + nameTbl.length) 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..7: continue; 8: fFontInfo.manufacturer := GetNameRecString(fStream, nameRec, offset); else break; end; end; end; //------------------------------------------------------------------------------ function TFontReader.GetTable_head: Boolean; var headTbl: TFontTable; yy,mo,dd,hh,mi,ss: cardinal; begin headTbl := fTables[fTblIdxes[tblHead]]; Result := (fStream.Size >= headTbl.offset + headTbl.length) 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 := (fStream.Size >= hheaTbl.offset + hheaTbl.length) 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: integer): Boolean; var tbl : TFontTable; begin tbl := fTables[fTblIdxes[tblHmtx]]; Result := (fStream.Size >= tbl.offset + tbl.length); if not Result then Exit; if glyphIdx < fTbl_hhea.numLongHorMets then begin fStream.Position := Integer(tbl.offset) + glyphIdx * 4; GetWord(fStream, fTbl_hmtx.advanceWidth); GetInt16(fStream, fTbl_hmtx.leftSideBearing); end else begin fStream.Position := Integer(tbl.offset) + Integer(fTbl_hhea.numLongHorMets -1) * 4; GetWord(fStream, fTbl_hmtx.advanceWidth); fStream.Position := Integer(tbl.offset + fTbl_hhea.numLongHorMets * 4) + 2 * (glyphIdx - Integer(fTbl_hhea.numLongHorMets)); GetInt16(fStream, fTbl_hmtx.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 (fStream.Size < tbl.offset + tbl.length) 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 (fStream.Size < tbl.offset + tbl.length) 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: integer; 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: integer): 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: integer): 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, fTbl_glyf.numContours); GetInt16(fStream, fTbl_glyf.xMin); GetInt16(fStream, fTbl_glyf.yMin); GetInt16(fStream, fTbl_glyf.xMax); GetInt16(fStream, fTbl_glyf.yMax); if fTbl_glyf.numContours < 0 then result := GetCompositeGlyph else result := GetSimpleGlyph; 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: TPathsEx; var i,j: integer; instructLen: WORD; flag, repeats: byte; contourEnds: TArrayOfWord; begin SetLength(contourEnds, fTbl_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, fTbl_glyf.numContours); setLength(result[0], contourEnds[0] +1); for i := 1 to High(result) do setLength(result[i], contourEnds[i] - contourEnds[i-1]); repeats := 0; for i := 0 to High(result) do begin for j := 0 to High(result[i]) 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; GetPathCoords(result); end; //------------------------------------------------------------------------------ procedure TFontReader.GetPathCoords(var paths: TPathsEx); var i,j: integer; xi,yi: Int16; flag, xb,yb: byte; pt: TPoint; begin if fTbl_glyf.numContours = 0 then Exit; //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 GetInt16(fStream, xi); 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 GetInt16(fStream, yi); 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); const q = 9.2863575e-4; // 33/35536 var i,j: integer; m0,n0,m,n,xx: double; begin m0 := max(abs(a), abs(b)); n0 := max(abs(c), abs(d)); if (m0 = 0) or (n0 = 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 //see https://developer.apple.com/fonts ... //... /TrueType-Reference-Manual/RM06/Chap6glyf.html if (abs(a)-abs(c))< q then m := 2 * m0 else m := m0; if (abs(b)-abs(d))< q then n := 2 * n0 else n := n0; for i := 0 to High(pathsEx) do for j := 0 to High(pathsEx[i]) do with pathsEx[i][j].pt do begin xx := m * ((a/m)*X + (c/m)*Y + e); y := m * ((b/n)*X + (d/n)*Y + f); X := xx; end; end; end; //------------------------------------------------------------------------------ function TFontReader.GetCompositeGlyph: TPathsEx; var streamPos: integer; flag, glyphIndex: WORD; arg1b, arg2b: ShortInt; arg1i, arg2i: Int16; tmp: single; a,b,c,d,e,f: double; componentPaths: TPathsEx; tbl_glyf_old: TFontTable_Glyf; 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, arg1i); GetInt16(fStream, arg2i); if (flag and ARGS_ARE_XY_VALUES <> 0) then begin e := arg1i; f := arg2i; end; end else begin GetShortInt(fStream, arg1b); GetShortInt(fStream, arg2b); if (flag and ARGS_ARE_XY_VALUES <> 0) then begin e := arg1b; f := arg2b; end; end; if (flag and WE_HAVE_A_SCALE <> 0) then begin Get2Dot14(fStream, tmp); a := tmp; d := tmp; end else if (flag and WE_HAVE_AN_X_AND_Y_SCALE <> 0) then begin Get2Dot14(fStream, tmp); a := tmp; Get2Dot14(fStream, tmp); d := tmp; end else if (flag and WE_HAVE_A_TWO_BY_TWO <> 0) then begin Get2Dot14(fStream, tmp); a := tmp; Get2Dot14(fStream, tmp); b := tmp; Get2Dot14(fStream, tmp); c := tmp; Get2Dot14(fStream, tmp); d := tmp; end; tbl_glyf_old := fTbl_glyf; streamPos := fStream.Position; componentPaths := GetGlyphPaths(glyphIndex); fStream.Position := streamPos; if (flag and ARGS_ARE_XY_VALUES <> 0) then begin if (flag and USE_MY_METRICS <> 0) then begin if Result <> nil then AffineTransform(a,b,c,d,e,f, result); end else AffineTransform(a,b,c,d,e,f, componentPaths); end; if tbl_glyf_old.numContours > 0 then begin inc(fTbl_glyf.numContours, tbl_glyf_old.numContours); fTbl_glyf.xMin := Min(fTbl_glyf.xMin, tbl_glyf_old.xMin); fTbl_glyf.xMax := Max(fTbl_glyf.xMax, tbl_glyf_old.xMax); fTbl_glyf.yMin := Min(fTbl_glyf.yMin, tbl_glyf_old.yMin); fTbl_glyf.yMax := Max(fTbl_glyf.yMax, tbl_glyf_old.yMax); end; AppendPathsEx(result, componentPaths); end; end; //------------------------------------------------------------------------------ function TFontReader.GetGlyphInfo(unicode: Word; out paths: TPathsD; out nextX: integer; out glyphMetrics: TGlyphMetrics): Boolean; var i,j, glyphIdx: integer; pt2: TPointEx; bez: TPathD; pathsEx: TPathsEx; begin paths := nil; Result := IsValidFontFormat; if not Result then Exit; glyphIdx := GetGlyphIdxFromCmapIdx(unicode); if not GetGlyphHorzMetrics(glyphIdx) then Exit; pathsEx := GetGlyphPaths(glyphIdx); //gets raw splines pathsEx := ConvertSplinesToBeziers(pathsEx); glyphMetrics := GetGlyphMetricsInternal(glyphIdx); //nb: must follow GetGlyphPaths nextX := fTbl_hmtx.advanceWidth; if pathsEx = nil then Exit; //eg space character //now flatten ... setLength(paths, length(pathsEx)); for i := 0 to High(pathsEx) do begin SetLength(paths[i],1); paths[i][0] := pathsEx[i][0].pt; for j := 1 to High(pathsEx[i]) do begin if OnCurve(pathsEx[i][j].flag) then begin AppendPoint(paths[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); AppendPath(paths[i], bez); end; end; end; end; //------------------------------------------------------------------------------ function TFontReader.GetFontInfo: TFontInfo; begin if not IsValidFontFormat then begin result.faceName := ''; result.style := ''; result.unitsPerEm := 0; end else begin result := fFontInfo; //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; end; //------------------------------------------------------------------------------ function TFontReader.GetGlyphMetricsInternal(glyphIdx: integer): TGlyphMetrics; begin if IsValidFontFormat then begin result.glyphIdx := glyphIdx; result.unitsPerEm := fTbl_head.unitsPerEm; result.glyf := fTbl_glyf; result.hmtx := ftbl_hmtx; Result.kernList := GetGlyphKernList(glyphIdx); end else FillChar(result, sizeOf(Result), 0) end; //------------------------------------------------------------------------------ function TFontReader.GetWeight: integer; var glyph: TPathsD; i, dummy: integer; accum: Cardinal; gm: TGlyphMetrics; rec: TRectD; img: TImage32; p: PARGB; const imgSize = 16; k = 5; //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'),glyph, dummy, gm); rec := GetBoundsD(glyph); glyph := Img32.Vector.OffsetPath(glyph, -rec.Left, -rec.Top); glyph := Img32.Vector.ScalePath(glyph, imgSize/rec.Width, imgSize/rec.Height); img := TImage32.Create(imgSize,imgSize); try DrawPolygon(img, glyph, 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; //------------------------------------------------------------------------------ function TFontReader.GetFontFamily: TTtfFontFamily; var dummy: integer; glyphsT, glyphsI, glyphsM: TPathsD; gmT, gmI, gmM: TGlyphMetrics; begin result := ttfUnknown; if (fTbl_post.majorVersion > 0) and (fTbl_post.isFixedPitch <> 0) then begin result := ttfMonospace; Exit; end else begin if not GetGlyphInfo(Ord('T'), glyphsT, dummy, gmT) or not Assigned(glyphsT) or not GetGlyphInfo(Ord('i'), glyphsI, dummy, gmI) or not GetGlyphInfo(Ord('m'), glyphsM, dummy, gmM) then Exit; if gmi.hmtx.advanceWidth = gmm.hmtx.advanceWidth then Result := ttfMonospace else if Length(glyphsT[0]) <= 12 then //probably <= 8 is fine too. Result := ttfSansSerif else Result := ttfSerif; end; end; //------------------------------------------------------------------------------ // TFontCache //------------------------------------------------------------------------------ constructor TFontCache.Create(fontReader: TFontReader; fontHeight: double); begin {$IFDEF XPLAT_GENERICS} fGlyphInfoList := TList.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 //when destroying in in a finalization section //it's possible for recipients to have been destroyed //without their destructors being called. 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: WORD; glyphList: TList): integer; {$ELSE} function FindInSortedList(charOrdinal: WORD; 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 := PGlyphInfo(glyphList[Result]).unicode - 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: WORD): Boolean; begin if not fSorted then Sort; result := FindInSortedList(charOrdinal, fGlyphInfoList) >= 0; end; //------------------------------------------------------------------------------ procedure TFontCache.GetMissingGlyphs(const ordinals: TArrayOfWord); 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.GetLineHeight: double; begin if not IsValidFont then Result := 0 else Result := Ascent + Descent; end; //------------------------------------------------------------------------------ function TFontCache.GetYyHeight: double; var minY, maxY: double; begin //nb: non-inverted Y coordinates. maxY := GetCharInfo(ord('Y')).metrics.glyf.yMax; minY := GetCharInfo(ord('y')).metrics.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: integer; 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.GetCharInfo(charOrdinal: WORD): PGlyphInfo; var listIdx: integer; begin Result := nil; if not fSorted then Sort; listIdx := FindInSortedList(charOrdinal, fGlyphInfoList); if listIdx < 0 then begin if not IsValidFont then Exit; Result := AddGlyph(Ord(charOrdinal)); end else Result := PGlyphInfo(fGlyphInfoList[listIdx]); end; //------------------------------------------------------------------------------ function TFontCache.GetCharOffsets(const text: UnicodeString; interCharSpace: double): TArrayOfDouble; var i,j, len: integer; ordinals: TArrayOfWord; glyphInfo: PGlyphInfo; thisX: double; prevGlyphKernList: TArrayOfTKern; begin len := length(text); SetLength(ordinals, len); for i := 0 to len -1 do ordinals[i] := Ord(text[i+1]); SetLength(Result, len +1); Result[0] := 0; if len = 0 then Exit; GetMissingGlyphs(ordinals); thisX := 0; prevGlyphKernList := nil; for i := 0 to High(ordinals) do begin glyphInfo := GetCharInfo(ordinals[i]); if not assigned(glyphInfo) then Break; if fUseKerning and assigned(prevGlyphKernList) then begin j := FindInKernList(glyphInfo.metrics.glyphIdx, prevGlyphKernList); if (j >= 0) then thisX := thisX + prevGlyphKernList[j].kernValue*fScale; end; Result[i] := thisX; thisX := thisX + glyphInfo.metrics.hmtx.advanceWidth*fScale +interCharSpace; prevGlyphKernList := glyphInfo.metrics.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 := GetCharOffsets(text); Result := offsets[high(offsets)]; end; //------------------------------------------------------------------------------ function TFontCache.GetSpaceWidth: double; begin Result := GetCharInfo(32).metrics.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(const rec: TRect; wordList: TWordInfoList; tpm: TTextPageMetrics; textAlign: TTextAlign; startLine, endLine: integer): TPathsD; var i,j, a,b: integer; x,y,lh, spcDx, lineWidth: double; pp: TPathsD; app: TArrayOfPathsD; begin Result := nil; if not Assigned(wordList) or (wordList.Count = 0) then Exit; lh := GetLineHeight; y := rec.Top; if startLine < 0 then startLine := 0; if (endLine < 0) or (endLine >= tpm.lineCount) then endLine := tpm.lineCount -1; for i := startLine to endLine do begin a := tpm.wordListOffsets[i]; b := tpm.wordListOffsets[i+1] -1; if textAlign = taJustify then spcDx := tpm.justifyDeltas[i] else spcDx := 0; lineWidth := tpm.lineWidths[i]; //ingore trailing spaces while (b >= a) do with wordList.GetWord(b) do if aWord <= #32 then dec(b) else break; case textAlign of taRight : x := rec.Left + (RectWidth(rec) - lineWidth); taCenter : x := rec.Left + (RectWidth(rec) - lineWidth)/2; else x := rec.Left; end; for j := a to b do with wordList.GetWord(j) do if aWord > #32 then begin app := OffsetPath(paths, x, y + Ascent); pp := MergePathsArray(app); AppendPath(Result, pp); x := x + width; end else x := x + width + spcDx; y := y + lh; end; end; //------------------------------------------------------------------------------ function TFontCache.GetTextOutline(const rec: TRect; const text: UnicodeString; textAlign: TTextAlign; textAlignV: TTextVAlign; underlineIdx: integer): TPathsD; var y,dy : double; wl : TWordInfoList; tpm : TTextPageMetrics; begin Result := nil; wl := TWordInfoList.Create; try wl.SetText(text, Self, underlineIdx); tpm := GetPageMetrics(RectWidth(rec), wl); Result := GetTextOutline(rec, wl, tpm, textAlign, 0, -1); case textAlignV of tvaMiddle: begin y := GetLineHeight * tpm.lineCount; dy := (RectHeight(rec) -y) /2 -1; end; tvaBottom: begin y := GetLineHeight * tpm.lineCount; dy := (RectHeight(rec) -y); end; else Exit; end; Result := OffsetPath(Result, 0, dy); finally wl.Free; end; end; //------------------------------------------------------------------------------ function TFontCache.GetTextOutline(x, y: double; const text: UnicodeString; out nextX: double; underlineIdx: integer): TPathsD; var i: integer; w, y2: double; p: TPathD; arrayOfGlyphs: TArrayOfPathsD; begin Result := nil; if not GetTextOutlineInternal(x, y, text, arrayOfGlyphs, nextX, underlineIdx) then Exit; if fUnderlined then begin w := LineHeight * lineFrac; y2 := y + 1.5 *(1+w); p := Rectangle(x, y2, nextX, y2 + w); AppendPath(Result, p); end; for i := 0 to high(arrayOfGlyphs) do AppendPath(Result, arrayOfGlyphs[i]); if fStrikeOut then begin w := LineHeight * lineFrac; y := y - LineHeight/4; p := Rectangle(x, y , nextX, y + w); AppendPath(Result, p); end; end; //------------------------------------------------------------------------------ function TFontCache.GetVerticalTextOutline(x, y: double; const text: UnicodeString; interCharSpace: double): TPathsD; var i, xxMax: integer; glyphInfo: PGlyphInfo; dx, dy: double; begin Result := nil; if not IsValidFont then Exit; xxMax := 0; for i := 1 to Length(text) do begin glyphInfo := GetCharInfo(ord(text[i])); if not assigned(glyphInfo) then Exit; with glyphInfo.metrics.glyf do if xMax > xxMax then xxMax := xMax; end; for i := 1 to Length(text) do begin glyphInfo := GetCharInfo(ord(text[i])); with glyphInfo.metrics.glyf do begin dx := (xxMax - xMax) * 0.5 * scale; y := y + yMax * scale; //yMax = char ascent dy := - yMin * scale; //yMin = char descent end; AppendPath(Result, Img32.Vector.OffsetPath( glyphInfo.contours, x + dx, y)); if text[i] = #32 then y := y + dy - interCharSpace else y := y + dy + interCharSpace; end; end; //------------------------------------------------------------------------------ function TFontCache.GetTextOutlineInternal(x, y: double; const text: UnicodeString; out glyphs: TArrayOfPathsD; out nextX: double; underlineIdx: integer): Boolean; var i,j, len : integer; dx,y2,w : double; unicodes : TArrayOfWord; glyphInfo : PGlyphInfo; p : TPathD; currGlyph : TPathsD; prevGlyphKernList: TArrayOfTKern; begin len := Length(text); unicodes := nil; setLength(unicodes, len); for i := 0 to len -1 do unicodes[i] := Ord(text[i +1]); Result := true; GetMissingGlyphs(unicodes); nextX := x; prevGlyphKernList := nil; dec(underlineIdx);//convert from 1 base to 0 base index for i := 0 to len -1 do begin glyphInfo := GetCharInfo(unicodes[i]); if not assigned(glyphInfo) then Break; if fUseKerning and assigned(prevGlyphKernList) then begin j := FindInKernList(glyphInfo.metrics.glyphIdx, prevGlyphKernList); if (j >= 0) then nextX := nextX + prevGlyphKernList[j].kernValue * fScale; end; currGlyph := OffsetPath(glyphInfo.contours, nextX, y); dx := glyphInfo.metrics.hmtx.advanceWidth * fScale; if i = underlineIdx then begin w := LineHeight * lineFrac; y2 := y + 1.5 * (1 + w); p := Rectangle(nextX, y2, nextX +dx, y2 + w); AppendPath(currGlyph, p); end; AppendPath(glyphs, currGlyph); nextX := nextX + dx; prevGlyphKernList := glyphInfo.metrics.kernList; end; 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); 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 begin fScale := fFontHeight / fFontReader.FontInfo.unitsPerEm; NotifyRecipients(inStateChange); end else begin fScale := 1; NotifyRecipients(inDestroy); end; end; //------------------------------------------------------------------------------ procedure TFontCache.SetFontHeight(newHeight: double); begin if fFontHeight = newHeight then Exit; fFontHeight := abs(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.contours); end; fFlipVert := value; end; //------------------------------------------------------------------------------ function GlyphSorter(glyph1, glyph2: pointer): integer; begin Result := PGlyphInfo(glyph1).unicode - PGlyphInfo(glyph2).unicode; end; //------------------------------------------------------------------------------ procedure TFontCache.Sort; begin {$IFDEF XPLAT_GENERICS} fGlyphInfoList.Sort(TComparer.Construct( function (const glyph1, glyph2: PGlyphInfo): integer begin Result := glyph1.unicode - glyph2.unicode; end)); {$ELSE} fGlyphInfoList.Sort(GlyphSorter); {$ENDIF} fSorted := true; end; //------------------------------------------------------------------------------ function TFontCache.AddGlyph(unicode: Word): PGlyphInfo; var dummy: integer; const minLength = 0.25; begin New(Result); Result.unicode := unicode; fFontReader.GetGlyphInfo(unicode, Result.contours, dummy, Result.metrics); fGlyphInfoList.Add(Result); if fFontHeight > 0 then begin Result.contours := ScalePath(Result.contours, fScale); //text rendering is about twice as fast when excess detail is removed Result.contours := StripNearDuplicates(Result.contours, minLength, true); end; if fFlipVert then VerticalFlip(Result.contours); 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 CheckFontHeight(var logFont: TLogFont); const _96Div72 = 96/72; begin if logFont.lfHeight > 0 then logFont.lfHeight := -Round(DpiAware(logFont.lfHeight * _96Div72)); end; //------------------------------------------------------------------------------ function PointHeightToPixelHeight(pt: double): double; const _96Div72 = 96/72; begin Result := Abs(pt) * _96Div72; 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; {$ENDIF} //------------------------------------------------------------------------------ //------------------------------------------------------------------------------ function DrawText(image: TImage32; x, y: double; const text: UnicodeString; font: TFontCache; textColor: TColor32 = clBlack32; useClearType: Boolean = false; clearTypeBgColor: TColor32 = clWhite32): 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); if useClearType then DrawPolygon_ClearType(image, glyphs, frNonZero, textColor, clearTypeBgColor) else 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: TRect; const text: UnicodeString; textAlign: TTextAlign; textAlignV: TTextVAlign; font: TFontCache; textColor: TColor32 = clBlack32; useClearType: Boolean = false; clearTypeBgColor: TColor32 = clWhite32); var glyphs: TPathsD; begin if (text = '') or not assigned(font) or not font.IsValidFont then Exit; glyphs := font.GetTextOutline(rec, text, textAlign, textAlignV); if useClearType then DrawPolygon_ClearType(image, glyphs, frNonZero, textColor, clearTypeBgColor) else 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 Exit; glyphs := font.GetAngledTextGlyphs(x, y, text, angleRadians, rotatePt, Result); DrawPolygon(image, glyphs, frNonZero, textColor); end; //------------------------------------------------------------------------------ function DrawVerticalText(image: TImage32; x, y, interCharSpace: double; const text: UnicodeString; font: TFontCache; textColor: TColor32 = clBlack32): double; var i, xxMax: integer; glyphs: TPathsD; glyphInfo: PGlyphInfo; dx, dy, scale: double; begin Result := y; if not assigned(font) or not font.IsValidFont then Exit; xxMax := 0; for i := 1 to Length(text) do begin glyphInfo := font.GetCharInfo(ord(text[i])); if not assigned(glyphInfo) then Exit; with glyphInfo.metrics.glyf do if xMax > xxMax then xxMax := xMax; end; scale := font.Scale; for i := 1 to Length(text) do begin glyphInfo := font.GetCharInfo(ord(text[i])); with glyphInfo.metrics.glyf do begin dx := (xxMax - xMax) * 0.5 * scale; y := y + yMax * scale; //yMax = char ascent dy := - yMin * scale; //yMin = char descent end; glyphs := Img32.Vector.OffsetPath( glyphInfo.contours, x + dx, y); DrawPolygon(image, glyphs, frNonZero, textColor); if text[i] = #32 then y := y + dy - interCharSpace else y := y + dy + interCharSpace; end; Result := y; end; //------------------------------------------------------------------------------ type TPathInfo = record pt : TPointD; vector : TPointD; angle : Double; dist : double; end; TPathInfos = array of TPathInfo; 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; textAlign: TTextAlign; perpendicOffset: integer; charSpacing: double; out charsThatFit: integer): TPathsD; overload; var pathLen: integer; pathInfos: TPathInfos; function GetPathInfo(var startIdx: integer; offset: double): TPathInfo; begin while startIdx <= pathLen do begin if pathInfos[startIdx].dist > offset then break; inc(startIdx); end; Result := pathInfos[startIdx -1]; if Result.angle >= 0 then Exit; //ie already initialized Result.angle := GetAngle(path[startIdx-1], path[startIdx]); Result.vector := GetUnitVector(path[startIdx-1], path[startIdx]); Result.pt := path[startIdx -1]; end; var i, pathInfoIdx: integer; textWidth, left, center, center2, scale, dist, dx: double; glyph: PGlyphInfo; offsets: TArrayOfDouble; pathInfo: TPathInfo; pt, rotatePt: TPointD; tmpPaths: TPathsD; begin Result := nil; pathLen := Length(path); charsThatFit := Length(text); offsets := font.GetCharOffsets(text, charSpacing); textWidth := offsets[charsThatFit]; setLength(pathInfos, pathLen +1); if (pathLen < 2) or (charsThatFit = 0) then Exit; dist := 0; pathInfos[0].angle := -1; pathInfos[0].dist := 0; for i:= 1 to pathLen -1 do begin pathInfos[i].angle := -1; //flag uninitialized. dist := dist + Distance(path[i-1], path[i]); pathInfos[i].dist := dist; end; //truncate text that doesn't fit ... if offsets[charsThatFit] - ((offsets[charsThatFit] - offsets[charsThatFit-1])*0.5) > dist then begin repeat dec(charsThatFit); until offsets[charsThatFit] <= dist; //break text word boundaries while (charsThatFit > 1) and (text[charsThatFit] <> #32) do dec(charsThatFit); if charsThatFit = 0 then charsThatFit := 1; end; case textAlign of taCenter: Left := (dist - textWidth) * 0.5; taRight : Left := dist - textWidth; else Left := 0; end; scale := font.Scale; Result := nil; pathInfoIdx := 1; for i := 1 to charsThatFit do begin glyph := font.GetCharInfo(Ord(text[i])); with glyph.metrics do center := (glyf.xMax - glyf.xMin) * scale * 0.5; center2 := left + center; left := left + glyph.metrics.hmtx.advanceWidth * scale + charSpacing; pathInfo := GetPathInfo(pathInfoIdx, center2); rotatePt := PointD(center, -perpendicOffset); tmpPaths := RotatePath(glyph.contours, rotatePt, pathInfo.angle); dx := center2 - pathInfo.dist; pt.X := pathInfo.pt.X + pathInfo.vector.X * dx - rotatePt.X; pt.Y := pathInfo.pt.Y + pathInfo.vector.Y * dx - rotatePt.Y; tmpPaths := OffsetPath(tmpPaths, pt.X, pt.Y); AppendPath(Result, tmpPaths); end; end; //------------------------------------------------------------------------------ // TWordInfo //------------------------------------------------------------------------------ constructor TWordInfo.Create(owner: TWordInfoList; idx: integer); begin index := idx; end; //------------------------------------------------------------------------------ // TWordInfoList //------------------------------------------------------------------------------ procedure TWordInfoList.SetText(const text: UnicodeString; font: TFontCache; underlineIdx: integer); var len: integer; spaceW: double; p, p2, pEnd: PWideChar; s: UnicodeString; begin if not Assigned(font) then Exit; BeginUpdate; try Clear; spaceW := font.GetSpaceWidth; p := PWideChar(text); pEnd := p; Inc(pEnd, Length(text)); while p < pEnd do begin if (p^ <= #32) then begin if (p^ = #32) then AddSpace(spaceW) else if (p^ = #10) then AddNewline; inc(p); dec(underlineIdx); end else begin p2 := p; inc(p); while (p < pEnd) and (p^ > #32) do inc(p); len := p - p2; SetLength(s, len); Move(p2^, s[1], len * SizeOf(Char)); AddWord(font, s, underlineIdx); dec(underlineIdx, len); end; end; finally EndUpdate; end; end; //------------------------------------------------------------------------------ procedure TWordInfoList.ApplyNewFont(font: TFontCache); var i: integer; spaceW, dummy: double; wi: TWordInfo; begin if not Assigned(font) then Exit; spaceW := font.GetSpaceWidth; BeginUpdate; try for i := 0 to Count -1 do begin wi := GetWord(i); if wi.aWord <= #32 then begin if wi.aWord = #32 then wi.width := spaceW else wi.width := 0; end else begin font.GetTextOutlineInternal(0,0, wi.aWord, wi.paths, dummy); wi.width := font.GetTextWidth(wi.aWord); end; end; finally EndUpdate; end; end; //------------------------------------------------------------------------------ constructor TWordInfoList.Create; begin inherited; {$IFDEF XPLAT_GENERICS} fList := TList.Create; {$ELSE} fList := TList.Create; {$ENDIF} end; //------------------------------------------------------------------------------ destructor TWordInfoList.Destroy; begin fOnChanged := nil; Clear; fList.Free; inherited; end; //------------------------------------------------------------------------------ function TWordInfoList.GetWord(index: integer): TWordInfo; begin if (index < 0) or (index >= fList.Count) then raise Exception.Create(rsWordListRangeError); Result := TWordInfo(fList.Items[index]); end; //------------------------------------------------------------------------------ function TWordInfoList.GetText: UnicodeString; var i: integer; begin Result := ''; for i := 0 to Count -1 do Result := Result + TWordInfo(fList.Items[i]).aWord; end; //------------------------------------------------------------------------------ procedure TWordInfoList.AddNewline; begin InsertNewline(MaxInt); end; //------------------------------------------------------------------------------ procedure TWordInfoList.AddSpace(font: TFontCache); begin InsertSpace(font, MaxInt); end; //------------------------------------------------------------------------------ procedure TWordInfoList.AddSpace(spaceWidth: double); begin InsertSpace(spaceWidth, MaxInt); end; //------------------------------------------------------------------------------ procedure TWordInfoList.AddWord(font: TFontCache; const word: UnicodeString; underlineIdx: integer); begin InsertWord(font, MaxInt, word, underlineIdx); end; //------------------------------------------------------------------------------ procedure TWordInfoList.InsertNewline(index: integer); var i, cnt: integer; newWord : TWordInfo; begin cnt := fList.Count; if (index > cnt) then index := cnt else if (index < 0) then index := 0; newWord := TWordInfo.Create(self, index); newWord.aWord := #10; newWord.width := 0; newWord.length := 1; newWord.paths := nil; fList.Insert(index, newWord); //reindex if index < cnt then for i := index +1 to cnt do TWordInfo(fList[i]).index := i; end; //------------------------------------------------------------------------------ procedure TWordInfoList.InsertSpace(font: TFontCache; index: integer); var width: double; begin if not Assigned(font) or not font.IsValidFont then raise Exception.Create(rsWordListFontError); width := font.GetCharInfo(32).metrics.hmtx.advanceWidth * font.fScale; InsertSpace(width, index); end; //------------------------------------------------------------------------------ procedure TWordInfoList.InsertSpace(spaceWidth: double; index: integer); var i, cnt: integer; newWord : TWordInfo; begin cnt := fList.Count; if (index > cnt) then index := cnt else if (index < 0) then index := 0; newWord := TWordInfo.Create(self, index); newWord.aWord := #32; newWord.width := spaceWidth; newWord.length := 1; newWord.paths := nil; fList.Insert(index, newWord); //reindex if index < cnt then for i := index +1 to cnt do TWordInfo(fList[i]).index := i; end; //------------------------------------------------------------------------------ procedure TWordInfoList.InsertWord(font: TFontCache; index: integer; const word: UnicodeString; underlineIdx: integer); var i, cnt: integer; width: double; newWord : TWordInfo; ap: TArrayOfPathsD; begin if not Assigned(font) or not font.IsValidFont then raise Exception.Create(rsWordListFontError); font.GetTextOutlineInternal(0,0, word, ap, width, underlineIdx); cnt := fList.Count; if (index > cnt) then index := cnt else if (index < 0) then index := 0; newWord := TWordInfo.Create(self, index); newWord.aWord := word; newWord.width := width; newWord.length := Length(word); newWord.paths := ap; fList.Insert(index, newWord); //reindex if index < cnt then for i := index +1 to cnt do TWordInfo(fList[i]).index := i; end; //------------------------------------------------------------------------------ function TWordInfoList.Count: integer; begin Result := fList.Count; end; //------------------------------------------------------------------------------ procedure TWordInfoList.Clear; var i: integer; begin for i := 0 to fList.Count -1 do TWordInfo(fList.Items[i]).Free; fList.Clear; if Assigned(fOnChanged) then fOnChanged(Self); end; //------------------------------------------------------------------------------ procedure TWordInfoList.BeginUpdate; begin inc(fUpdateCount); end; //------------------------------------------------------------------------------ procedure TWordInfoList.EndUpdate; begin dec(fUpdateCount); if (fUpdateCount = 0) then Changed; end; //------------------------------------------------------------------------------ procedure TWordInfoList.Changed; begin if Assigned(fOnChanged) then fOnChanged(Self); end; //------------------------------------------------------------------------------ procedure TWordInfoList.Delete(Index: Integer); begin if (index < 0) or (index >= fList.Count) then raise Exception.Create(rsWordListRangeError); TWordInfo(fList.Items[index]).Free; fList.Delete(index); if Assigned(fOnChanged) then fOnChanged(Self); end; //------------------------------------------------------------------------------ procedure TWordInfoList.DeleteRange(startIdx, endIdx: Integer); var i, cnt, cnt2: Integer; begin if (startIdx < 0) or (endIdx >= fList.Count) then raise Exception.Create(rsWordListRangeError); for i := startIdx to endIdx do TWordInfo(fList.Items[i]).Free; //fList.DeleteRange(startIdx, endIdx - startIdx +1); cnt := endIdx - startIdx +1; cnt2 := fList.Count - cnt; for i := startIdx to cnt2 -1 do fList[i] := fList[i +cnt]; fList.Count := cnt2; if Assigned(fOnChanged) then fOnChanged(Self); end; //------------------------------------------------------------------------------ procedure TWordInfoList.Edit(font: TFontCache; index: Integer; const newWord: string); var len: integer; dummy: double; begin if (index < 0) or (index >= fList.Count) then raise Exception.Create(rsWordListRangeError); len := system.Length(newWord); if len = 0 then Delete(index) else if Assigned(font) then with TWordInfo(fList.Items[index]) do begin aWord := newWord; length := 1; while (length < len) and (aWord[length+1] > #32) do inc(length); if length < len then SetLength(aWord, length); width := font.GetTextWidth(aWord); font.GetTextOutlineInternal(0,0,aWord, paths, dummy); if Assigned(fOnChanged) then fOnChanged(Self); end; end; //------------------------------------------------------------------------------ function GetPageMetrics(lineWidth: double; wordList: TWordInfoList): TTextPageMetrics; var arrayCnt, arrayCap: integer; procedure CalcLineWidthsAndJustify(idx: integer); var i,j,k, spcCnt: integer; x: double; forceLeftAlign: Boolean; begin j := Result.wordListOffsets[idx] -1; if j < 0 then Exit; forceLeftAlign := wordList.GetWord(j).aWord = #10; i := Result.wordListOffsets[idx -1]; while (j > i) and (wordList.GetWord(j).aWord = #32) do dec(j); spcCnt := 0; x := 0; for k := i to j do with wordList.GetWord(k) do begin if aWord = #32 then inc(spcCnt); x := x + width; end; Result.lineWidths[idx-1] := x; if not forceLeftAlign and (spcCnt > 0) then Result.justifyDeltas[idx-1] := (Result.maxLineWidth - x)/spcCnt; end; procedure AddLine(i: integer); begin if arrayCnt = arrayCap then begin inc(arrayCap, 16); SetLength(Result.wordListOffsets, arrayCap); SetLength(Result.justifyDeltas, arrayCap); SetLength(Result.lineWidths, arrayCap); end; inc(Result.lineCount); Result.wordListOffsets[arrayCnt] := i; Result.justifyDeltas[arrayCnt] := 0.0; if (arrayCnt > 0) then CalcLineWidthsAndJustify(arrayCnt); inc(arrayCnt); end; var i,j, cnt: integer; x: double; wi: TWordInfo; begin Result.lineCount := 0; Result.maxLineWidth := lineWidth; Result.wordListOffsets := nil; arrayCnt := 0; arrayCap := 0; if not Assigned(wordList) or (wordList.Count = 0) then Exit; i := 0; j := 0; cnt := wordList.Count; x := 0; while (i < cnt) do begin wi := wordList.GetWord(i); if (i = j) and (wi.aWord = #32) then begin inc(i); inc(j); Continue; end; if (wi.aWord = #10) then begin AddLine(j); inc(i); j := i; x := 0; end else if (x + wi.width > lineWidth) then begin if j = i then Break; //word is too long for line. Todo: ??hiphenate AddLine(j); j := i; x := 0; end else begin x := x + wi.width; inc(i); end; end; if (j < cnt)then AddLine(j); //add end short line AddLine(cnt); dec(Result.lineCount); SetLength(Result.wordListOffsets, arrayCnt); SetLength(Result.justifyDeltas, arrayCnt); SetLength(Result.lineWidths, arrayCnt); //make sure the 'real' last line isn't justified. Result.justifyDeltas[arrayCnt-2] := 0; //nb: the 'lineWidths' for the very last line may be longer //than maxLineWidth when a word's width exceeds 'maxLineWidth end; //------------------------------------------------------------------------------ // TFontManager //------------------------------------------------------------------------------ constructor TFontManager.Create; begin fMaxFonts := 20; {$IFDEF XPLAT_GENERICS} fFontList := TList.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.GetFont(const fontName: string): TFontReader; var i: integer; begin Result := nil; for i := 0 to fFontList.Count -1 do if SameText(TFontReader(fFontList[i]).fFontInfo.faceName, fontName) then begin Result := fFontList[i]; Exit; end; end; //------------------------------------------------------------------------------ {$IFDEF MSWINDOWS} function TFontManager.Load(const fontName: string): TFontReader; begin if fFontList.Count >= fMaxFonts then raise Exception.Create(rsTooManyFonts); Result := GetFont(fontname); if Assigned(Result) then Exit; Result := TFontReader.Create; try if not Result.Load(fontName) or not ValidateAdd(Result) then FreeAndNil(Result); except FreeAndNil(Result); end; if Assigned(Result) then Result.fFontManager := self; end; //------------------------------------------------------------------------------ {$ENDIF} function TFontManager.LoadFromStream(stream: TStream): TFontReader; begin if fFontList.Count >= fMaxFonts then raise Exception.Create(rsTooManyFonts); Result := TFontReader.Create; try if not Result.LoadFromStream(stream) or not ValidateAdd(Result) then FreeAndNil(Result); except FreeAndNil(Result); end; if Assigned(Result) then Result.fFontManager := self; end; //------------------------------------------------------------------------------ function TFontManager.LoadFromResource(const resName: string; resType: PChar): TFontReader; begin if fFontList.Count >= fMaxFonts then raise Exception.Create(rsTooManyFonts); Result := TFontReader.Create; try if not Result.LoadFromResource(resName, resType) or not ValidateAdd(Result) then FreeAndNil(Result); except FreeAndNil(Result); end; if Assigned(Result) then Result.fFontManager := self; end; //------------------------------------------------------------------------------ function TFontManager.LoadFromFile(const filename: string): TFontReader; begin if fFontList.Count >= fMaxFonts then raise Exception.Create(rsTooManyFonts); Result := TFontReader.Create; try if not Result.LoadFromFile(filename) or not ValidateAdd(Result) then FreeAndNil(Result); except FreeAndNil(Result); end; if Assigned(Result) then Result.fFontManager := self; end; //------------------------------------------------------------------------------ function TFontManager.ValidateAdd(fr: TFontReader): Boolean; var fr2: TFontReader; begin Result := Assigned(fr); if not Result then Exit; //avoid adding duplicates fr2 := GetBestMatchFont(fr.fFontInfo); if not Assigned(fr2) or ((fr.fFontInfo.macStyles <> fr2.fFontInfo.macStyles) or not SameText(fr.fFontInfo.faceName, fr2.fFontInfo.faceName)) then fFontList.Add(fr) else Result := false; 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 TFontManager.GetBestMatchFont(const fontInfo: TFontInfo): TFontReader; function StylesToInt(macstyles: TMacStyles): integer; begin if msBold in macStyles then Result := 1 else Result := 0; if msItalic in macStyles then inc(Result, 2); end; function FamilyToInt(fontFamily: TTtfFontFamily): integer; begin Result := Ord(fontFamily); end; function NameDiff(const name1, name2: string): integer; begin if SameText(name1, name2) then Result := 0 else Result := 1; end; function CompareFontInfos(const fi1, fi2: TFontInfo): integer; var styleDiff: integer; begin styleDiff := Abs(StylesToInt(fi1.macStyles) - StylesToInt(fi2.macStyles)); if styleDiff = 2 then Dec(styleDiff); Result := styleDiff shl 8 + Abs(FamilyToInt(fi1.fontFamily) - FamilyToInt(fi2.fontFamily)) shl 4 + NameDiff(fi1.faceName, fi2.faceName); end; var i, bestIdx: integer; bestDiff, currDiff: integer; begin Result := nil; if fFontList.Count = 0 then Exit; bestIdx := 0; bestDiff := CompareFontInfos(fontInfo, TFontReader(fFontList[0]).fFontInfo); for i := 1 to fFontList.Count -1 do begin currDiff := CompareFontInfos(fontInfo, TFontReader(fFontList[i]).fFontInfo); if (currDiff < bestDiff) then begin bestIdx := i; bestDiff := currDiff; if bestDiff = 0 then Break; end; end; Result := TFontReader(fFontList[bestIdx]); 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 FontManager: TFontManager; begin result := aFontManager; end; //------------------------------------------------------------------------------ initialization aFontManager := TFontManager.Create; finalization aFontManager.Free; end.